代码分为三部分 1 class 、 1 module 、1 form
'###################################
'######## 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
'#####################################
'############# form ####################
'#####################################
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