SysTabControl32

1 form , 1 class ,1 module

'#####################################
'########   module  #####################
'#####################################

'---------------------------------------------------------------------------------------
' Module    : mdlSubClassEx2
' DateTime  : 2005-3-21 00:28
' Author    : Lingll
' Purpose   : 子类处理的mdl,
'             利用SetProp,可以非常方便的对多个窗口做子类处理
'---------------------------------------------------------------------------------------

Option Explicit

Private Const GWL_WNDPROC = (-4)

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal Hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal Hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal Hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const PROP_PREVPROC = "WinProc"
Private Const PROP_OBJECT = "Object"

Private Const WM_NOTIFY As Long = &H4E

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

''return 0:pass the message;other:no pass
'Public Function WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'WindowProc = 0
'End Function

Private Function WindowProc(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lPrevProc As Long
Dim oObj As cTabControl32
  
    ' Get the previous window procedure
    lPrevProc = GetProp(Hwnd, PROP_PREVPROC)
    Set oObj = PtrToObj(GetProp(Hwnd, PROP_OBJECT))
   
    If wMsg = WM_NOTIFY Then
        If oObj.WindowProc(Hwnd, wMsg, wParam, lParam) = 0 Then
            WindowProc = CallWindowProc(lPrevProc, Hwnd, wMsg, wParam, lParam)
        End If
    Else
        WindowProc = CallWindowProc(lPrevProc, Hwnd, wMsg, wParam, lParam)
    End If
   
End Function

Private Function PtrToObj(ByVal lPtr As Long) As Object
Dim oUnk As Object

   MoveMemory oUnk, lPtr, 4&
   Set PtrToObj = oUnk
   MoveMemory oUnk, 0&, 4&
           
End Function

Public Sub SubClass_TabCtl(ByVal Hwnd As Long, ByVal Obj As Object)

   ' Set the properties
   SetProp Hwnd, PROP_OBJECT, ObjPtr(Obj)
   SetProp Hwnd, PROP_PREVPROC, GetWindowLong(Hwnd, GWL_WNDPROC)
  
   ' Subclass the windows
   SetWindowLong Hwnd, GWL_WNDPROC, AddressOf WindowProc
  
End Sub

Public Sub UnsubClass_TabCtl(ByVal Hwnd As Long)
Dim lProc As Long

   ' Get the window procedure
   lProc = GetProp(Hwnd, PROP_PREVPROC)
  
   ' Unsubclass the window
   SetWindowLong Hwnd, GWL_WNDPROC, lProc
  
   ' Remove the properties
   RemoveProp Hwnd, PROP_OBJECT
   RemoveProp Hwnd, PROP_PREVPROC

End Sub

'#####################################
'###########    class  ###################
'#####################################

'---------------------------------------------------------------------------------------
' Module    : cTabControl32
' DateTime  : 2005-3-24 21:16
' Author    : Lingll
' Purpose   :
'---------------------------------------------------------------------------------------

Option Explicit

Private Declare Function CreateWindowEx Lib "user32.dll" Alias _
    "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal _
    lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal _
    hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal Hwnd As Long) As Long

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Const WC_TABCONTROL As String = "SysTabControl32"

Private Type TCITEM
    mask As Long
    dwState As Long
    dwStateMask As Long
    pszText As String
    cchTextMax As Long
    iImage As Long
    lParam As Long
End Type

Private Const WS_CHILD As Long = &H40000000
Private Const WS_CLIPSIBLINGS As Long = &H4000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_Default As Long = WS_CHILD Or WS_CLIPSIBLINGS Or WS_VISIBLE

'--------------------------------------------------
'========    style   ==============================
'--------------------------------------------------
Public Enum ctceTCS
    TCS_BOTTOM = &H2
    TCS_BUTTONS = &H100
    TCS_FIXEDWIDTH = &H400
    TCS_FLATBUTTONS = &H8
    TCS_FOCUSNEVER = &H8000
    TCS_FOCUSONBUTTONDOWN = &H1000
    TCS_FORCEICONLEFT = &H10
    TCS_FORCELABELLEFT = &H20
    TCS_HOTTRACK = &H40
    TCS_MULTILINE = &H200
    TCS_MULTISELECT = &H4
    TCS_OWNERDRAWFIXED = &H2000
    TCS_RAGGEDRIGHT = &H800
    TCS_RIGHT = &H2
    TCS_RIGHTJUSTIFY = &H0
    TCS_SCROLLOPPOSITE = &H1
    TCS_SINGLELINE = &H0
    TCS_TABS = &H0
    TCS_TOOLTIPS = &H4000
    TCS_VERTICAL = &H80
End Enum

