XProfan

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

'Ownerdrawn Buttons

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

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

{$PUSHFBDLLGLOBALLINE Faible Shared As Any Ptr hComctl32}
{$PUSHFBDLLGLOBALLINE Faible 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")
  return 0
ENDPROC 'fbinit

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

fbPROC fbRePaintWindow(ByVal hW As Integer,ByVal bkmode As Integer) As Integer
  'bkmode: 1=Hintergrund wird récente gezeichnet, 0=Hintergrund wird dans Ruhe gelassen (sais mais pas, si BOOL wirklich aussi 4 Bytes hat, cela steht im MSDN pas 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,plus,erg,hDC
  erg=0
  weiter=0
  CallOrigWndProc=1
  '{ 'WM_MOUSEMOVE
  si smessage=WM_MOUSEMOVE
    for i=1 to _AnzOwnerDrawButtons%
      si swnd=peek(integer,_pOB%+(i*4))
        num=i
        weiter=1
        exit for
      endif
    endfor
    si plus
      'CallOrigWndProc=0
      si 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%
      si swnd=peek(integer,_pOB%+(i*4))
        num=i
        weiter=1
        exit for
      endif
    endfor
    si plus
      'CallOrigWndProc=0
      poke integer,_pMouseTracking%+(num*4),0
      fbrepaintwindow(sWnd,0)
    endif
  '}
  '{ 'WM_LBUTTONUP
  elseif smessage=WM_LBUTTONUP
    for i=1 to _AnzOwnerDrawButtons%
      si swnd=peek(integer,_pOB%+(i*4))
        num=i
        weiter=1
        exit for
      endif
    endfor
    si plus
      poke integer,_pODBClicked%+(num*4),1
    endif
  '}
  endif
  si swnd=%HWnd
    si smessage=WM_DRAWITEM
      'dans slparam ist qui Pointer sur qui DRAWITEMSTRUCT-Struktur gespeichert
      si peek(Integer,slparam+0)=ODT_BUTTON
        for i=1 to _AnzOwnerDrawButtons%
          si peek(Integer,slparam+20)=peek(integer,_pOB%+(i*4))
            num=i
            weiter=1
            exit for
          endif
        endfor
        si plus
          hDC=peek(Integer,slparam+24)
          SetBkMode(hDC,TRANSPARENT)
          si (peek(Integer,slparam+16) and ODS_SELECTED)=0
            si peek(integer,_pMouseTracking%+(num*4))=0 'bedeutet, dass qui Mauszeiger pas sur dem Button steht (car sonst serait qui souris getrackt, jusqu'à vous den Button verlässt)
              selectobject(hDC,_hBrushNormal%)
              selectobject(hDC,_hPenNormal%)
              SetBkColor(hDC,rgb(200,200,200))
            d'autre
              selectobject(hDC,_hBrushHover%)
              selectobject(hDC,_hPenHover%)
              SetBkColor(hDC,rgb(100,100,255))
            endif
          d'autre
            selectobject(hDC,_hBrushClick%)
            selectobject(hDC,_hPenClick%)
            SetBkColor(hDC,rgb(255,0,0))
          endif
          si (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
  si CallOrigWndProc<>0
    return DefSubclassProc(sWnd,sMessage,swParam,slParam)
  d'autre
    return erg
  endif
ENDPROC 'fbSubClassProc
'}

PROC CreateODB
  parameters hWparent%,text$,x1%,y1%,x2%,y2%
  declare hODB%
  hODB%:=~CreateWindowEx(0,"Button",text$,~WS_CHILD | ~WS_TABSTOP | ~BS_OWNERDRAW,x1%,y1%,x2%,y2%,hWparent%,0,%HInstance,0)
  si 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 (pour Hover-Aktionen)
    showwindow(hODB%,1) 'darf seulement ici kommmen, weil seulement ici cela Owner-Drawing par Subclassing abgedeckt ist
  endif
  return hODB%
ENDPROC 'CreateODB

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

PROC ODBClicked
  parameters hB%
  si _odbclicked%[_nODB[@str$(hB%])]
    _odbclicked%[_nODB[@str$(hB%])]:=0
    return 1
  d'autre
    return 0
  endif
ENDPROC 'ODBClicked


'{ ' *** Hauptprogramm
usermessages $10
style de fenêtre 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 (y wird 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
  si @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 finissons
DestroyODB(_hB1%)
DestroyODB(_hB2%)
deleteobject _hBrushNormal%
deleteobject _hBrushClick%
deleteobject _hBrushHover%
deleteobject _hPenNormal%
deleteobject _hPenClick%
deleteobject _hPenHover%
deleteobject _hPenFocus%
deleteobject _hF%
freedll _hScDll&
@fbdeinit()
end
'}