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 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")
  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 neu gezeichnet, 0=Hintergrund wird in Ruhe gelassen (weiß aber nicht, ob BOOL wirklich auch 4 Bytes hat, das steht im MSDN nicht 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,weiter,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 weiter
      '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 weiter
      '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 weiter
      poke integer,_pODBClicked%+(num*4),1
    endif
  '}
  endif
  if swnd=%HWnd
    if smessage=WM_DRAWITEM
      'in slparam ist der Pointer auf die 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 weiter
          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 der Mauszeiger nicht über dem Button steht (denn sonst würde die Maus getrackt, bis sie den Button verlässt)
              selectobject(hDC,_hBrushNormal%)
              selectobject(hDC,_hPenNormal%)
              SetBkColor(hDC,rgb(200,200,200))
            else
              selectobject(hDC,_hBrushHover%)
              selectobject(hDC,_hPenHover%)
              SetBkColor(hDC,rgb(100,100,255))
            endif
          else
            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
    return DefSubclassProc(sWnd,sMessage,swParam,slParam)
  else
    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)
  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 (für Hover-Aktionen)
    showwindow(hODB%,1) 'darf erst hier kommmen, weil erst hier das Owner-Drawing durch 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 beenden
  _nODB[@str$(hB%)]=0
  @destroywindow(hB%)
ENDPROC 'DestroyODB

PROC ODBClicked
  parameters hB%
  if _odbclicked%[_nODB[@str$(hB%])]
    _odbclicked%[_nODB[@str$(hB%])]:=0
    return 1
  else
    return 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 (darin 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
  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 beenden
DestroyODB(_hB1%)
DestroyODB(_hB2%)
deleteobject _hBrushNormal%
deleteobject _hBrushClick%
deleteobject _hBrushHover%
deleteobject _hPenNormal%
deleteobject _hPenClick%
deleteobject _hPenHover%
deleteobject _hPenFocus%
deleteobject _hF%
freedll _hScDll&
@fbdeinit()
end
'}