'###################################
'########### 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