muy bueno F3B14N, veo que eliminaste VirtualAlloc y VirtualFree con lo que se termino el problema que mencionaba anteriormente al parecer todo funciona de lujo  , además se simplifico mucho mas.

Gracias por compartirlo.

PD: fijate quizas te guste mas para crear el ASM(), creo que asi lo hacia Cobein.

Código:

        Dim sCode As String

   
        sCode = "90FF05000000006A0054FF742418FF742418FF742418FF7424186800000000B800000000FFD0FF0D00000000A10000000085C075" & _
                "0458C21000A10000000085C0740458C2100058595858585868008000006A00680000000051B800000000FFE00000000000000000"
               
        For i = 0 To Len(sCode) - 1 Step 2
            bvASM(i / 2) = CByte("&h" & Mid$(sCode, i + 1, 2))
        Next

Saludos.

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 Const WM_MOUSEMOVE As Long = &H200
 
Private PrevWndProc As Long
Private bvASM(40) As Byte
 
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(Me.Hwnd)
    ElseIf Msg = WM_MOUSEMOVE Then
        Me.Caption = Timer
    End If
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 + 1784), 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 Form_Load()
    Call SetSubclassing(Me, 0, Me.Hwnd)
End Sub

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

 
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