XProfan

declarar i%,a%
a%=0
for i%,1,100000000
inc a%
endfor

'Ownerdrawn Buttons

declarar _ende%
declarar _hBrushNormal%,_hBrushClick%,_hBrushHover% SharedInFbProcs
declarar _hPenNormal%,_hPenClick%,_hPenHover%,_hPenFocus%,_hF% SharedInFbProcs
declarar _hB1%,_hB2%,_hB3%,_pMousetracking%,_pOB%,_AnzOwnerDrawButtons%,_pODBClicked% SharedInFbProcs
declarar _MouseTracking%[100],_hODB%[100],_ODBClicked%[100]
declarar hash _nODB[]
declarar _hScDll&

'{ 'FreeBasic-Routinen
{$fbSYNTAX on}
{$SETFBDLLNAME ODButtons}

{$PUSHFBDLLGLOBALLINE Dim Shared As Any Ptr hComctl32}
{$PUSHFBDLLGLOBALLINE Dim Shared DefSubclassProc As Function (ByVal As HWND,ByVal As Integer,ByVal As WPARAM,ByVal As LPARAM) As Integer}

fbPROC fbInit() As Integer Export
  hComctl32=DyLibLoad("Comctl32.dll")
  DefSubclassProc=DyLibSymbol(hComctl32,"DefSubclassProc")
  volver 0
ENDPROC 'fbinit

fbPROC fbDeInit() As Integer Export
  DyLibFree(hComctl32)
  volver 0
ENDPROC 'fbDeinit

fbPROC fbRePaintWindow(ByVal hW As Integer,ByVal bkmode As Integer) As Integer
  'bkmode: 1=Hintergrund se redibujar, 0=Hintergrund se en Ruhe gelassen (weiß pero no, si BOOL wirklich auch 4 Bytes ha, el es en el MSDN no drin)
  dim As Byte Pointer b,wr
  b=Allocate(6*4)
  wr=Allocate(4*4)
  GetWindowRect(hW,wr)
  poke Integer,b+0,hW 'long b#,0=hW&
  poke Integer,b+4,0 'long b#,4=0
  poke Integer,b+8,0 'long b#,8=0
  poke Integer,b+12,peek(Integer,wr+8)-peek(Integer,wr+0) 'long b#,12=@width(hW&)
  poke Integer,b+16,peek(Integer,wr+12)-peek(Integer,wr+4) 'long b#,16=@height(hW&)
  poke Integer,b+20,bkmode 'long b#,20=bkmode&
  InvalidateRect(hW,b,0)
  DeAllocate(b)
  DeAllocate(wr)
ENDPROC 'fbRePaintWindow

