Option Explicit

Private Declare Function socket Lib "WSOCK32" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function closesocket Lib "WSOCK32" (ByVal s As Long) As Long
Private Declare Function connect Lib "WSOCK32" (ByVal s As Long, addr As SOCKADDR, ByVal NameLen As Long) As Long
Private Declare Function send Lib "WSOCK32" (ByVal s As Long, Buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Private Declare Function recv Lib "WSOCK32" (ByVal s As Long, Buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function inet_addr Lib "WSOCK32" (ByVal cp As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32" (ByVal wVR As Long, lpWSAD As Long) As Long
Private Declare Function WSACleanup Lib "WSOCK32" () As Long
Private Declare Function WSAAsyncSelect Lib "WSOCK32" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long

Private Declare Function CreateWindowExA Lib "USER32" (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 Declare Function RegisterClassExA Lib "USER32" (pcWndClassEx As WNDCLASSEX) As Integer
Private Declare Function DefWindowProcA Lib "USER32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Type WNDCLASSEX
    cbSize As Long
    style As Long
    lpfnWndProc As Long
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
    hIconSm As Long
End Type

Private Type SOCKADDR
    sin_family                      As Integer
    sin_port                        As Integer
    sin_addr                        As Long
    sin_zero                        As String * 8
End Type

Private Const AF_INET = 2
Private Const PF_INET = 2
Private Const FD_READ = &H1&
Private Const FD_WRITE = &H2&
Private Const FD_CONNECT = &H10&
Private Const FD_CLOSE = &H20&
Private Const SOCK_STREAM = 1
Private Const IPPROTO_TCP = 6
Private Const WINSOCK_MESSAGE = 1025

Private wHwnd As Long

Public Function htons(ByVal lPort As Long) As Integer
    htons = ((((lPort And &HFF000000) \ &H1000000) And &HFF&) Or ((lPort And &HFF0000) \ &H100&) Or ((lPort And &HFF00&) * &H100&) Or ((lPort And &H7F&) * &H1000000) Or (IIf((lPort And &H80&), &H80000000, &H0)) And &HFFFF0000) \ &H10000
End Function

'--------
Public Function ProcessMessage(ByVal hWnd As Long, ByVal lMessage As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If lMessage = WINSOCK_MESSAGE Then
        Dim bBuffer(1 To 1024) As Byte
    
        Select Case lParam
            Case FD_CONNECT: Call WsSendData(wParam, StrConv("AAAAAAAAAA", vbFromUnicode))
            Case FD_WRITE:
            Case FD_READ:
                    Call recv(wParam, bBuffer(1), 1024, 0)
                    MsgBox StrConv(bBuffer, vbUnicode)
            Case FD_CLOSE: 'Jmp connect Routine
        End Select
        Exit Function
    End If
    ProcessMessage = DefWindowProcA(hWnd, lMessage, wParam, lParam)
End Function
'--------

Public Function WsInitialize(ByVal MyWndProc As Long, ByVal szSocketName As String) As Boolean
    Dim WNDC As WNDCLASSEX
    
    If wHwnd = 0 Then
        WNDC.cbSize = LenB(WNDC)
        WNDC.lpfnWndProc = MyWndProc
        WNDC.hInstance = App.hInstance
        WNDC.lpszClassName = szSocketName
    
        Call RegisterClassExA(WNDC) '0: Exit Function
        wHwnd = CreateWindowExA(0&, szSocketName, "", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, 0&) '0: Call UnregisterClass(szSocketName, App.hInstance)
    End If
    
    Call WSAStartup(&H101, 0&)
    Initialize = True
End Function
Public Sub WsTerminate()
    Call WSACleanup
End Sub

Public Function WsConnect(lRemoteHost As String, lPort As Long) As Long
    Dim SockData As SOCKADDR
    Dim hSocket As Long
    Dim lWsMsg As Long
    
    SockData.sin_family = AF_INET
    SockData.sin_port = htons(lPort) 'If sockdata.sin_port = INVALID_SOCKET Then Exit Function
    SockData.sin_addr = inet_addr(lRemoteHost) 'If sockdata.sin_addr = INADDR_NONE Then Exit Function
    hSocket = socket(PF_INET, SOCK_STREAM, IPPROTO_TCP) 'If hSocket < 0 Then Exit Function

    Call connect(hSocket, SockData, 16)  ' If hSocket Then WsClose   Exit Function
    
    If WSAAsyncSelect(hSocket, wHwnd, ByVal WINSOCK_MESSAGE, ByVal FD_READ Or FD_WRITE Or FD_CONNECT Or FD_CLOSE) Then
        lWsMsg = FD_CLOSE
    Else
        lWsMsg = FD_CONNECT
    End If
    
    Call ProcessMessage(0, WINSOCK_MESSAGE, hSocket, FD_CONNECT): WsConnect = hSocket
End Function
Public Function WsSendData(ByVal SocketIndex As Long, bMessage() As Byte) As Long
    If UBound(bMessage) > -1 Then
        WsSendData = send(SocketIndex, bMessage(0), (UBound(bMessage) - LBound(bMessage) + 1), 0)
    End If
End Function

    Private Sub Main()
    If WsInitialize(AddressOf ProcessMessage, "Server") Then
        If WsConnect("127.0.0.1", 7777) Then
            Do
                DoEvents
            Loop
        End If
    End If
End Sub

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId 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 WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long

Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000
Private Const PAGE_READWRITE = &H4
Private Const INFINITE = &HFFFFFFFF

Public Function ExecuteDll(lPid As Long) As Boolean
Dim hVictim As Long
Dim hInject As Long
Dim lParamAddress As Long
Dim lStartAddress As Long
Dim bB() As Byte
Dim sTmp As String

hVictim = OpenProcess(PROCESS_ALL_ACCESS, 0, lPid): If hVictim = 0 Then Exit Function
If hVictim = 0 Then: GoTo Error
'===
sTmp = "68" & GetLng(0) & _
"68" & GetLng(StrPtr("HOLA")) & _
"68" & GetLng(StrPtr("HOLA")) & _
"68" & GetLng(0) & "68"

Call PutThunk(sTmp, bB)
'===
lStartAddress = GetProcAddress(GetModuleHandle("USER32"), "MessageBoxA"): If lStartAddress = 0 Then GoTo Error
lParamAddress = VirtualAllocEx(hVictim, 0&, UBound(bB) + 1, MEM_COMMIT, PAGE_READWRITE): If lParamAddress = 0 Then GoTo Error
Call WriteProcessMemory(hVictim, lParamAddress, ByVal VarPtr(bB(0)), UBound(bB) + 1, ByVal 0&)
'===
hInject = CreateRemoteThread(hVictim, ByVal 0&, 0&, ByVal lStartAddress, lParamAddress, 0, ByVal 0&)
If hInject = 0 Then: GoTo Error
'===

Call WaitForSingleObject(hInject, INFINITE)
Call CloseHandle(hVictim)
Call CloseHandle(hInject)

ExecuteDll = True
Exit Function

Error:
Call CloseHandle(hInject)
Call CloseHandle(hVictim)

ExecuteDll = False
End Function

Private Function GetLng(ByVal lLng As Long) As String
Dim lTMP As Long

lTMP = (((lLng And &HFF000000) &H1000000) And &HFF&) Or ((lLng And &HFF0000) &H100&) Or ((lLng And &HFF00&) * &H100&) Or ((lLng And &H7F&) * &H1000000) ' by Mike D Sutton
If (lLng And &H80&) Then lTMP = lTMP Or &H80000000

GetLng = String$(8 - Len(Hex$(lTMP)), "0") & Hex$(lTMP)
End Function

Private Sub PutThunk(ByVal sThunk As String, ByRef bvRet() As Byte)
Dim i As Long

ReDim bvRet(0)

For i = 0 To Len(sThunk) - 1 Step 2
bvRet(i / 2) = CByte("&H" & Mid$(sThunk, i + 1, 2))
ReDim Preserve bvRet(UBound(bvRet) + 1)
Next i

ReDim Preserve bvRet(UBound(bvRet) - 1)
End Sub

Sub Main()
ExecuteDll 7756, 0
End Sub