[VB6] How to do a DLL Injector

Requirements:
3 CommandButton
2 Text
3 Module
1 Timer
1 CommonDialog1(Microsoft Common Dialog Control 6.0)
1 Label

Tutorial:

- Add all the components and tools in the form and get ready

- Text1 will be the DLL searcher and Text2 to put the window name.
- Add the code below in the "Search" CommandButton:

Dim sTemp As String
CommonDialog1.FileName = "*.dll"
CommonDialog1.ShowOpen
Text1.Text = CommonDialog1.FileName

- Add the code below in the "Auto-Inject Status- Off" CommandButton:

If Text1.Text = "" Then Exit Sub
If Text2.Text = "" Then Exit Sub

If Command1.Caption = "Status of the Injector: OFF" Then
Timer1.Enabled = True
Command1.Caption = "Status of the Injector : ON"
Exit Sub
Else
Command1.Caption = "Status of the Injector: OFF"
Timer1.Enabled = False
Label1.Caption = "Waiting to Inject DLL"
End If

- Put the code below in your project:

Option Explicit
Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetWindowText Lib "User32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "User32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Const SW_SHOW = 5

- In the "Close" CommandButton, the code below:

End

- In the Form's Load event, the code below:

GetSeDebugPrivelege
Label1.Caption = "Waiting DLL Injection"

- In the Timer, the code below:

On Error Resume Next
Dim hwnd As Long
Dim pid As Long
Dim lSuccess&
Dim pHandle As Long

hwnd = FindWindow(vbNullString, Text2.Text)
GetWindowThreadProcessId hwnd, pid
pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, pid)

If hwnd = 0 Then
Label1.Caption = "Looking for the window name..."
Else
Label1.Caption = "Window name not found!"
GetWindowThreadProcessId hwnd, pid
Label1.Caption = pid
lSuccess = InjectLibrary(pid, Text1.Text)
End If

pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, pid)
MsgBox pid
lSuccess = InjectLibrary(pid, App.Path & "\Morphine.dll")
If lSuccess > 0 Then
Label1.Caption = "DLL Injected with success!!"
Timer1.Enabled = False
Exit Sub
Else
Label1.Caption = "Waiting for the DLL Injection..."
End If
End Sub

Now the Modules part!

- Change the module names for the below's:
1st - modDebugPriveleges
2nd - modFiles
3rd - modInjection

- In the "modDebugPriveleges" add the below:

Option Explicit

Private Const SE_DEBUG_NAME As String = "SeDebugPrivilege"
Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Private Const TOKEN_QUERY As Long = &H8
Private Const SE_PRIVILEGE_ENABLED As Long = &H2

Private Type LUID
LowPart As Long
HighPart As Long
End Type

Private Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type

Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type

Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, ByRef TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, ByRef NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByRef PreviousState As TOKEN_PRIVILEGES, ByRef ReturnLength As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Public Sub GetSeDebugPrivelege()
LoadPrivilege SE_DEBUG_NAME
End Sub

Public Function LoadPrivilege(ByVal Privilege As String) As Boolean
On Error GoTo ErrHandler

Dim hToken&, SEDebugNameValue As LUID, tkp As TOKEN_PRIVILEGES, hProcessHandle&, tkpNewButIgnored As TOKEN_PRIVILEGES, lBuffer&

hProcessHandle = GetCurrentProcess()
OpenProcessToken hProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), hToken
LookupPrivilegeValue "", Privilege, SEDebugNameValue

With tkp
.PrivilegeCount = 1
.TheLuid = SEDebugNameValue
.Attributes = SE_PRIVILEGE_ENABLED
End With

AdjustTokenPrivileges hToken, False, tkp, Len(tkp), tkpNewButIgnored, lBuffer
LoadPrivilege = True

Exit Function
ErrHandler:
MsgBox "An error occurred retrieving SE_DEBUG_NAME prileges in the LoadPrivelege() function. Note: This program is running without debug priveleges, that may interfere with removing the infection.", vbCritical + vbOKOnly
Resume Next
End Function

- In the "modFiles" module, the code below:

Option Explicit

Public Function FileExists(sFile$) As Boolean
If Trim$(sFile) = vbNullString Then Exit Function

FileExists = IIf(Dir(sFile, vbArchive + vbHidden + vbReadOnly + vbSystem) <> vbNullString, True, False)
End Function

Public Function TrimNull$(sToTrim$)
If InStr(sToTrim, Chr(0)) > 0 Then
TrimNull = Left$(sToTrim, InStr(sToTrim, Chr(0)) - 1)
Else
TrimNull = sToTrim
End If
End Function

- In the "modInjection" module, the code below:

Option Explicit

Private Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Const INFINITE = &HFFFFFFFF

Private Const MEM_COMMIT = &H1000
Private Const MEM_RELEASE = &H8000
Private Const PAGE_READWRITE = &H4

Public Declare Function GetCurrentProcessId Lib "kernel32" () 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 OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) 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 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 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 Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long


Public Function InjectLibrary(lPID&, sLibrary$) As Long
Dim hProcess&, hThread&, lLinkToLibrary&, lSize&, hKernel&

If Not FileExists(sLibrary) Then
MsgBox "Archive doesn't exist!"
Exit Function
End If

If lPID = GetCurrentProcessId() Then
InjectLibrary = InjectIntoMe(sLibrary)

Exit Function
End If

hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, lPID)

If hProcess = 0 Then
MsgBox "hProcess returned NULL"
Exit Function
End If

lSize = LenB(StrConv(sLibrary, vbFromUnicode)) + 1
lLinkToLibrary = VirtualAllocEx(hProcess, 0&, lSize, MEM_COMMIT, PAGE_READWRITE)

If lLinkToLibrary = 0 Then
CloseHandle hProcess

MsgBox "lLinkToLibrary failed"
Exit Function
End If

If (WriteProcessMemory(hProcess, lLinkToLibrary, ByVal sLibrary, lSize, ByVal 0&) = 0) Then
CloseHandle hProcess
If lLinkToLibrary <> 0 Then VirtualFreeEx hProcess, lLinkToLibrary, 0, MEM_RELEASE

MsgBox "WriteProcessMemory failed"
Exit Function
End If

hKernel = GetProcAddress(GetModuleHandle("Kernel32"), "LoadLibraryA")

If hKernel = 0 Then
CloseHandle hProcess
If lLinkToLibrary <> 0 Then VirtualFreeEx hProcess, lLinkToLibrary, 0, MEM_RELEASE

MsgBox "hKernel returned NULL"
Exit Function
End If

hThread = CreateRemoteThread(hProcess, ByVal 0&, 0&, ByVal hKernel, lLinkToLibrary, 0, ByVal 0&)

If hThread = 0 Then
CloseHandle hKernel
CloseHandle hProcess
If lLinkToLibrary <> 0 Then VirtualFreeEx hProcess, lLinkToLibrary, 0, MEM_RELEASE

MsgBox "hThread returned NULL."
Exit Function
End If

WaitForSingleObject hThread, 2000

If lLinkToLibrary <> 0 Then VirtualFreeEx hProcess, lLinkToLibrary, 0, MEM_RELEASE

If hKernel <> 0 Then CloseHandle (hKernel)
If hThread <> 0 Then CloseHandle (hThread)
If hProcess <> 0 Then CloseHandle (hProcess)

InjectLibrary = 1
End Function

Private Function InjectIntoMe(sLibrary$) As Long
InjectIntoMe = LoadLibrary(sLibrary)
End Function

End of the tutorial. Have fun with your injector.
Cappie.