XProfan

'TabControl con "neu"-Tab y "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&

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

SUBCLASSPROC
  declarar dis#,rect#,tcitem#,b#,t$,mx%,my%,i%,o%
  if &sWnd=%HWnd
    '{ 'Schließen-X en 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$=@cadena$(b#,0)
        disponer 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
        disponer rect#,tcitem#
      endif
      disponer 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%
            romper
          endif
        más
          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%
            romper
          endif
        endif
      endfor 'i%
      disponer rect#
    endif
    '}
  endif
ENDPROC 'SUBCLASSPROC

'{ 'Hilfsfunktionen
PROC MouseAbsX
  Declarar Punto#,XX&
  Dim Punto#,8
  @external("user32.dll","GetCursorPos",Punto#)
  XX&=@long(Punto#,0)
  Disponer Punto#
  Volver XX&
ENDPROC 'MouseAbsX
PROC MouseAbsY
  Declarar Punto#,YY&
  Dim Punto#,8
  @external("user32.dll","GetCursorPos",Punto#)
  YY&=@long(Punto#,4)
  Disponer Punto#
  Volver YY&
ENDPROC 'MouseAbsY
PROC GetAbsWindowPosX1
  parámetros hW&
  declarar b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,0)
  disponer b#
  volver ret&
ENDPROC 'GetAbsWindowPosX1
PROC GetAbsWindowPosY1
  parámetros hW&
  declarar b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,4)
  disponer b#
  volver ret&
ENDPROC 'GetAbsWindowPosY1
PROC GetAbsWindowPosX2
  'Lo se el absolute Position ermittelt! Für Breite/Höhe GetWindowSpan uso!
  parámetros hW&
  declarar b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,8)
  disponer b#
  volver ret&
ENDPROC 'GetAbsWindowPosX2
PROC GetAbsWindowPosY2
  'Lo se el absolute Position ermittelt! Für Breite/Höhe GetWindowSpan uso!
  parámetros hW&
  declarar b#,ret&
  dim b#,4*4
  @external("user32.dll","GetWindowRect",hW&,b#)
  ret&=@long(b#,12)
  disponer b#
  volver ret&
ENDPROC 'GetAbsWindowPosY2
'}


'Hauptprogramm:
cls
usermessages $10
_hWhiteBrush%=~CreateSolidBrush(@rgb(255,255,255))
_hBMP%=Create("HPIC",0,"TOOLBAR")
_hIL%=@Crear("IMAGELIST",16,16,_hBMP%,@rgb(192,192,192))
_hIclose%=~ImageList_GetIcon(_hIL%,10,~ILD_NORMAL)
deleteobject _hBMP%
_hTC%=@Crear("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, así el Schließen-X-Icon hineinpasst
inserttab(_hTC%,1,"Tab 2   ")
inserttab(_hTC%,2,"  *neu")
waitinput 1 'TabControl 1x Mostrar
@set("FASTMODE",0) 'Fastmode kann otra vez ausgeschaltet voluntad
_MaxTab%=3
_TabNr%=2
mientras que _ende%=0
  waitinput
  if (%uMessage=$10) or ((~GetForegroundWindow()=%HWnd) and @iskey(27))
    mientras que @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 con "neu"-Tab y "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&
declarar tabcontrol&,_hIL%,_ende%,_MaxTab%,_TabNr%, hFont%

SUBCLASSPROC

    declarar 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%
                romper

            endif

        más

            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%
                romper

            endif

        endif

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

    endif

ENDPROC'SUBCLASSPROC

'Hauptprogramm:
cls
hFont% = Crear("Font","segoe ui",16,0,0,0,0)
SetDialogFont  hFont%
usermessages $10
Tabcontrol&=Crear("TABCTRL",%HWnd,_hIL%,0,0,width(%HWnd),24)
subclass Tabcontrol&,1
set("FASTMODE",1)
inserttab(Tabcontrol&,1,"Tab 1  × ")'drei Spaces rechts, así el Schließen-X-Icon hineinpasst
inserttab(Tabcontrol&,1,"Tab 2  × ")
inserttab(Tabcontrol&,2,"  *neu")
waitinput 1'TabControl 1x Mostrar
set("FASTMODE",0)'Fastmode kann otra vez ausgeschaltet voluntad
_MaxTab%=3
_TabNr%=2

mientras que _ende%=0

    waitinput

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

        mientras que iskey(27)

            sleep 25

        endwhile

        _ende%=1

    endif

endwhile

subclass Tabcontrol&,0
usermessages 0
end