XProfan

'TabControl mit "neu"-Tab und "Schließen-X"

$H windows.ph
$H messages.ph
$H commctrl.ph

STRUCT S_RECT=left&,top&,right&,bottom&
STRUCT S_DRAWITEMSTRUCT=CtlType&,CtlID&,itemID&,itemAction&,itemState&,hwndItem&,hDC&,rcX1&,rcY1&,rcX2&,rcY2&,itemData&
STRUCT S_TCITEM=mask&,dwState&,dwStateMask&,pszText&,cchTextMax&,iImage&,lParam&

declare _hTC%,_hIL%,_hBMP%,_hWhiteBrush%,_hIclose%,_ende%,_MaxTab%,_TabNr%

SUBCLASSPROC
  declare dis#,rect#,tcitem#,b#,t$,mx%,my%,i%,o%
  if &sWnd=%HWnd
    '{ 'Schließen-X auf Tabs malen
    if %sMessage=~WM_DRAWITEM
      dim dis#,S_DRAWITEMSTRUCT
      dis#=&slParam
      if dis#.hwndItem&=_hTC%
        dim rect#,S_RECT
        dim tcitem#,S_TCITEM
        rect#.left&=dis#.rcX1&+~GetSystemMetrics(~SM_CXEDGE)
        rect#.top&=dis#.rcY1&+~GetSystemMetrics(~SM_CYEDGE)
        rect#.right&=dis#.rcX2&-~GetSystemMetrics(~SM_CXEDGE)
        rect#.bottom&=dis#.rcY2&
        tcitem#.mask&=~TCIF_TEXT | ~TCIF_STATE
        tcitem#.dwStateMask&=$FFFFFFFF
        dim b#,1000
        tcitem#.psztext&=b#
        tcitem#.cchtextmax&=1000
        @sendmessage(_hTC%,~TCM_GETITEMA,dis#.itemID&,tcitem#)
        if TCITEM#.dwstate&=1
          ~FillRect(dis#.hDC&,rect#,_hWhiteBrush%)
          ~SetBkMode(dis#.hDC&,~TRANSPARENT)
          rect#.left&=rect#.left&+4
          rect#.top&=rect#.top&+2
        endif
        t$=@string$(b#,0)
        dispose b#
        '~selectobject(DIS#.hDC&,_hTabFont)
        ~drawtext(dis#.hDC&,@addr(t$),-1,rect#,~DT_LEFT | ~DT_SINGLELINE)
        if tcitem#.dwstate&<>1
          rect#.right&=rect#.right&+4
        endif
        if t$<>"  *neu"
          ~DrawIconEx(dis#.hDC&,rect#.right&-16-2,rect#.top&,_hIclose%,16,16,0,0,~DI_IMAGE | ~DI_MASK)
        endif
        dispose rect#,tcitem#
      endif
      dispose dis#
    endif
    '}
  elseif &sWnd=_hTC%
    '{ 'Schließen-X oder "*neu"-Tab angeklickt
    if %smessage=~WM_LBUTTONDOWN
      mx%=@mouseabsx()
      my%=@mouseabsy()
      dim rect#,S_RECT
      for i%,0,_MaxTab%-1
        @sendmessage(_hTC%,~TCM_GETITEMRECT,i%,rect#)
        if i%<_MaxTab%-1
          if (mx%>=rect#.right&-16-2+@GetAbsWindowPosX1(_hTC%)) and (mx%<=rect#.right&+@GetAbsWindowPosX1(_hTC%)) and (my%>=rect#.top&+@GetAbsWindowPosY1(_hTC%)) and (my%<=rect#.top&+16+@GetAbsWindowPosY1(_hTC%))
            @sendmessage(_hTC%,~TCM_DELETEITEM,i%,0)
            dec _MaxTab%
            'for o%,0,_MaxTab%-2
            '  settext _hTC%,o%,"Tab "+@str$(o%+1)+"   "
            'endfor 'o%
            break
          endif
        else
          if (mx%>=rect#.left&+@GetAbsWindowPosX1(_hTC%)) and (mx%<=rect#.right&+@GetAbsWindowPosX1(_hTC%)) and (my%>=rect#.top&+@GetAbsWindowPosY1(_hTC%)) and (my%<=rect#.bottom&+@GetAbsWindowPosY2(_hTC%))
            inc _TabNr%
            inserttab(_hTC%,_MaxTab%-1,"Tab "+@str$(_TabNr%)+"   ")
            inc _MaxTab%
            break
          endif
        endif
      endfor 'i%
      dispose rect#
    endif
    '}
  endif
ENDPROC 'SUBCLASSPROC

'{ 'Hilfsfunktionen
PROC MouseAbsX
  Declare Point#,XX&
  Dim Point#,8
  @external("user32.dll","GetCursorPos",Point#)
  XX&=@long(Point#,0)
  Dispose Point#
  Return XX&
ENDPROC 'MouseAbsX
PROC MouseAbsY
  Declare Point#,YY&
  Dim Point#,8
  @external("user32.dll","GetCursorPos",Point#)
  YY&=@long(Point#,4)
  Dispose Point#
  Return YY&
ENDPROC 'MouseAbsY
PROC GetAbsWindowPosX1
  parameters hW&
  declare b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,0)
  dispose b#
  return ret&
ENDPROC 'GetAbsWindowPosX1
PROC GetAbsWindowPosY1
  parameters hW&
  declare b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,4)
  dispose b#
  return ret&
ENDPROC 'GetAbsWindowPosY1
PROC GetAbsWindowPosX2
  'Es wird die absolute Position ermittelt! Für Breite/Höhe GetWindowSpan verwenden!
  parameters hW&
  declare b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,8)
  dispose b#
  return ret&
ENDPROC 'GetAbsWindowPosX2
PROC GetAbsWindowPosY2
  'Es wird die absolute Position ermittelt! Für Breite/Höhe GetWindowSpan verwenden!
  parameters hW&
  declare b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,12)
  dispose b#
  return ret&
ENDPROC 'GetAbsWindowPosY2
'}


'Hauptprogramm:
cls
usermessages $10
_hWhiteBrush%=~CreateSolidBrush(@rgb(255,255,255))
_hBMP%=Create("HPIC",0,"TOOLBAR")
_hIL%=@Create("IMAGELIST",16,16,_hBMP%,@rgb(192,192,192))
_hIclose%=~ImageList_GetIcon(_hIL%,10,~ILD_NORMAL)
deleteobject _hBMP%
_hTC%=@Create("TABCTRL",%HWnd,_hIL%,0,0,@width(%HWnd),24)
setstyle _hTC%,@getstyle(_hTC%) | ~TCS_OWNERDRAWFIXED
@set("FASTMODE",1)
subclass %HWnd,1
subclass _hTC%,1
inserttab(_hTC%,1,"Tab 1   ") 'drei Spaces rechts, damit das Schließen-X-Icon hineinpasst
inserttab(_hTC%,1,"Tab 2   ")
inserttab(_hTC%,2,"  *neu")
waitinput 1 'TabControl 1x anzeigen
@set("FASTMODE",0) 'Fastmode kann jetzt wieder ausgeschaltet werden
_MaxTab%=3
_TabNr%=2
while _ende%=0
  waitinput
  if (%uMessage=$10) or ((~GetForegroundWindow()=%HWnd) and @iskey(27))
    while @iskey(27)
      sleep 25
    endwhile
    _ende%=1
  endif
endwhile
subclass _hTC%,0
subclass %HWnd,0
deleteobject _hIL%
deleteobject _hWhiteBrush%
deleteobject _hIclose%
usermessages 0
end

'TabControl mit "neu"-Tab und "Schließen-X"
 $H windows.ph
 $H messages.ph
 $H commctrl.ph
STRUCT S_RECT      = left&,top&,right&,bottom&
STRUCT S_TABRECT   = x1&,y1&,x2&,y2&
STRUCT S_MOUSE     = mx&,my&
declare tabcontrol&,_hIL%,_ende%,_MaxTab%,_TabNr%, hFont%

SUBCLASSPROC

    declare rect#,i%,o%,tabrect#,mouse#

    If SubClassMessage(Tabcontrol&, ~WM_LBUTTONDOWN)

        '{ 'Schließen-X oder "*neu"-Tab angeklickt
        dim rect#,S_RECT
        dim mouse#,S_MOUSE
        dim tabrect#,S_TABRECT
        external("user32.dll","GetCursorPos",mouse#)
        external("user32.dll","GetWindowRect",Tabcontrol&,tabrect#)
        for i%,0,_MaxTab%-1
        sendmessage(Tabcontrol&,~TCM_GETITEMRECT,i%,rect#)

        if i%<_MaxTab%-1

            if (mouse#.mx&>=rect#.right&-16-2+tabrect#.x1&) and (mouse#.mx&<=rect#.right&+tabrect#.x1&) and (mouse#.my&>=rect#.top&+tabrect#.y1&) and (mouse#.my&<=rect#.top&+16+tabrect#.y1&)

                sendmessage(Tabcontrol&,~TCM_DELETEITEM,i%,0)
                dec _MaxTab%
                break

            endif

        else

            if (mouse#.mx&>=rect#.left&+tabrect#.x1&) and (mouse#.mx&<=rect#.right&+tabrect#.x1&) and (mouse#.my&>=rect#.top&+tabrect#.y1&) and (mouse#.my&<=rect#.bottom&+tabrect#.x2&)

                inc _TabNr%
                inserttab(Tabcontrol&,_MaxTab%-1,"Tab "+str$(_TabNr%)+"  × ")
                inc _MaxTab%
                break

            endif

        endif

        endfor'i%
        dispose rect#, mouse#, tabrect#
        '}

    endif

ENDPROC'SUBCLASSPROC

'Hauptprogramm:
cls
hFont% = Create("Font","segoe ui",16,0,0,0,0)
SetDialogFont  hFont%
usermessages $10
Tabcontrol&=Create("TABCTRL",%HWnd,_hIL%,0,0,width(%HWnd),24)
subclass Tabcontrol&,1
set("FASTMODE",1)
inserttab(Tabcontrol&,1,"Tab 1  × ")'drei Spaces rechts, damit das Schließen-X-Icon hineinpasst
inserttab(Tabcontrol&,1,"Tab 2  × ")
inserttab(Tabcontrol&,2,"  *neu")
waitinput 1'TabControl 1x anzeigen
set("FASTMODE",0)'Fastmode kann jetzt wieder ausgeschaltet werden
_MaxTab%=3
_TabNr%=2

while _ende%=0

    waitinput

    if (%uMessage=$10) or ((~GetForegroundWindow()=%HWnd) and iskey(27))

        while iskey(27)

            sleep 25

        endwhile

        _ende%=1

    endif

endwhile

subclass Tabcontrol&,0
usermessages 0
end