代码分为三部分 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 <
/font>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 Dest
roy

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 I
f
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


 
目前有0条回应
Comment
Trackback
你目前的身份是游客,请输入昵称和电邮!