'    Private Const TCS_BOTTOM As Long = &H2
'    Private Const TCS_BUTTONS As Long = &H100
'    Private Const TCS_FIXEDWIDTH As Long = &H400
'    Private Const TCS_FLATBUTTONS As Long = &H8
'    Private Const TCS_FOCUSNEVER As Long = &H8000
'    Private Const TCS_FOCUSONBUTTONDOWN As Long = &H1000
'    Private Const TCS_FORCEICONLEFT As Long = &H10
'    Private Const TCS_FORCELABELLEFT As Long = &H20
'    Private Const TCS_HOTTRACK As Long = &H40
'    Private Const TCS_MULTILINE As Long = &H200
'    Private Const TCS_MULTISELECT As Long = &H4
'    Private Const TCS_OWNERDRAWFIXED As Long = &H2000
'    Private Const TCS_RAGGEDRIGHT As Long = &H800
'    Private Const TCS_RIGHT As Long = &H2
'    Private Const TCS_RIGHTJUSTIFY As Long = &H0
'    Private Const TCS_SCROLLOPPOSITE As Long = &H1
'    Private Const TCS_SINGLELINE As Long = &H0
'    Private Const TCS_TABS As Long = &H0
'    Private Const TCS_TOOLTIPS As Long = &H4000
'    Private Const TCS_VERTICAL As Long = &H80

Private Const TCS_EX_FLATSEPARATORS As Long = &H1
Private Const TCS_EX_REGISTERDROP As Long = &H2
'====================================================

'--------------------------------------------------
'===========   notify message   ===================
'--------------------------------------------------
Private Type NMHDR
    hwndFrom As Long
    idfrom As Long
    code As Long
End Type

Private Const NM_FIRST As Long = 0
Private Const TCN_FIRST As Long = -550

Private Const NM_CLICK As Long = (NM_FIRST - 2)
Private Const NM_RCLICK As Long = (NM_FIRST - 5)
Private Const NM_RELEASEDCAPTURE As Long = (NM_FIRST - 16)
Private Const TCN_FOCUSCHANGE As Long = (TCN_FIRST - 4)
Private Const TCN_SELCHANGING As Long = (TCN_FIRST - 2)
Private Const TCN_SELCHANGE As Long = (TCN_FIRST - 1)
Private Const TCN_LAST As Long = (-580)
'============================================================

Private Const TCM_FIRST As Long = &H1300
Private Const TCM_INSERTITEMA As Long = (TCM_FIRST + 7)
Private Const TCM_INSERTITEMW As Long = (TCM_FIRST + 62)
Private Const TCM_GETCURSEL As Long = (TCM_FIRST + 11)
Private Const TCM_DELETEITEM As Long = (TCM_FIRST + 8)
Private Const TCM_DELETEALLITEMS As Long = (TCM_FIRST + 9)
Private Const TCM_ADJUSTRECT As Long = (TCM_FIRST + 40)

Private Const TCIF_TEXT As Long = &H1

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Const WM_SETFONT As Long = &H30

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function SetWindowPos Lib "user32.dll" (ByVal Hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
Private Const HWND_BOTTOM As Long = 1
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal Hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetParent Lib "user32.dll" (ByVal Hwnd As Long) As Long
Private Declare Function ScreenToClient Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpPoint As POINTAPI) As Long

Public Event Changed(vPos&)

Private m_lMsgWnd As Long     ' Toolbar parent window
Private m_lTabWnd As Long    ' Toolbar window
'Private mIList As Long      'imagelist

Private Const m_def_fontname$ = "宋体"
Private Const m_def_fontsize$ = 9
Private Const m_def_fontcharset = 134

