1 FORM, 1 Class, 1 Module
'################################################################################################################################################################################################################################################################### ####################################################################################################################################################################################################################################################### #######
'------------------------------------- -------------------------------------- 'MODULE: MDLSUBCLASSEX2' DATETIME: 2005-3-21 00:28 'Author: lingll' purpose: MDL of subclass processing, 'Using SetProp, it can be very convenient for multiple windows to do subclasses' --------------- -------------------------------------------------- --------------------
Option expedition
Private const GWL_WndProc = (-4)
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As LongPrivate 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 LongPrivate Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal Hwnd As Long, ByVal lpString As String) As LongPrivate Declare Function setProp lib "user32" alias "setpropa" (Byval Hwnd As String, Byval HData As long) As long
Private Declare Function CallWindowProc Lib "User32" Alias "CallWindowProca" (Byval HWND As Long, Byval Msg As Long, Byval WParam 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 LongDim lPrevProc As LongDim 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 Objectdim 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_PREVPROCEnd Sub
'#################################################################### Class ##################################################################################################################################################################################################################################################################################################### ########
'------------------------------------- -------------------------------------- 'Module: CTABControl32' DateTime: 2005-3-24 21:16 Author: Lingll 'Purpose:' ------------------------------------- ------------------------------------------------
Option expedition
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 LongPrivate 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 LONGEND TYPE
Private Const WS_CHILD As Long = & H40000000Private Const WS_CLIPSIBLINGS As Long = & H4000000Private Const WS_VISIBLE As Long = & H10000000Private Const WS_Default As Long = WS_CHILD Or WS_CLIPSIBLINGS Or WS_VISIBLE
'------------------------------------- - '======== style ======================================= -------- ------------------------------------------ Public Enum CTCSTCS_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 = & H80END 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 = & H80Private const tcs_ex_flatseparetor S as long = & h1private const tcs_ex_registerdrop as ring = & h2 '====================================== ==============
'------------------------------------- - '=========== Notify message ==================== --------------- ---------------------------------- Private Type NmHDR HWNDFROM AS Long IDFROM As Long Code As LONGEND TYPRIVATE CONST NM_FIRST As long = 0Private 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 = & H1300Private 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 a, Byref LParam As Any) AS Longprivate Const WM_SETFONT AS Long = & H30Private Type Rect Left As Long Top As Long Right As Long Bottom As Longend Type
Private Type Pointapi X As Long Y As Longend 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 LongPrivate Const SWP_NOACTIVATE As Long = & H10Private Const SWP_NOMOVE As Long = & H2Private Const SWP_NOSIZE As Long = & H1Private Const HWND_BOTTOM As Long = 1Private Declare Function GetWindowRect Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpRect As RECT) As LongPrivate 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 LongPrivate Declare Function GetParent Lib" user32.dll "(ByVal Hwnd As Long ) AS longprivate 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 WinDowPrivate M_ltabwnd As Long' Toolbar Window'private Milist As Long 'ImageList
Private Const m_def_fontname $ = "Arial" Private Const m_def_fontsize $ = 9Private Const m_def_fontcharset = 134'return 0: pass the message; other: no passPublic Function WindowProc (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As longstatic TNMT As NMHDRCopyMemory TNMT, BYVAL LPARAM, LEN (TNMT) SELECT CASE TNMT.CODE CASE TCN_SELCHANGE RAISEEVENT CHANGED ()) End SelectWindowProc = 0nd 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 subsclass_tabctl (m_lmsgwnd, me)
Create = M_LTABWndend 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 IFEND 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 TCITEMIF M_LTABWND <> 0 THEN WITH TABITEMINFO 'Add tab. .mask = TCIF_TEXT .pszText = vCaption End With SendMessage m_lTabWnd, TCM_INSERTITEMA, vPos, TabItemInfoEnd IfEnd SubPublic Sub DelItem (vPos &) If m_lTabWnd <> 0 Then SendMessage m_lTabWnd, TCM_DELETEITEM, vPos, ByVal 0 & End IfEnd Sub
Public Sub Clear () IF M_LTABWND <> 0 THEN SENDMESSAGE M_LTABWND, TCM_DELETEALLITEMS, 0 &, BYVAL 0 & End IFEND SUB
Public Function GetSelected () As longif m_ltabwnd <> 0 Then getSelected = SendMessage (m_ltabwnd, tcm_getcursl, 0 &, byval 0 & else getselected = -1END OFEND FUNCTION
Public Sub GetjustRect (Optional Vleft &, Optional Vtop &, _ Optional VRIGHT & OPTIONAL VBOTTOM &) DIM TRCAD AS RectdIm Trcwn As Rectdim 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 vgerht = tpt.x (trcwn.right trcad.right) - (trcwn.left trcad.Left) vbottom = tpt.y (trcwn.bottom trcad.bottom) - (trcwn.top trcad.top) End ifend sub
Public Sub GetRect (Optional vLeft &, Optional vTop &, _ Optional vRight &, Optional vBottom &) Dim tRc As RECTIf m_lTabWnd <> 0 Then GetWindowRect m_lTabWnd, tRc vLeft = tRc.Left vTop = tRc.Top vRight = tRc.Right vBottom = tRc.BottomEnd IFEND Subpublic Sub Move (X &, Y &, CX &, CY &) IF M_LTABWND <> 0 and MOVEWINDOW M_LMSGWND, X, Y, CX, CY, 1 MOVEWINDOW M_LTABWND, X, Y, CX, CY, 1END IFEND SUB
'Play in Zorder Costu 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 IFend Sub
Public Sub Destroy () IF M_LTABWND <> 0 THEN DESTROYWINDOW M_LTABWND M_LTABWND = 0nd IF
IF m_lmsgwnd <> 0 THEN DESTROYWINDOW M_LMSGWND UNSUBCLASS_TABCTL M_LMSGWND M_LMSGWND = 0END IFEND SUB
Private function makelong (Wlow As Long, WHIGH AS long) As longmakelong = WHIGH * & H10000 WLOWEND FUNCTION
Private sub coplass_initialize () Call DestroyEnd Sub
Public property get hwnd () as longwnd = m_ltabWndend Property
'#################################################################### ## fom ################################################################################################################################################################################################################################################################################################### ##########
Option expedition
Private WithEvents ttab As cTabControl32Private Declare Function BringWindowToTop Lib "user32.dll" (ByVal Hwnd As Long) As LongPrivate 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 LongPrivate Declare Function ScreenToClient Lib "user32.dll" (ByVal Hwnd As Long, ByRef lpPoint As POINTAPI) As LongPrivate Type POINTAPI x As Long y As LongEnd TypePrivate Sub Command1_Click () ttab .Delitem 2nd Sub
Private sub form_load () set ttab = new cTabcontrol32ttab.create me.hwnd, tcs_hottrack, 0, 0, me.scalewidth / 15, me.scaleheight / 15ttab.additem 0, "Tab1" TTAB.ADDITEM 1, "Tab2" TTAB. AddItem 2, "Tab3" TTAB.Additem 3, "Page 4" 'TTAB.SETFONTTTAB.SETFONT
Command1.zorderend Sub 'TabChanged' This frmTest's private method is used to process the TAB Control page change.
PRIVATE SUB FORM_RESize () Ttab.move 0, 0, Me.scalewidth / 15, Me.ScaleHeight / 15
DIM X & 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 vposend Sub
