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-routines
{$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 becomes new drawn, 0=Hintergrund becomes in silence let (white but not, whether BOOL really too 4 Bytes has, the standing in the MSDN not 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,moreover,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 moreover
      '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 moreover
      '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 moreover
      poke integer,_pODBClicked%+(num*4),1
    endif
  '}
  endif
  if swnd=%HWnd
    if smessage=WM_DRAWITEM
      'in slparam is the Pointer on The DRAWITEMSTRUCT-structure stored
      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 moreover
          hDC=peek(Integer,slparam+24)
          SetBkMode(hDC,TRANSPARENT)
          if (peek(Integer,slparam+16) and ODS_SELECTED)=0
            if peek(integer,_pMouseTracking%+(num*4))=0 'means, that the Cursor not over the Button standing (because otherwise would The mouse getrackt, until whom Button leave)
              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[@st$(hODB%)]=_AnzOwnerDrawButtons%
    @external("Comctl32.dll","SetWindowSubclass",hODB%,@external("kernel32.dll","GetProcAddress",_hScDll&,"FBSUBCLASSPROC@24"),577,1) 'Button subclassen (for Hover-activities)
    showwindow(hODB%,1) 'must first here kommmen, because first here the Owner-Drawing through Subclassing abgedeckt is
  endif
  return hODB%
ENDPROC 'CreateODB

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

PROC ODBClicked
  parameters hB%
  if _odbclicked%[_nODB[@st$(hB%])]
    _odbclicked%[_nODB[@st$(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 novel",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 (therein becomes WM_DRAWITEM processing)
_hB1%:=createodb(%HWnd,"Testbutton 1 (end)",10,10,150,30)
_hB2%:=createodb(%HWnd,"Testbutton 2",190,10,150,30)
_hB3%:=@create("BUTTON",%HWnd,"normal 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 terminate
DestroyODB(_hB1%)
DestroyODB(_hB2%)
deleteobject _hBrushNormal%
deleteobject _hBrushClick%
deleteobject _hBrushHover%
deleteobject _hPenNormal%
deleteobject _hPenClick%
deleteobject _hPenHover%
deleteobject _hPenFocus%
deleteobject _hF%
freedll _hScDll&
@fbdeinit()
end
'}