'return 0:pass the message;other:no pass
Public Function WindowProc(ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static tNMT As NMHDR
CopyMemory tNMT, ByVal lParam, Len(tNMT)
Select Case tNMT.code
    Case TCN_SELCHANGE
        RaiseEvent Changed(GetSelected())
End Select
WindowProc = 0
End Function

Public Function Create(hParent&, vStyle As ctceTCS, x&, y&, cx&, cy&)
   
    Call InitCommonControls
    Call Destroy
   
    m_lMsgWnd = CreateWindowEx(0&, "#32770", vbNullString, WS_Default, x, y, cx, cy, hParent, 0, App.hInstance, ByVal 0&)
   
    vStyle = vStyle Or WS_Default
   
    m_lTabWnd = CreateWindowEx( _
            0&, WC_TABCONTROL, "", _
            vStyle, 5, 5, cx - 10, cy - 10, _
            m_lMsgWnd, 0&, App.hInstance, ByVal 0&)
           
    Call SubClass_TabCtl(m_lMsgWnd, Me)

    Create = m_lTabWnd
End Function

Public Sub SetFont_Obj(vFont As IFont)
If m_lTabWnd <> 0 Then
    SendMessage m_lTabWnd, WM_SETFONT, ByVal vFont.hFont, ByVal MAKELONG(-1, 0)
End If
End Sub

Public Sub SetFont( _
    Optional vFontName$ = m_def_fontname, _
    Optional vFontSize& = m_def_fontsize, _
    Optional vCharset& = m_def_fontcharset)
   
Dim tFont As IFont

    Set tFont = New StdFont
    With tFont
       .Size = vFontSize
       .Name = vFontName
       .Charset = vCharset
    End With
    Call SetFont_Obj(tFont)
End Sub

Public Sub AddItem(vPos&, vCaption$)
Dim TabItemInfo As TCITEM
If m_lTabWnd <> 0 Then
    With TabItemInfo ' 添加选项卡片。
        .mask = TCIF_TEXT
        .pszText = vCaption
    End With
   
    SendMessage m_lTabWnd, TCM_INSERTITEMA, vPos, TabItemInfo
End If
End Sub

Public Sub DelItem(vPos&)
If m_lTabWnd <> 0 Then
    SendMessage m_lTabWnd, TCM_DELETEITEM, vPos, ByVal 0&
End If
End Sub

Public Sub Clear()
If m_lTabWnd <> 0 Then
    SendMessage m_lTabWnd, TCM_DELETEALLITEMS, 0&, ByVal 0&
End If
End Sub

Public Function GetSelected() As Long
If m_lTabWnd <> 0 Then
    GetSelected = SendMessage(m_lTabWnd, TCM_GETCURSEL, 0&, ByVal 0&)
Else
    GetSelected = -1
End If
End Function

Public Sub GetAdjustRect(Optional vLeft&, Optional vTop&, _
    Optional vRight&, Optional vBottom&)
Dim tRcAd As RECT
Dim tRcWn As RECT
Dim tPt As POINTAPI, tPt2 As POINTAPI

If m_lTabWnd <> 0 Then
    SendMessage m_lTabWnd, TCM_ADJUSTRECT, 0, tRcAd
    GetWindowRect m_lTabWnd, tRcWn
   
    tPt.x = tRcWn.Left + tRcAd.Left
    tPt.y = tRcWn.Top + tRcAd.Top
    Call ScreenToClient(GetParent(m_lMsgWnd), tPt)
   
'    tPt.x = tRcWn.Right + tRcAd.Right
'    tPt.y = tRcWn.Bottom + tRcAd.Bottom
'    Call ScreenToClient(GetParent(m_lMsgWnd), tPt)
   
    vLeft = tPt.x
    vTop = tPt.y
    vRight = tPt.x + (tRcWn.Right + tRcAd.Right) - (tRcWn.Left + tRcAd.Left)
    vBottom = tPt.y + (tRcWn.Bottom + tRcAd.Bottom) - (tRcWn.Top + tRcAd.Top)
End If
End Sub

Public Sub GetRect(Optional vLeft&, Optional vTop&, _
    Optional vRight&, Optional vBottom&)
Dim tRc As RECT
If m_lTabWnd <> 0 Then
    GetWindowRect m_lTabWnd, tRc
   
    vLeft = tRc.Left
    vTop = tRc.Top
    vRight = tRc.Right
    vBottom = tRc.Bottom
End If
End Sub

Public Sub Move(x&, y&, cx&, cy&)
If m_lMsgWnd <> 0 And m_lTabWnd <> 0 Then
    MoveWindow m_lMsgWnd, x, y, cx, cy, 1
    MoveWindow m_lTabWnd, x, y, cx, cy, 1
End If
End Sub

'置于zorder最下
Public Sub SetToBottom()
If m_lTabWnd <> 0 And m_lMsgWnd <> 0 Then
    Call SetWindowPos(m_lMsgWnd, HWND_BOTTOM, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE)
End If
End Sub

Public Sub Destroy()
If m_lTabWnd <> 0 Then
    DestroyWindow m_lTabWnd
    m_lTabWnd = 0
End If

If m_lMsgWnd <> 0 Then
    DestroyWindow m_lMsgWnd
    UnsubClass_TabCtl m_lMsgWnd
    m_lMsgWnd = 0
End If
End Sub

Private Function MAKELONG(wLow As Long, wHigh As Long) As Long
MAKELONG = wHigh * &H10000 + wLow
End Function

Private Sub Class_Initialize()
Call Destroy
End Sub

Public Property Get Hwnd() As Long
Hwnd = m_lTabWnd
End Property

'#####################################
'#############  fom  ###################
'#####################################

Option Explicit

Private WithEvents ttab As cTabControl32
Private Declare Function BringWindowToTop Lib "user32.dll" (ByVal Hwnd As Long) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal Hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function ScreenToClient Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Sub Command1_Click()
ttab.DelItem 2
End Sub

Private Sub Form_Load()
Set ttab = New cTabControl32
ttab.Create Me.Hwnd, TCS_HOTTRACK, 0, 0, Me.ScaleWidth / 15, Me.ScaleHeight / 15
ttab.AddItem 0, "Tab1"
ttab.AddItem 1, "Tab2"
ttab.AddItem 2, "Tab3"
ttab.AddItem 3, "页4"
'ttab.SetFont
ttab.SetFont

Command1.ZOrder
End Sub
'    TabChanged     ' 这个 frmTest 的 Private 方法用于处理 Tab Control 页面改变的操作。

Private Sub Form_Resize()
ttab.Move 0, 0, Me.ScaleWidth / 15, Me.ScaleHeight / 15

Dim x&, y&, cx&, cy&
ttab.GetAdjustRect x, y, cx, cy

MoveWindow Frame1.Hwnd, x, y, cx - x, cy - y, 1

End Sub

Private Sub ttab_Changed(vPos As Long)
Debug.Print vPos
End Sub