上一篇
下一篇
SysTabControl32
作者:JiaJia 日期:2008-02-05
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
引用内容'#####################################
'######## 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
文章来自: 
引用通告: 
Tags: 评论: 0 | 引用: 0 | 查看次数: -
发表评论