Results 1 to 19 of 19

Thread: how to make SSTab by vb6 usercontrol?

  1. #1

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    how to make SSTab by vb6 usercontrol?

    Want to use the least code to achieve, I don't know what to do?
    In the design mode of the form, click multiple tab controls to automatically switch, you can add sub-controls, switch between different tabs, and display different controls inside.

    windowless=False is required, the mouse click event of the custom control is processed in the form design mode to achieve the purpose of selecting tabs 1-3
    Last edited by xiaoyao; May 11th, 2021 at 09:38 AM.

  2. #2
    PowerPoster Arnoutdv's Avatar
    Join Date
    Oct 2013
    Posts
    4,512

    Re: how to make SSTab by vb6 usercontrol?

    Have a look at the codebank
    There is a TabControl by Eduardo

  3. #3

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    Quote Originally Posted by Arnoutdv View Post
    Have a look at the codebank
    There is a TabControl by Eduardo
    That is too complicated to understand.
    If 3 LABEL controls are added to the custom controls, can I click on these 3 objects in the form design state? How to trigger an event?

  4. #4
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    You need to subclass the WM_LBUTTONDOWN message

  5. #5

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    My idea is to add 3 label control arrays (label1(0), label1(1), label1(2) to the custom control, set to container mode
    Make an array or related structure.
    Then drag and drop the control to the form, click label1(0) in the form, and then add a few controls and store them in TabInfoList(0).TabControlList
    Click label1(1), the previously added control will be hidden, or set LEFT to -1000
    The newly added controls are stored in TabInfoList(1).TabControlList

    Click 3 label controls to simulate switching of 3 tabs.
    Respectively display the corresponding TabInfoList(Index).TabControlList control list
    Code:
    Private Type TabInfo
        Tabid As Long
        tabName As String
        TabControlList As Collection
    End Type
    Dim TabInfoList() As TabInfo
    
    Private Sub UserControl_Initialize()
    ReDim TabInfoList(2)
    
    hook  UserControl.hwnd
    get x,y from :The position where the control was clicked in the form design state
    end sub

  6. #6
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    Yes, that's more or less what you need to do.
    But be aware that labels controls don't support Unicode.

  7. #7

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    Unicode need by DrawTextW

    WM_LBUTTONDOWN maybe can't read mouse x,y?
    now it's ok.
    Code:
       Dim X As Integer, Y As Integer
       X = lParam And &HFFFF&
       Y = (lParam And &HFFFF0000) \ &H10000
    Code:
    'in form1.frm
    Private Sub Form_Load()
    Call HookHwnd(Command1.hwnd)
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    Call UnHookHwnd(Command1.hwnd)
    End Sub
    Code:
    Option Explicit
    'in base file
     
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Copyright 2002 40Star, All Rights Reserved.
    '
    'E-Mail      :40Star@163.com
    'Distribution:你可以完全自由随便的使用这段代码,不管你用于任何目的
    '              程序在于交流和学习
    '              如有任何BUG请和我联系
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As String) As Long
    
    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 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
      
    Const GWL_WNDPROC = (-4&)
    
    Dim PrevWndProc&
    
    Private Const WM_DESTROY = &H2
    
    
    Public Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long
    
    Public Const TME_CANCEL = &H80000000
    Public Const TME_HOVER = &H1&
    Public Const TME_LEAVE = &H2&
    Public Const TME_NONCLIENT = &H10&
    Public Const TME_QUERY = &H40000000
    
    Private Const WM_LBUTTONDOWN = &H201
    Private Const WM_LBUTTONUP = &H202
    Private Const WM_MOUSELEAVE = &H2A3&
    Private Const WM_MOUSEMOVE = &H200
    
    Public Type TRACKMOUSEEVENTTYPE
        cbSize As Long
        dwFlags As Long
        hwndTrack As Long
        dwHoverTime As Long
    End Type
    
    Public bTracking As Boolean
    Dim evtTrack As TRACKMOUSEEVENTTYPE
    '''''''''''''''''''''''''''''''''''''''''
    Private Type POINTAPI
     x As Long
     y As Long
    End Type
    
    Private Type MSLLHOOKSTRUCT
     Pt As POINTAPI
     mouseData As Long
     Flags As Long
     time As Long
     dwExtraInfo As Long
    End Type
    
    Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    
     
    Private Function SubWndProc(ByVal hwnd As Long, ByVal Msg As Long, _
                                ByVal wParam As Long, ByVal lParam As Long) _
                                As Long
    
       If Msg = WM_DESTROY Then UnHookHwnd (hwnd)
    
       '处理鼠标移出消息
       If Msg = WM_MOUSEMOVE Then
            If bTracking = False Then
                '只加入一次拦截,防止重复处理
               bTracking = True
                Dim ET As TRACKMOUSEEVENTTYPE
                'initialize structure
                ET.cbSize = Len(ET)
                ET.hwndTrack = hwnd
                ET.dwFlags = TME_LEAVE
                'start the tracking
                TrackMouseEvent ET
            End If
    
       ElseIf Msg = WM_MOUSELEAVE Then
          bTracking = False
          Debug.Print "The mouse left the form"
    
       ElseIf Msg = WM_LBUTTONDOWN Then
            Debug.Print "mouse left click"
       Dim X As Integer, Y As Integer
       X = lParam And &HFFFF&
       Y = (lParam And &HFFFF0000) \ &H10000
    
       End If
       SubWndProc = CallWindowProc(PrevWndProc, hwnd, Msg, wParam, lParam)
    End Function
    
    Public Sub HookHwnd(hwnd As Long)
      PrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubWndProc)
    End Sub
    
    Public Sub UnHookHwnd(hwnd As Long)
      Call SetWindowLong(hwnd, GWL_WNDPROC, PrevWndProc)
    End Sub
    ' -- 模块结束 -- '
    Last edited by xiaoyao; May 11th, 2021 at 09:36 AM.

  8. #8

  9. #9

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    Quote Originally Posted by Eduardo- View Post
    In the WM_LBUTTONDOWN message the lParam have the X and Y.
    Code:
       Dim X As Integer, Y As Integer
       X = lParam And &HFFFF&
       Y = (lParam And &HFFFF0000) \ &H10000
    yes ,it's ok

    'The following 2 conditions must be met to generate a HitTest event
    'UserControl.windowless=true'No window mode (no handle)
    'UserControl.BackStyle = 0'Transparent, the control is transparent


    Because I want to add some other controls to the custom control and drag and drop the control in the form, then use the TAB option to group and manually add multiple sub-controls.
    windowless=true, no more controls can be added.
    Last edited by xiaoyao; May 12th, 2021 at 01:39 AM.

  10. #10
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    Yes, you cannot add contained controls to a windowless usercontrol.

  11. #11

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    Multi-function TAB control, he uses the LEFT method, which puts LEFT on the left, but the LINE control only has X1, Y1 properties, and does not support LEFT properties. Buttons and other controls can generally be supported.

  12. #12
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    Yes, for Line controls you need to move X1 and X2 instead of Left.

  13. #13

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    .Tab Control Group of multi-control the principle of grouping other tabs to the left distance into-7000.I don't know if there's another way.Originally, I wanted to create a virtual temporary container, like a shipyard.But in the form design state to modify the child control parent object, the container is not OK, perhaps to use the plug-in method.

  14. #14
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    The contained controls that are in the usercontrol belong to the host (the usercontrol's Parent, that can be a form, another usercontrol or a property page). You are not allowed to change their container to something inside your usercontrol, because that would mean to change their parent. VB6 doesn't allow you to do that (it raises an error).
    Perhaps you could try with the API SetParent, but that won't work with windowless controls.

    You could set them Visible to False when they are not in the current tab (instead of moving them to the left), but that would raise problems when the host program attempts to make them Visible or not Visible.

  15. #15

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    SetParent can't support label,sharpe control,that have no hwnd.

    There is also the easiest way, if there are 10 tabs, add 10 picturebox controls as a container, and put the corresponding controls into it.
    When needed, insert these containers into the tab custom control to display, but it is so convenient that there is no TAB control to click on a different tab and drag and drop the control directly.

    yes ,uses "Visible "Attributes ,it's will be conflict. Let the left distance of the controls of other tabs be -7000, this is the easiest way.

    In the custom control, in the form design mode, can the parent object be set to another container in the form, or an invisible container in the custom control? let me try.
    It is feasible to cut the control with the mouse and paste it to other containers.
    Therefore, it is definitely feasible to use the VB6 ADD-IN plug-in mechanism, and then set the position in the new container after cutting. Cut back when switching to other tabs, and move the controls in the originally visible tab to the transit container. But this code may be more complicated.

    how to get mouse WM_LBUTTONDOWN event by subclass for design mode ,when usercontrol put on form1.frm?

    this clsTrickSubclass.cls、clsTrickSubclass2.cls i can't get message callback
    [VB6] - Class for subclassing windows and classes.-VBForums
    https://www.vbforums.com/showthread....ws-and-classes
    Last edited by xiaoyao; May 12th, 2021 at 11:49 AM.

  16. #16
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    If to use a control involves also installing a custom add-in, it is complicated.

    About Trick's subclassing, I think you should ask to him.

  17. #17

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    I DON'T KHNOw about your "IBSSubclass.cls"

    m_lOrigWndProc = SetWindowLong(UserControl.Hwnd, GWL_WNDPROC, AddressOf WndProc)
    i can hook WM_LBUTTONDOWN message in bas file,how to run WndProc in usrcontrol,without bas file?

  18. #18
    PowerPoster
    Join Date
    Feb 2017
    Posts
    3,209

    Re: how to make SSTab by vb6 usercontrol?

    I think Trick's subclassing does that. Another one is wqweto's MST subclassing.

  19. #19

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    Re: how to make SSTab by vb6 usercontrol?

    Quote Originally Posted by Eduardo- View Post
    I think Trick's subclassing does that. Another one is wqweto's MST subclassing.
    yes ,it's very good.
    self-contained/Project1.vbp,thanks for [wqweto's MST subclassing.]
    ctxTrackMouse.ctl
    it's can get mouse event for tab control

    set Usercontrol.ControlContainer=True

    Code:
    Public Function SubclassProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) As Long
        Select Case wMsg
        Case WM_LBUTTONDOWN
            Debug.Print "Mouse Click-" & "x,y=" & (lParam And &HFFFF&) & "," & (lParam \ &H10000 And &HFFFF&) & ",Handled=" & Handled
    Code:
    'SubClassControl.ctl /usercontrol
    Option Explicit
    'set Usercontrol.ControlContainer=True 
    
    DefObj A-Z
    
    #Const ImplNoIdeProtection = (MST_NO_IDE_PROTECTION <> 0)
    #Const ImplSelfContained = True
    
    '=========================================================================
    ' Events
    '=========================================================================
    
    Event MouseEnter()
    Event MouseLeave()
    
    '=========================================================================
    ' API
    '=========================================================================
    Private Const WM_LBUTTONDOWN As Long = &H201
    Private Const WM_CANCELMODE                 As Long = &H1F
    Private Const WM_MOUSELEAVE                 As Long = &H2A3
    '--- for Modern Subclassing Thunk (MST)
    Private Const MEM_COMMIT                    As Long = &H1000
    Private Const PAGE_EXECUTE_READWRITE        As Long = &H40
    Private Const SIGN_BIT                      As Long = &H80000000
    Private Const PTR_SIZE                      As Long = 4
    Private Const EBMODE_DESIGN                 As Long = 0
    '--- end MST
    
    Private Declare Function TrackMouseEvent Lib "comctl32" Alias "_TrackMouseEvent" (lpEventTrack As TRACKMOUSESTRUCT) As Long
    '--- for Modern Subclassing Thunk (MST)
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect 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 Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Declare Function GetProcByOrdinal Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcOrdinal As Long) As Long
    Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
    #If Not ImplNoIdeProtection Then
        Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
        Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    #End If
    #If ImplSelfContained Then
        Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
        Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
    #End If
    '--- end MST
    
    Private Enum TrackMouseEventFlags
        TME_HOVER = &H1
        TME_LEAVE = &H2
        TME_NONCLIENT = &H10
        TME_QUERY = &H40000000
        TME_CANCEL = &H80000000
    End Enum
    
    Private Type TRACKMOUSESTRUCT
        cbSize              As Long
        dwFlags             As TrackMouseEventFlags
        hwndTrack           As Long
        dwHoverTime         As Long
    End Type
    
    '=========================================================================
    ' Constants and member variables
    '=========================================================================
    
    Private m_pSubclass         As IUnknown
    Private m_bIsHot            As Boolean
    
    '=========================================================================
    ' Properties
    '=========================================================================
    
    Property Get IsHot() As Boolean
        IsHot = m_bIsHot
    End Property
    
    Property Let IsHot(ByVal bValue As Boolean)
        m_bIsHot = bValue
        BackColor = IIf(bValue, vbHighlight, vbInfoBackground)
    End Property
    
    '=========================================================================
    ' Methods
    '=========================================================================
    
    Private Sub pvSubclass()
        Set m_pSubclass = InitSubclassingThunk(hWnd, Me, InitAddressOfMethod(Me, 5).SubclassProc(0, 0, 0, 0, 0))
    End Sub
    
    Private Sub pvUnsubclass()
        TerminateSubclassingThunk m_pSubclass, Me
    End Sub
    
    Public Function SubclassProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) As Long
    'Debug.Print "自定义控件子类化-" & Now
        Select Case wMsg
        Case WM_MOUSELEAVE, WM_CANCELMODE
            If IsHot Then
                IsHot = False
                RaiseEvent MouseLeave
            End If
        Case WM_LBUTTONDOWN
            Debug.Print "Mouse Click-" & "x,y=" & (lParam And &HFFFF&) & "," & (lParam \ &H10000 And &HFFFF&) & ",Handled=" & Handled
            'abcd,我加的
        End Select
        '--- note: performance optimization for design-time subclassing
        '设计时子类的性能优化
        If Not Handled And ThunkPrivateData(m_pSubclass) = EBMODE_DESIGN Then
            '这里肯定会运行
            Handled = True
            SubclassProc = DefSubclassProc(hWnd, wMsg, wParam, lParam)
        End If
    End Function
    
    '=========================================================================
    ' Control events
    '=========================================================================
    
    Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim uTrackMouse     As TRACKMOUSESTRUCT
        
        If Not IsHot Then
            IsHot = True
            With uTrackMouse
                .cbSize = Len(uTrackMouse)
                .hwndTrack = hWnd
                .dwFlags = TME_LEAVE Or TME_HOVER
            End With
            Call TrackMouseEvent(uTrackMouse)
            RaiseEvent MouseEnter
        End If
    End Sub
    
    Private Sub UserControl_InitProperties()
        pvSubclass
    End Sub
    
    Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
        pvSubclass
    End Sub
    
    Private Sub UserControl_Terminate()
        pvUnsubclass
    End Sub
    
    '=========================================================================
    ' The Modern Subclassing Thunk (MST)
    '=========================================================================
    
    Private Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As SubClassControl
        Dim STR_THUNK       As String: STR_THUNK = "6AAAAABag+oFV4v6ge9QEMEAgcekEcEAuP9EJAS5+QcAAPOri8LB4AgFuQAAAKuLwsHoGAUAjYEAq7gIAAArq7hEJASLq7hJCIsEq7iBi1Qkq4tEJAzB4AIFCIkCM6uLRCQMweASBcDCCACriTrHQgQBAAAAi0QkCIsAiUIIi0QkEIlCDIHqUBDBAIvCBTwRwQCri8IFUBHBAKuLwgVgEcEAq4vCBYQRwQCri8IFjBHBAKuLwgWUEcEAq4vCBZwRwQCri8IFpBHBALn5BwAAq4PABOL6i8dfgcJQEMEAi0wkEIkRK8LCEAAPHwCLVCQE/0IEi0QkDIkQM8DCDABmkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEg/gAfgPCBABZWotCDGgAgAAAagBSUf/gZpC4AUAAgMIIALgBQACAwhAAuAFAAIDCGAC4AUAAgMIkAA==" ' 25.3.2019 14:01:08
        Const THUNK_SIZE    As Long = 16728
        Dim hThunk          As Long
        Dim lSize           As Long
        
        hThunk = pvThunkAllocate(STR_THUNK, THUNK_SIZE)
        If hThunk = 0 Then
            Exit Function
        End If
        lSize = CallWindowProc(hThunk, ObjPtr(pObj), MethodParamCount, GetProcAddress(GetModuleHandle("kernel32"), "VirtualFree"), VarPtr(InitAddressOfMethod))
        Debug.Assert lSize = THUNK_SIZE
    End Function
    
    Private Function InitSubclassingThunk(ByVal hWnd As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
        Dim STR_THUNK       As String: STR_THUNK = "6AAAAABag+oFgepwEBAAV1aLdCQUg8YIgz4AdC+L+oHHKBIQAIvCBQwREACri8IFSBEQAKuLwgVYERAAq4vCBYAREACruQkAAADzpYHCKBIQAFJqHP9SEFqL+IvCq7gBAAAAqzPAq4tEJAyri3QkFKWlM8Crg+8cagBX/3IM/3cM/1IYi0QkGIk4Xl+4XBIQAC1wEBAAwhAADx8Ai0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1GIsKUv9xDP9yDP9RHItUJASLClL/URQzwMIEAJBVi+yLVRj/QgT/QhiLQhg7QgR0b4tCEIXAdGiLCotBLIXAdDdS/9BaiUIIg/gBd1OFwHUJgX0MAwIAAHRGiwpS/1EwWoXAdTuLClJq8P9xJP9RKFqpAAAACHUoUjPAUFCNRCQEUI1EJARQ/3UU/3UQ/3UM/3UI/3IQ/1IUWVhahcl1E1KLCv91FP91EP91DP91CP9RIFr/ShhQUug4////WF3CGAAPHwA=" ' 9.6.2020 13:56:03
        Const THUNK_SIZE    As Long = 492
        Static hThunk       As Long
        Dim aParams(0 To 10) As Long
        Dim lSize           As Long
        
        aParams(0) = ObjPtr(pObj)
        aParams(1) = pfnCallback
        #If ImplSelfContained Then
            If hThunk = 0 Then
                hThunk = pvThunkGlobalData("InitSubclassingThunk")
            End If
        #End If
        If hThunk = 0 Then
            hThunk = pvThunkAllocate(STR_THUNK, THUNK_SIZE)
            If hThunk = 0 Then
                Exit Function
            End If
            aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
            aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
            Call DefSubclassProc(0, 0, 0, 0)                                            '--- load comctl32
            aParams(4) = GetProcByOrdinal(GetModuleHandle("comctl32"), 410)             '--- 410 = SetWindowSubclass ordinal
            aParams(5) = GetProcByOrdinal(GetModuleHandle("comctl32"), 412)             '--- 412 = RemoveWindowSubclass ordinal
            aParams(6) = GetProcByOrdinal(GetModuleHandle("comctl32"), 413)             '--- 413 = DefSubclassProc ordinal
            '--- for IDE protection
            Debug.Assert pvThunkIdeOwner(aParams(7))
            If aParams(7) <> 0 Then
                aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
                aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
                aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
            End If
            #If ImplSelfContained Then
                pvThunkGlobalData("InitSubclassingThunk") = hThunk
            #End If
        End If
        lSize = CallWindowProc(hThunk, hWnd, 0, VarPtr(aParams(0)), VarPtr(InitSubclassingThunk))
        Debug.Assert lSize = THUNK_SIZE
    End Function
    
    Private Function TerminateSubclassingThunk(pSubclass As IUnknown, pObj As Object) As IUnknown
        If Not pSubclass Is Nothing Then
            Debug.Assert ThunkPrivateData(pSubclass, 2) = ObjPtr(pObj)
            ThunkPrivateData(pSubclass, 2) = 0
            Set pSubclass = Nothing
        End If
    End Function
    
    Property Get ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long) As Long
        Dim lPtr            As Long
        lPtr = ObjPtr(pThunk)
        If lPtr <> 0 Then
            Call CopyMemory(ThunkPrivateData, ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, PTR_SIZE)
        End If
    End Property
    
    Property Let ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long, ByVal lValue As Long)
        Dim lPtr            As Long
        
        lPtr = ObjPtr(pThunk)
        If lPtr <> 0 Then
            Call CopyMemory(ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, lValue, PTR_SIZE)
        End If
    End Property
    
    Private Function pvThunkIdeOwner(hIdeOwner As Long) As Boolean
        #If Not ImplNoIdeProtection Then
            Dim lProcessId      As Long
            
            Do
                hIdeOwner = FindWindowEx(0, hIdeOwner, "IDEOwner", vbNullString)
                Call GetWindowThreadProcessId(hIdeOwner, lProcessId)
            Loop While hIdeOwner <> 0 And lProcessId <> GetCurrentProcessId()
        #End If
        pvThunkIdeOwner = True
    End Function
    
    Private Function pvThunkAllocate(sText As String, Optional ByVal Size As Long) As Long
        Static Map(0 To &H3FF) As Long
        Dim baInput()       As Byte
        Dim lIdx            As Long
        Dim lChar           As Long
        Dim lPtr            As Long
        
        pvThunkAllocate = VirtualAlloc(0, IIf(Size > 0, Size, (Len(sText) \ 4) * 3), MEM_COMMIT, PAGE_EXECUTE_READWRITE)
        If pvThunkAllocate = 0 Then
            Exit Function
        End If
        '--- init decoding maps
        If Map(65) = 0 Then
            baInput = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
            For lIdx = 0 To UBound(baInput)
                lChar = baInput(lIdx)
                Map(&H0 + lChar) = lIdx * (2 ^ 2)
                Map(&H100 + lChar) = (lIdx And &H30) \ (2 ^ 4) Or (lIdx And &HF) * (2 ^ 12)
                Map(&H200 + lChar) = (lIdx And &H3) * (2 ^ 22) Or (lIdx And &H3C) * (2 ^ 6)
                Map(&H300 + lChar) = lIdx * (2 ^ 16)
            Next
        End If
        '--- base64 decode loop
        baInput = StrConv(Replace(Replace(sText, vbCr, vbNullString), vbLf, vbNullString), vbFromUnicode)
        lPtr = pvThunkAllocate
        For lIdx = 0 To UBound(baInput) - 3 Step 4
            lChar = Map(baInput(lIdx + 0)) Or Map(&H100 + baInput(lIdx + 1)) Or Map(&H200 + baInput(lIdx + 2)) Or Map(&H300 + baInput(lIdx + 3))
            Call CopyMemory(ByVal lPtr, lChar, 3)
            lPtr = (lPtr Xor SIGN_BIT) + 3 Xor SIGN_BIT
        Next
    End Function
    
    #If ImplSelfContained Then
    Private Property Get pvThunkGlobalData(sKey As String) As Long
        Dim sBuffer     As String
        
        sBuffer = String$(50, 0)
        Call GetEnvironmentVariable("_MST_GLOBAL" & GetCurrentProcessId() & "_" & sKey, sBuffer, Len(sBuffer) - 1)
        pvThunkGlobalData = Val(Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1))
    End Property
    
    Private Property Let pvThunkGlobalData(sKey As String, ByVal lValue As Long)
        Call SetEnvironmentVariable("_MST_GLOBAL" & GetCurrentProcessId() & "_" & sKey, lValue)
    End Property
    #End If
    
    
    Public Sub Test()
    '
    End Sub
    Public Function Sum(ByVal a As Long, ByVal b As Long)
    Sum = a + b
    End Function
    Last edited by xiaoyao; May 12th, 2021 at 01:21 PM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width