Obtener puntero de funcion dentro de un form o class.

[LeandroA]

Hola BlackZeroX si funciona quizas lo probaste con un STATIC y no recibe el WM_MouseMove proba con BUTTON

Class1

Código [Seleccionar] Expandir


Option Explicit
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC As Long = -4
Private Const WM_DESTROY As Long = &H2

Private PrevWndProc As Long
Private bvASM(40) As Byte

Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" 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, lpParam As Any) As Long
Private Const WS_VISIBLE As Long = &H10000000
Private mWnd As Long

Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    WindowProc = CallWindowProcA(PrevWndProc, hwnd, Msg, wParam, lParam)

    If Msg = WM_DESTROY Then
        Call StopSubclassing(hwnd)
    End If
   
    Debug.Print Msg, wParam, lParam
End Function

Private Sub SetSubclassing(Obj As Object, hwnd As Long)
    Dim WindowProcAddress As Long
    Dim pObj As Long
    Dim pVar As Long

    Dim i As Long

    For i = 0 To 40
        bvASM(i) = Choose(i + 1, &H55, &H8B, &HEC, &H83, &HC4, &HFC, &H8D, &H45, &HFC, &H50, &HFF, &H75, &H14, _
                                 &HFF, &H75, &H10, &HFF, &H75, &HC, &HFF, &H75, &H8, &H68, &H0, &H0, &H0, &H0, _
                                 &HB8, &H0, &H0, &H0, &H0, &HFF, &HD0, &H8B, &H45, &HFC, &HC9, &HC2, &H10, &H0)
    Next i

    pObj = ObjPtr(Obj)

    Call CopyMemory(pVar, ByVal pObj, 4)
    Call CopyMemory(WindowProcAddress, ByVal (pVar + 28), 4)

    Call LongToByte(pObj, bvASM, 23)
    Call LongToByte(WindowProcAddress, bvASM, 28)

    PrevWndProc = SetWindowLongA(hwnd, GWL_WNDPROC, VarPtr(bvASM(0)))
End Sub

Private Sub StopSubclassing(hwnd)
    Call SetWindowLongA(hwnd, GWL_WNDPROC, PrevWndProc)
End Sub

Private Sub LongToByte(ByVal lLong As Long, ByRef bReturn() As Byte, Optional i As Integer = 0)
    bReturn(i) = lLong And &HFF
    bReturn(i + 1) = (lLong And 65280) / &H100
    bReturn(i + 2) = (lLong And &HFF0000) / &H10000
    bReturn(i + 3) = ((lLong And &HFF000000) \ &H1000000) And &HFF
End Sub

Private Sub Class_Initialize()
    mWnd = CreateWindowEx(0&, "Button", "Hola Mundo", WS_VISIBLE, 0&, 0&, 300, 300, 0&, 0&, App.hInstance, ByVal 0&)
    If mWnd <> 0 Then Call SetSubclassing(Me, mWnd)
End Sub

Private Sub Class_Terminate()
    If mWnd <> 0 Then
        Call StopSubclassing(mWnd)
        DestroyWindow mWnd
    End If
End Sub


Saludos.

[BlackZeroX]

...
Edito:

Cuando declaro algunas cosas mas crashea  ... ya encontre el horror, es que el ASM modifica la 1ra cosa publica y como tenia una variable publica pues crasheaba ya que no era mi WinProc...

Código (Vb) [Seleccionar] Expandir



Dim c As Class1
Private Sub Form_Load()
   Set c = New Class1
End Sub



Código (Vb,57) [Seleccionar] Expandir



Option Explicit

Private Const GWL_WNDPROC                   As Long = -4
Private Const WM_DESTROY                    As Long = &H2
Private Const WS_VISIBLE                    As Long = &H10000000
Private Const MAX_PATH                      As Integer = 260
Private Const MAXDWORD                      As Long = &HFFFF
Private Const INVALID_HANDLE_VALUE          As Long = -1

Private Type FILETIME
   dwLowDateTime                           As Long
   dwHighDateTime                          As Long
End Type

Private Type WIN32_FIND_DATA                                        '// Bytes...
   dwFileAttributes                        As Long                 '// 4
   ftCreationTime                          As FILETIME             '// 8
   ftLastAccessTime                        As FILETIME             '// 8
   ftLastWriteTime                         As FILETIME             '// 8
   nFileSizeHigh                           As Long                 '// 4
   nFileSizeLow                            As Long                 '// 4
   dwReserved0                             As Long                 '// 4
   dwReserved1                             As Long                 '// 4
   cFileName                               As String * MAX_PATH    '// MAX_PATH*2 = 260*2 = 520
   cAlternate                              As String * 14          '// 14*2 = 28