fbPROC fbSubClassProc(ByVal sWnd As Integer,ByVal sMessage As Integer,ByVal swParam As Integer,ByVal slParam As Integer,ByVal uIdSubclass As Integer Pointer,ByVal dwRefData As Integer) As Integer Export
  dim CallOrigWndProc As Integer
  dim s as Byte Pointer
  dim r as RECT
  'dim DIS as DRAWITEMSTRUCT 'DRAWITEMSTRUCT=CtlType&,CtlID&,itemID&,itemAction&,itemState&,hwndItem&,hDC&,rcItemX1&,rcItemY1&,rcItemX2&,rcItemY2&,itemData&
  dim TME as TRACKMOUSEEVENT 'TRACKMOUSEEVENT=cbSize&,dwFlags&,hwndTrack&,dwHoverTime&
  dim as integer i,num,más,erg,hDC
  erg=0
  weiter=0
  CallOrigWndProc=1
  '{ 'WM_MOUSEMOVE
  if smessage=WM_MOUSEMOVE
    for i=1 to _AnzOwnerDrawButtons%
      if swnd=peek(integer,_pOB%+(i*4))
        num=i
        weiter=1
        exit for
      endif
    endfor
    if más
      'CallOrigWndProc=0
      if peek(integer,_pMouseTracking%+(num*4))=0
        'beep
        TME.cbSize=16
        TME.dwFlags&=TME_LEAVE
        TME.hwndTrack=sWnd
        TME.dwHoverTime=HOVER_DEFAULT
        TrackMouseEvent(@TME)
        poke integer,_pMouseTracking%+(num*4),1
        fbrepaintwindow(sWnd,0)
      endif
    endif
  '}
  '{ 'WM_MOUSELEAVE
  elseif smessage=WM_MOUSELEAVE
    for i=1 to _AnzOwnerDrawButtons%
      if swnd=peek(integer,_pOB%+(i*4))
        num=i
        weiter=1
        exit for
      endif
    endfor
    if más
      'CallOrigWndProc=0
      poke integer,_pMouseTracking%+(num*4),0
      fbrepaintwindow(sWnd,0)
    endif
  '}
  '{ 'WM_LBUTTONUP
  elseif smessage=WM_LBUTTONUP
    for i=1 to _AnzOwnerDrawButtons%
      if swnd=peek(integer,_pOB%+(i*4))
        num=i
        weiter=1
        exit for
      endif
    endfor
    if más
      poke integer,_pODBClicked%+(num*4),1
    endif
  '}
  endif
  if swnd=%HWnd
    if smessage=WM_DRAWITEM
      'en slparam es el Pointer en el DRAWITEMSTRUCT-Struktur gespeichert
      if peek(Integer,slparam+0)=ODT_BUTTON
        for i=1 to _AnzOwnerDrawButtons%
          if peek(Integer,slparam+20)=peek(integer,_pOB%+(i*4))
            num=i
            weiter=1
            exit for
          endif
        endfor
        if más
          hDC=peek(Integer,slparam+24)
          SetBkMode(hDC,TRANSPARENT)
          if (peek(Integer,slparam+16) and ODS_SELECTED)=0
            if peek(integer,_pMouseTracking%+(num*4))=0 'bedeutet, dass el Mauszeiger no encima el Button es (porque sonst sería el Ratón getrackt, a ellos el Button verlässt)
              selectobject(hDC,_hBrushNormal%)
              selectobject(hDC,_hPenNormal%)
              SetBkColor(hDC,rgb(200,200,200))
            más
              selectobject(hDC,_hBrushHover%)
              selectobject(hDC,_hPenHover%)
              SetBkColor(hDC,rgb(100,100,255))
            endif
          más
            selectobject(hDC,_hBrushClick%)
            selectobject(hDC,_hPenClick%)
            SetBkColor(hDC,rgb(255,0,0))
          endif
          if (peek(Integer,slparam+16) and ODS_FOCUS)<>0
            selectobject(hDC,_hPenFocus%)
          endif
          rectangle(hDC,peek(Integer,slparam+28),peek(Integer,slparam+32),peek(Integer,slparam+36),peek(Integer,slparam+40))
          selectobject(hDC,_hF%)
          r.left=peek(Integer,slparam+28)
          r.top=peek(Integer,slparam+32)
          r.right=peek(Integer,slparam+36)
          r.bottom=peek(Integer,slparam+40)
          s=Allocate(1002)
          sendmessage(peek(Integer,slparam+20),WM_GETTEXT,1000,s)
          drawtext(hDC,s,-1,@r,DT_SINGLELINE or DT_CENTER or DT_VCENTER)
          DeAllocate(s)
          CallOrigWndProc=0
        endif
      endif
    endif
  endif
  if CallOrigWndProc<>0
    volver DefSubclassProc(sWnd,sMessage,swParam,slParam)
  más
    volver erg
  endif
ENDPROC 'fbSubClassProc
'}

