classmem.cls

VB编的一个war3防秒退程序 内附使用说明

For i = 0 To LenAsc
byteSave(i) = CByte("&H" & strMid(i))
'MsgBox Hex(byteSave(i))
Next
'Print i


End Sub


Sub CloseSockets()

Dim i As Long

Dim Rema As Long
Dim Loca As Long

Dim tcpt As MIB_TCPTABLE


GetTcpTable tcpt, Len(tcpt), 0
For i = 0 To tcpt.dwNumEntries - 1
Rema = tcpt.table(i).dwRemoteAddr
Loca = tcpt.table(i).dwLocalAddr
'Remp = ntohs(tcpt.table(i).dwRemotePort)
'locp = ntohs(tcpt.table(i).dwLocalPort)
If Rema = Loca And tcpt.table(i).dwState = 5 Then   '一般remote IP和local IP相同就是HF
tcpt.table(i).dwState = 12
SetTcpEntry tcpt.table(i)

End If
Next
End Sub

Function ReadProcessMemt(ByVal hProcess As Long, ByVal lpBaseAddress As Long, _
ByRef lpBuffer As Long, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
ReadProcessMemt = ReadProcessMem(hProcess, lpBaseAddress, lpBuffer, nSize, lpNumberOfBytesWritten)

End Function

Function ReadProcessMeml(ByVal hProcess As Long, ByVal lpBaseAddress As Long, _
ByRef lpBuffer As Long, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
ReadProcessMeml = ReadProcessMem(hProcess, lpBaseAddress, lpBuffer, nSize, lpNumberOfBytesWritten)

End Function






Function EnumProcess(ByRef out_ProcessIds() As Long, ByRef out_ProcessPath() As String) As Long
Dim cb As Long
Dim cbNeeded As Long
Dim l_NumProcess As Long

cb = 8
cbNeeded = 96

EnumProcess = 0
'{{{取得所有的进程数和ID
Do While cb <= cbNeeded
cb = cb * 2
'在以下这句中，《Hardcore Visual Basic》一书写成ReDim aProcesses(0 To (cRequest
'/ 4) - 1) As Long，不明白他为什么要这么写？我最初的调试不成功，后来把减1
'去掉后就成功了^^
     ReDim ProcessIDs(cb / 4) As Long
     Call EnumProcesses(out_ProcessIds(0), cb, cbNeeded)
Loop
l_NumProcess = cbNeeded / 4          '进程数目
'}}}



'{{{
Dim l_hProcess As Long
Dim lRet As Long, i As Long, l_Modules(0 To 250) As Long
For i = 0 To l_NumProcess
'取得一个进程的句柄
'使用OpenProcess函数打开句柄，其中的两个常量在winnt.h中可以找到相应的声明。
  l_hProcess = OpenProcess(PROCESS_QUERY_INFORMATION _
Or PROCESS_VM_READ, 0, ProcessIDs(i))

   '如果句柄有效，则
If l_hProcess <> 0 Then
        lRet = EnumProcessModules(out_ProcessIds(i), l_Modules(0), 255, cbNeeded)
If lRet <> 0 Then
   out_ProcessPath(i) = Space(255)
    lRet = GetModuleFileNameExA(out_ProcessIds(i), l_Modules(0), out_ProcessPath(i), 255)
End If
End If

   lRet = CloseHandle(out_ProcessIds(i))
Next
 '}}}
 
 
EnumProcess = l_NumProcess              '返回进程数
End Function




Function EnumModulebyHandle(ByVal in_PId As Long, ByRef out_ModuleIDs() As Long, ByRef out_ModulePath() As String _
, ByRef out_DllAddr() As Long) As Long
Dim i As Long
Dim l_moduleName As String
Dim l_numModule As Long

   '如果句柄有效，则
EnumModulebyHandle = 0

If in_PId = 0 Then
Debug.Print "传入的进程PID=0"
Exit Function
End If
Debug.Print "传入的进程PID=" & in_PId

'=============枚举模块名称start
    Dim l_stuProcess As MODULEENTRY32
    Dim n As Long
    Dim l_hSnapShot As Long
    l_hSnapShot = CreateToolhelp32Snapshot(8, in_PId)
    l_stuProcess.dwSize = Len(l_stuProcess)
    n = Module32First(l_hSnapShot, l_stuProcess)
    Do While n > 0
        out_ModuleIDs(l_numModule) = l_stuProcess.th32ModuleID         '获得ID
        out_ModulePath(l_numModule) = Left(l_stuProcess.szModule, InStr(l_stuProcess.szModule, Chr(0)) - 1) '获得名称
        out_DllAddr(l_numModule) = l_stuProcess.hModule          '获得地址
        n = Module32Next(l_hSnapShot, l_stuProcess)
        Debug.Print "ID:" & Hex(out_ModuleIDs(l_numModule)), "名称:" & out_ModulePath(l_numModule), Hex(out_DllAddr(l_numModule))
        l_numModule = l_numModule + 1                                '计算数量
    Loop
'=============枚举end


EnumModulebyHandle = l_numModule - 1
End Function



Function GetModuleAddr(ByVal Phandle As Long, ByVal Dllhandle As Long, ByRef out_DllAddr As Long _
, ByRef out_DllImgSize As Long, ByRef out_DllEntry As Long) As Long
Dim cb As Long
Dim l_Dllinfo As LPMODULEINFO

GetModuleAddr = GetModuleInformation(Phandle, Dllhandle, l_Dllinfo, 255)

out_DllAddr = l_Dllinfo.lpBaseOfDll
out_DllImgSize = l_Dllinfo.SizeOfImage
out_DllEntry = l_Dllinfo.EntryPoint
End Function


Function WriteMemL(ByVal Phandle As Long, ByVal AddrToWrite As Long, ByVal DataToWrite As Long)
WriteMemL = WriteProcessMemory(Phandle, AddrToWrite, DataToWrite, 4, 0)
End Function


Function CreateRemoteThreadVB(ByVal hProcess As Long, ByVal lpThreadAttributes As Long, dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
CreateRemoteThreadVB = CreateRemoteThread(hProcess, ByVal lpThreadAttributes, dwStackSize, ByVal lpStartAddress, ByVal lpParameter, ByVal dwCreationFlags, lpThreadId)

End Function
 
 
Function VirtualProtectEx2(ByVal hProcess As Long, lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
VirtualProtectEx2 = VirtualProtectEx(ByVal hProcess, lpAddress, ByVal dwSize, ByVal flNewProtect, lpflOldProtect)
End Function


Function VirtualAllocEx2(ByVal hProcess As Long, lpAddress As Long, ByRef dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
VirtualAllocEx2 = VirtualAllocEx(hProcess, ByVal 0&, dwSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE)

End Function

Function VirtualFreeEx2(ByVal hProcess As Long, lpAddress As Long, ByRef dwSize As Long) As Long
VirtualFreeEx2 = VirtualFreeEx(hProcess, lpAddress, dwSize, MEM_RELEASE)
End Function

Sub Wait(ByVal mWaitTime As Single)                 '延时,毫秒
If mWaitTime <= 0 Then                              '进入参数为0则不等待
Exit Sub
End If

Dim start As Single
start = Timer
mWaitTime = mWaitTime / 1000
Do While start + mWaitTime > Timer
Sleep 10
DoEvents
Loop
End Sub


   
Function GetSpecialfolder(CSIDL As Long) As String
          Dim r     As Long
          Dim IDL     As ITEMIDLIST
          'Get   the   special   folder
          Dim path     As String
          r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
          If r = NO_ERROR Then
                  'Create   a   buffer
                  path = Space$(512)
                  'Get   the   path   from   the   IDList
                  r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal path$)
                  'Remove   the   unnecessary   chr$(0)'s
                  GetSpecialfolder = Left$(path, InStr(path, Chr$(0)) - 1)
                  Exit Function
          End If
          GetSpecialfolder = ""
  End Function
   
Sub KillCookie()
On Error Resume Next
          Dim CookiesPath     As String
          CookiesPath = GetSpecialfolder(CSIDL_COOKIES)       '获取COOKIES文件夹路径
          '为了防止在ie打开时，内存中还有部分COOKIES存在，加了下面这句
          Call InternetSetOption(0, INTERNET_OPTION_END_BROWSER_SESSION, ByVal 0&, 0)
          Kill CookiesPath + "\*.txt"         '全部删除，如果需要删除某一个COOKIES的话，需要用dir或fso枚举出所有文件，然后用kill语句删除
End Sub


Function HexToBin(ByVal in_strHex As String, ByRef out_StrBin As String, ByVal in_lenHex As Long) As Long
Dim i As Long
Dim l_byte As Byte
Dim l_strIn As String
Dim l_str1byte As String

in_lenHex = in_lenHex * 2
For i = 1 To in_lenHex - Len(in_strHex)                 '把字符串少了的字节用0填充
in_strHex = "0" & in_strHex
Next
out_StrBin = ""

For i = 1 To Len(in_strHex)
l_byte = CByte("&h" & Mid(in_strHex, i, 1))
Select Case l_byte
Case 0
l_str1byte = "0000"
Case 1
l_str1byte = "0001"
Case 2
l_str1byte = "0010"
Case 3
l_str1byte = "0011"
Case 4
l_str1byte = "0100"
Case 5
l_str1byte = "0101"
Case 6
l_str1byte = "0110"
Case 7
l_str1byte = "0111"
Case 8
l_str1byte = "1000"
Case 9
l_str1byte = "1001"
Case 10
l_str1byte = "1010"
Case 11
l_str1byte = "1011"
Case 12
l_str1byte = "1100"
Case 13
l_str1byte = "1101"
Case 14
l_str1byte = "1110"
Case 15
l_str1byte = "1111"
End Select

out_StrBin = out_StrBin & l_str1byte
Next

HexToBin = Len(out_StrBin)                                          'BIN的长度
End Function
Function BinToHex(ByVal in_strBin As String, ByRef out_strHex As String) As Long 'len(传入参数)必须是4的倍数
Dim i As Long
Dim l_1byte As Byte
Dim l_bit(1 To 256)  As Long

out_strHex = ""
If Len(in_strBin) Mod 4 <> 0 Then
Exit Function
End If

For i = 1 To Len(in_strBin)                         '先将bin字符串的每一位转成数字
l_bit(i) = CByte("&h" & Mid(in_strBin, i, 1))
'Debug.Print l_bit(i)
Next

For i = 1 To Len(in_strBin)
l_1byte = l_bit(i) * 2 ^ 3 + l_bit(i + 1) * 2 ^ 2 + l_bit(i + 2) * 2 + l_bit(i + 3)
out_strHex = out_strHex & Hex(l_1byte)
i = i + 3                                           'i只能加3,因为FOR会自动把i+1
Next
BinToHex = Len(in_strBin) / 4

End Function


Sub antiDBG()
End Sub



Sub WriteAndSend(ByVal l_Phandle As Long, ByVal l_strAllWrite As String, ByVal l_addrWrite As Long, ByVal l_addrCThread As Long)
Dim l_byteToWrite() As Byte, i As Long, l_lngUnicode As Long
Dim l_intHeight As Integer
Dim l_intLow As Integer
Dim l_lngNumWords As Long
ReDim l_byteToWrite(0 To LenB(l_strAllWrite))              '写入WAR3

l_lngNumWords = 0
For i = 0 To Len(l_strAllWrite) - 1
If Asc(Mid(l_strAllWrite, i + 1, 2)) > 0 Then
l_byteToWrite(i + l_lngNumWords) = Asc(Mid(l_strAllWrite, i + 1, 1))

ElseIf Asc(Mid(l_strAllWrite, i + 1, 2)) < 0 Then
l_lngUnicode = Asc(Mid(l_strAllWrite, i + 1, 2)) + 65536  '汉字处理
l_intHeight = l_lngUnicode / 256 - 1
l_intLow = l_lngUnicode Mod 256
l_byteToWrite(i + l_lngNumWords) = CByte(l_intHeight)         'AscB(MidB(l_strAllWrite, i + 1, 1))
l_byteToWrite(i + l_lngNumWords + 1) = CByte(l_intLow)  'AscB(MidB(l_strAllWrite, i + 2, 1))
l_lngNumWords = l_lngNumWords + 1

ElseIf Asc(Mid(l_strAllWrite, i + 1, 2)) = 0 Then
Exit For
End If
Next
l_byteToWrite(i + l_lngNumWords) = &H0                                  '字符串以0结尾

Call WriteMem(l_Phandle, l_addrWrite, l_byteToWrite, 0)   '写入

If l_addrCThread <> 0 Then
Call CreateRemoteThreadVB(l_Phandle, 0&, 0, l_addrCThread, 0&, 0&, 0&) '&h11234 createthread it
End If
End Sub


Sub SetWindowTop(ByVal in_Hwnd As Long, ByVal in_TopOrNot As Long)
Dim l_lngrtn  As Long
If in_TopOrNot = 1 Then
'让窗口在顶层
l_lngrtn = SetWindowPos(in_Hwnd, -1, 0, 0, 0, 0, 3)
ElseIf in_TopOrNot = 0 Then
'取消窗口在顶层
l_lngrtn = SetWindowPos(in_Hwnd, -2, 0, 0, 0, 0, 3)
End If
End Sub

Function GetPidbyWindow(ByVal in_Hwnd As Long) As Long
Call GetWindowThreadProcessId(in_Hwnd, GetPidbyWindow)
End Function


Function Cls_TerminateProcess(ByVal in_Phandle As Long)
Cls_TerminateProcess = TerminateProcess(in_Phandle, 1)
End Function