End Type                                                            '// total bytes: 592 bytes...  = &H250

Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function lstrcmp Lib "KERNEL32" Alias "lstrcmpA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function FindFirstFile& Lib "KERNEL32" Alias "FindFirstFileA" (ByVal lpFileName$, lpFindFileData As WIN32_FIND_DATA)
Private Declare Function FindNextFile& Lib "KERNEL32" Alias "FindNextFileA" (ByVal hFindFile&, lpFindFileData As WIN32_FIND_DATA)
Private Declare Function GetFileAttributes Lib "KERNEL32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "KERNEL32" (ByVal hFindFile As Long) As Long

'   //  SubClassing
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProcA Lib "user32" (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 DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" 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, lpParam As Any) As Long

Private bIni                                As Boolean
Private sDir                                As String
Private sCriterios()                        As String
Private bIncludeFolders                     As Boolean
Private bCancel                             As Boolean
Private tVBFAFoundInDir                     As VbFileAttribute
Private tVBFAFoundInFile                    As VbFileAttribute
Private lhSearchF()                         As Long
Private lsIndex(0 To 1)                     As Long
Private dblBytesNow_                        As Double
Private tWFDFound                           As WIN32_FIND_DATA
Private bRun                                As Boolean
Private bFound                              As Boolean
Private bPause                              As Boolean
'public AllowEvents                        As Boolean ' // No pongan nada en modo publico xS.
private bAllowEvents                        As Boolean ' // No pongan nada en modo publico xS.

Private PrevWndProc                         As Long
Private bvASM(40)                           As Byte
Private mWnd                                As Long

Event Folder(ByRef PathFolder As String)
Event File(ByVal TypeOfFile As Long)
Event Begin()
Event Finish()

Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
   WindowProc = CallWindowProcA(PrevWndProc, hwnd, Msg, wParam, lParam)

   If Msg = WM_DESTROY Then
       Call StopSubclassing(hwnd)
   End If
   
   Debug.Print Msg, wParam, lParam
End Function

Private Sub SetSubclassing(Obj As Object, hwnd As Long)
   Dim WindowProcAddress As Long
   Dim pObj As Long
   Dim pVar As Long

   Dim i As Long

   For i = 0 To 40
       bvASM(i) = Choose(i + 1, &H55, &H8B, &HEC, &H83, &HC4, &HFC, &H8D, &H45, &HFC, &H50, &HFF, &H75, &H14, _
                                &HFF, &H75, &H10, &HFF, &H75, &HC, &HFF, &H75, &H8, &H68, &H0, &H0, &H0, &H0, _
                                &HB8, &H0, &H0, &H0, &H0, &HFF, &HD0, &H8B, &H45, &HFC, &HC9, &HC2, &H10, &H0)
   Next i

   pObj = ObjPtr(Obj)

   Call CopyMemory(pVar, ByVal pObj, 4)
   Call CopyMemory(WindowProcAddress, ByVal (pVar + 28), 4)

   Call LongToByte(pObj, bvASM, 23)
   Call LongToByte(WindowProcAddress, bvASM, 28)

   PrevWndProc = SetWindowLongA(hwnd, GWL_WNDPROC, VarPtr(bvASM(0)))
End Sub

Private Sub StopSubclassing(hwnd)
   Call SetWindowLongA(hwnd, GWL_WNDPROC, PrevWndProc)
End Sub

Private Sub LongToByte(ByVal lLong As Long, ByRef bReturn() As Byte, Optional i As Integer = 0)
   bReturn(i) = lLong And &HFF
   bReturn(i + 1) = (lLong And 65280) / &H100
   bReturn(i + 2) = (lLong And &HFF0000) / &H10000
   bReturn(i + 3) = ((lLong And &HFF000000) \ &H1000000) And &HFF
End Sub

Private Sub Class_Initialize()
   mWnd = CreateWindowEx(0&, "Button", "Hola Mundo", WS_VISIBLE, 0&, 0&, 300, 300, 0&, 0&, App.hInstance, ByVal 0&)
   If mWnd <> 0 Then Call SetSubclassing(Me, mWnd)
End Sub

Private Sub Class_Terminate()
   If mWnd <> 0 Then
       Call StopSubclassing(mWnd)
       DestroyWindow mWnd
   End If
End Sub



Temibles Lunas!¡.

[F3B14N]

En modulos clase:

Call CopyMemory(WindowProcAddress, ByVal (pVar + &H1C + (ProcIndex * 4&)), 4)

[BlackZeroX]

En modulos clase:

Call CopyMemory(WindowProcAddress, ByVal (pVar + &H1C + (ProcIndex * 4&)), 4)

excelente con el ProcIndex podremos hacer varias subclasificaciones con el codigo xD

Dulces Lunas!¡.

[BlackZeroX]

alguien tiene el ASM?, quiero ver que es lo que modifica/hace.

Dulces Lunas!¡.