PROC CreateODB
  parámetros hWparent%,texto$,x1%,y1%,x2%,y2%
  declarar hODB%
  hODB%:=~CreateWindowEx(0,"Button",texto$,~WS_CHILD | ~WS_TABSTOP | ~BS_OWNERDRAW,x1%,y1%,x2%,y2%,hWparent%,0,%HInstance,0)
  if hODB%
    inc _AnzOwnerDrawButtons%
    _hODB%[_AnzOwnerDrawButtons%]:=hODB%
    _nODB[@str$(hODB%)]=_AnzOwnerDrawButtons%
    @external("Comctl32.dll","SetWindowSubclass",hODB%,@external("kernel32.dll","GetProcAddress",_hScDll&,"FBSUBCLASSPROC@24"),577,1) 'Button subclassen (para Hover-Aktionen)
    showwindow(hODB%,1) 'darf sólo hier kommmen, porque sólo hier el Owner-Drawing por Subclassing abgedeckt es
  endif
  volver hODB%
ENDPROC 'CreateODB

PROC DestroyODB
  parámetros hB%
  @external("Comctl32.dll","RemoveWindowSubclass",hB%,@external("kernel32.dll","GetProcAddress",_hScDll&,"FBSUBCLASSPROC@24"),577)  'Button-Subclassing final
  _nODB[@str$(hB%)]=0
  @destroywindow(hB%)
ENDPROC 'DestroyODB

PROC ODBClicked
  parámetros hB%
  if _odbclicked%[_nODB[@str$(hB%])]
    _odbclicked%[_nODB[@str$(hB%])]:=0
    volver 1
  más
    volver 0
  endif
ENDPROC 'ODBClicked


'{ ' *** Hauptprogramm
usermessages $10
windowstyle 1+2+4+8+512
window 500,400
@fbinit()
_AnzOwnerDrawButtons%:=0
_MouseTracking%[1]:=0
_MouseTracking%[2]:=0
_pMouseTracking%:=@addr(_MouseTracking%[0])
_pOB%:=@addr(_hODB%[0])
_pODBClicked%:=@addr(_ODBClicked%[0])
_hBrushNormal%:=~createsolidbrush(@rgb(200,200,200))
_hBrushClick%:=~createsolidbrush(@rgb(255,0,0))
_hBrushHover%:=~createsolidbrush(@rgb(100,100,255))
_hPenNormal%:=~createpen(~PS_SOLID,3,@rgb(200,200,200))
_hPenClick%:=~createpen(~PS_SOLID,3,@rgb(255,0,0))
_hPenHover%:=~createpen(~PS_SOLID,3,@rgb(100,100,255))
_hPenFocus%:=~createpen(~PS_SOLID,3,@rgb(0,0,0))
_hF%:=@create("FONT","Times New Roman",18,0,1,1,0)
_hScDll&:=@usedll("ODButtons.dll")
@external("Comctl32.dll","SetWindowSubclass",%HWnd,@external("kernel32.dll","GetProcAddress",_hScDll&,"FBSUBCLASSPROC@24"),577,1) '%HWnd subclassen (en él se WM_DRAWITEM verarbeitet)
_hB1%:=createodb(%HWnd,"Testbutton 1 (Ende)",10,10,150,30)
_hB2%:=createodb(%HWnd,"Testbutton 2",190,10,150,30)
_hB3%:=@create("BUTTON",%HWnd,"normaler Button",10,70,150,30)
'{ 'Eingabehandling
_ende%:=0
whilenot _ende%
  waitinput
  if @iskey(27) or (%umessage=$10) or @odbclicked(_hB1%)
    _ende%:=1
  endif
endwhile
'}
@external("Comctl32.dll","RemoveWindowSubclass",%HWnd,@external("kernel32.dll","GetProcAddress",_hScDll&,"FBSUBCLASSPROC@24"),577) '%HWnd-Subclassing final
DestroyODB(_hB1%)
DestroyODB(_hB2%)
deleteobject _hBrushNormal%
deleteobject _hBrushClick%
deleteobject _hBrushHover%
deleteobject _hPenNormal%
deleteobject _hPenClick%
deleteobject _hPenHover%
deleteobject _hPenFocus%
deleteobject _hF%
freedll _hScDll&
@fbdeinit()
end
'}