给初学者：用VB写外挂 ———— 实战四：雷电3修改器

本文链接：https://blog.youkuaiyun.com/zcsor/article/details/1320375

代码如下：

窗体：

'请保留作者信息：
'ZCSOR于06-10-4开发
'E-MAIL:shaoyan5@163.com

Option Explicit

Private Sub Form_Load()
SetLogo 101
'初始化要写入的数据
Call SetIlu: SetDi: SetNsr: SetIsk: SetIap

ToKen

'开始热键获取
SetTimer Me.hwnd, 0, 1, AddressOf TimerProc

LabMSG.Caption = "F5 ：增加炸弹(全屏幕炸弹增加6枚)" & vbCrLf & _
                 "F6 ：增加得分(将得分增加到最多)" & vbCrLf & _
                 "F7 ：增加人数(增加重新开始机会)" & vbCrLf & _
                 "F8 ：修改记录(将最高记录修改到最大)" & vbCrLf & _
                 "F9 ：辅武开放(武器效果增强到最大)" & vbCrLf & _
                 "F10：锁定修改(每5秒重复一次所有修改项目)"
SetMsg
PicBBS.ToolTipText = "http://www.3q2008.com/bbs/sml_class.asp?id=78"
PicSoft.ToolTipText = "http://down.youkuaiyun.com/app/morefile.php?user=zcsor"
LogoPic.ToolTipText = "按左键打开Blog，按右键打开软件列表"
End Sub

Private Sub Form_Unload(Cancel As Integer)
'停止热键获取
KillTimer Me.hwnd, 0
' "爱翔广宇揽东日之傲骨梅花飞入梦境待晓时其清水芙蓉"

End Sub

Private Sub SetLogo(ByVal ResID As Long)
LogoPic.Picture = LoadResPicture(ResID, 0)
End Sub

Private Sub LogoPic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case Button
    Case 1
        Shell "Rundll32.exe url.dll, FileProtocolHandler http://blog.youkuaiyun.com/zcsor"
    Case 2
        Shell "Rundll32.exe url.dll, FileProtocolHandler http://down.youkuaiyun.com/app/morefile.php?user=zcsor"
    Case Else
        MsgBox "按左键打开Blog，按右键打开软件列表"
End Select
End Sub

Private Sub PicBBS_Click()
Shell "Rundll32.exe url.dll, FileProtocolHandler http://www.3q2008.com/bbs/sml_class.asp?id=78"
End Sub

Private Sub PicSoft_Click()
LogoPic_MouseUp 2, 0, 1, 1
End Sub

Private Sub TimerLock_Timer()
If mSetOver(10) Then
    Xiugai "F5"
    Xiugai "F6"
    Xiugai "F7"
    Xiugai "F8"
    Xiugai "F9"
End If
End Sub

模块1

'负责权限,内存读写
Option Explicit

'查找窗体写内存等
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId 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 ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SYNCHRONIZE = &H100000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF
Private Const PROCESS_VM_OPERATION = &H8&
Private Const PROCESS_VM_READ = &H10&
Private Const PROCESS_VM_WRITE = &H20&

'权限提升
Private Declare Function GetCurrentProcess Lib "kernel32" () 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, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long

Private Const TOKEN_ASSIGN_PRIMARY = &H1
Private Const TOKEN_DUPLICATE = (&H2)
Private Const TOKEN_IMPERSONATE = (&H4)
Private Const TOKEN_QUERY = (&H8)
Private Const TOKEN_QUERY_SOURCE = (&H10)
Private Const TOKEN_ADJUST_PRIVILEGES = (&H20)
Private Const TOKEN_ADJUST_GROUPS = (&H40)
Private Const TOKEN_ADJUST_DEFAULT = (&H80)
Private Const TOKEN_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or TOKEN_ASSIGN_PRIMARY Or _
TOKEN_DUPLICATE Or TOKEN_IMPERSONATE Or TOKEN_QUERY Or TOKEN_QUERY_SOURCE Or _
TOKEN_ADJUST_PRIVILEGES Or TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)
Private Const SE_PRIVILEGE_ENABLED = &H2
Private Const ANYSIZE_ARRAY = 1

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
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type

Private GamePid As Long ' 储存进程标识符( Process Id )
Private msgStr(1 To 10) As String
'提升权限为高
Public Function ToKen() As Boolean
Dim hdlProcessHandle As Long
Dim hdlTokenHandle As Long
Dim tmpLuid As LUID
Dim tkp As TOKEN_PRIVILEGES
Dim tkpNewButIgnored As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long
Dim lp As Long
hdlProcessHandle = GetCurrentProcess()
lp = OpenProcessToken(hdlProcessHandle, TOKEN_ALL_ACCESS, hdlTokenHandle)
lp = LookupPrivilegeValue("", "SeDebugPrivilege", tmpLuid)
tkp.PrivilegeCount = 1
tkp.Privileges(0).pLuid = tmpLuid
tkp.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
lp = AdjustTokenPrivileges(hdlTokenHandle, False, tkp, Len(tkpNewButIgnored), tkpNewButIgnored, lBufferNeeded)
ToKen = lp
End Function

'获取内存内容,本函数返回值为当前该地址数值（10进制）
'Public Function GetData(ByVal lppid As Long, ByVal lpADDress As Long, Optional ByVal dtLen As Long = 4) As Long
'Dim pHandle As Long ' 储存进程句柄
' 使用进程标识符取得进程句柄
'pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, lppid)
' 在内存地址中读取数据
'ReadProcessMemory pHandle, ByVal lpADDress, ByVal VarPtr(GetData), dtLen, 0&
' 关闭进程句柄
'CloseHandle pHandle
'End Function

'获取内存内容，该函数在调用时将SaveData()作为参数传入，函数无返回值，调用后SaveData()内容即为当前地址内容（BYTE数组）
Public Function GetData(ByVal lppid As Long, ByVal lpAddress As Long, SaveData() As Byte, Optional ByVal dtLen As Long = 4)
Dim pHandle As Long ' 储存进程句柄
' 使用进程标识符取得进程句柄
pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, lppid)
' 在内存地址中读取数据
ReadProcessMemory pHandle, ByVal lpAddress, ByVal VarPtr(SaveData(0)), dtLen, 0&
' 关闭进程句柄
CloseHandle pHandle
End Function

'将修改内存
Public Function SetData(ByVal lppid As Long, ByVal lpDestAddr As Long, lpSrcAddr() As Byte, Optional ByVal dtLen As Long = 4) As Boolean
On Error GoTo mErr
Dim lBytesReadWrite As Long
Dim pHandle As Long ' 储存进程句柄
' 使用进程标识符取得进程句柄
pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, lppid)
WriteProcessMemory pHandle, ByVal lpDestAddr, ByVal VarPtr(lpSrcAddr(0)), dtLen, 0&
' 关闭进程句柄
CloseHandle pHandle
SetData = True
mErr:
End Function

Public Function GetPid(lpClassName As String, lpWindowName As String) As Long
' 取得进程标识符
GetWindowThreadProcessId FindWindow(lpClassName, lpWindowName), GetPid
End Function

Public Sub Xiugai(ByVal Fx As String)

On Error GoTo m_Err

Dim msgStr As String '临时字符,标志是修改还是恢复

GamePid = GetPid("JJ9WIN", vbNullString) '获取游戏进程PID

If GamePid = 0 Then
Form1!Label4.Caption = "请先启动游戏！"
Exit Sub
End If
If mGetOver = False Then Get_B '若没有备份原来的内存数据则备份它

'根据参数进行相应的写内存操作
Select Case Fx
    '*******************************************************
    'F5
    '*******************************************************
    Case "F5"
        If mSetOver(5) Then
            SetData GamePid, &H61BE04, Ilu_B(), 1
            msgStr = "恢复"
        Else
            SetData GamePid, &H61BE04, Ilu(), 1
            msgStr = "修改"
        End If
        mSetOver(5) = Not mSetOver(5)
    '*******************************************************
    'F6
    '*******************************************************
    Case "F6"
        If mSetOver(6) Then
            SetData GamePid, &H61BD9C, Di_B(), 4
            msgStr = "恢复"
        Else
            SetData GamePid, &H61BD9C, Di(), 4
            msgStr = "修改"
        End If
        mSetOver(6) = Not mSetOver(6)
    '*******************************************************
    'F7
    '*******************************************************
    Case "F7"
        If mSetOver(7) Then
            SetData GamePid, &H61BDA0, Nsr_B(), 1
            msgStr = "恢复"
        Else
            SetData GamePid, &H61BDA0, Nsr(), 1
            msgStr = "修改"
        End If
        mSetOver(7) = Not mSetOver(7)
    '*******************************************************
    'F8
    '*******************************************************
    Case "F8"
        If mSetOver(8) Then
            SetData GamePid, &H61BDB8, Isk_B(), 1
            msgStr = "恢复"
        Else
            SetData GamePid, &H61BDB8, Isk(), 1
            msgStr = "修改"
        End If
        mSetOver(8) = Not mSetOver(8)
    '*******************************************************
    'F4属性
    '*******************************************************
    Case "F9"
        If mSetOver(9) Then
            SetData GamePid, &H61BDAC, Iap_B(), 1
            msgStr = "恢复"
        Else
            SetData GamePid, &H61BDAC, Iap(), 1
            msgStr = "修改"
        End If
        mSetOver(9) = Not mSetOver(9)
    Case "F10"
        mSetOver(10) = Not mSetOver(10)
End Select
SetMsg
Form1!Label4.Caption = Fx & msgStr & "成功！"   '显示修改/恢复项目是否成功

Exit Sub
m_Err:
Form1!Label4.Caption = Fx & "修改失败啦！"
MsgBox Err.Description
End Sub

'将游戏中将被修改的原始数据读回保存
Public Sub Get_B()
GetData GamePid, &H61BE04, Ilu_B(), 1

GetData GamePid, &H61BD9C, Di_B(), 4

GetData GamePid, &H61BDA0, Nsr_B(), 1

GetData GamePid, &H61BDB8, Isk_B(), 1

GetData GamePid, &H61BDAC, Iap_B(), 1

mGetOver = True '修改备份标志
End Sub

Public Sub SetMsg()     '修改是否修改信息
Dim i As Long
Form1!LabF.Caption = ""
For i = 5 To 10
    If mSetOver(i) Then msgStr(i) = "ON" & vbCrLf Else msgStr(i) = "OFF" & vbCrLf
    Form1!LabF.Caption = Form1!LabF.Caption & msgStr(i)
Next i

End Sub

模块2

'负责热键的定义和获取,结束的函数在FORM1的UNLOAD过程
Option Explicit

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Global Cnt As Long, Ret As Long
'获取按下的是哪个键
Function GetPressedKey() As Long
    For Cnt = 116 To 120 '112-121 为 F1-F10
        If GetAsyncKeyState(Cnt) <> 0 Then
            GetPressedKey = Cnt
            If Ret = Cnt Then Exit Function '如果按下的键重复,表示一次按键还没有结束,不重复进行修改
            Select Case Cnt
                Case 116
                    Xiugai "F5"
                Case 117
                    Xiugai "F6"
                Case 118
                    Xiugai "F7"
                Case 119
                    Xiugai "F8"
                Case 120
                    Xiugai "F9"
                Case Else
            End Select
            Exit For
        End If
    Next Cnt
End Function
'回调
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    Ret = GetPressedKey
End Sub

模块3

'负责数据定义
Option Explicit

'写入数据,及备份原来数据
Public Ilu(0) As Byte
Public Ilu_B(0) As Byte

Public Di(3) As Byte
Public Di_B(3) As Byte

Public Nsr(0) As Byte
Public Nsr_B(0) As Byte

Public Isk(0) As Byte
Public Isk_B(0) As Byte

Public Iap(0) As Byte
Public Iap_B(0) As Byte

Public mSetOver(5 To 10) As Boolean '是否经过修改
Public mGetOver As Boolean '是否已经备份数据

Public Sub SetIlu()
Ilu(0) = &HF
End Sub

Public Sub SetDi()
Di(0) = &HF6: Di(1) = &HC9: Di(2) = &H9A: Di(3) = &H3B
End Sub

Public Sub SetNsr()
Nsr(0) = &HA
End Sub

Public Sub SetIsk()
Isk(0) = &H5
End Sub

Public Sub SetIap()
Iap(0) = &H5
End Sub

以上代码都是根据上一个修改器改的。没什么好说了，你运行的时候可能会不正常，如果不想自己修改，把以下部分另存为FORM1.FRM

VERSION 5.00
Begin VB.Form Form1
   AutoRedraw      =   -1 'True
   BorderStyle     =   3 'Fixed Dialog
   Caption         =   "ZCSOR修改器系列:雷电Ⅲ修改器"
   ClientHeight    =   1935
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4560
   LinkTopic       =   "泰坦之旅v1.08十项属性修改器"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1935
   ScaleWidth      =   4560
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2 '屏幕中心
   Begin VB.Timer TimerLock
      Interval        =   5000
      Left            =   1680
      Top             =   1200
   End
   Begin VB.Frame Frame3
      Height          =   540
      Left            =   2890
      TabIndex        =   8
      Top             =   -80
      Width           =   1680
      Begin VB.PictureBox PicSoft
         Appearance      =   0 'Flat
         BackColor       =   &H80000005&
         BorderStyle     =   0 'None
         ForeColor       =   &H80000008&
         Height          =   375
         Left            =   30
         MousePointer    =   14 'Arrow and Question
         Picture         =   "Form1.frx":0000
         ScaleHeight     =   375
         ScaleWidth      =   1605
         TabIndex        =   9
         Top             =   120
         Width           =   1605
      End
   End
   Begin VB.Frame Frame2
      Height          =   540
      Left            =   0
      TabIndex        =   6
      Top             =   -80
      Width           =   1680
      Begin VB.PictureBox PicBBS
         Appearance      =   0 'Flat
         BackColor       =   &H80000005&
         BorderStyle     =   0 'None
         ForeColor       =   &H80000008&
         Height          =   375
         Left            =   30
         MousePointer    =   14 'Arrow and Question
         Picture         =   "Form1.frx":2572
         ScaleHeight     =   375
         ScaleWidth      =   1605
         TabIndex        =   7
         Top             =   120
         Width           =   1605
      End
   End
   Begin VB.Frame Frame6
      Height          =   540
      Left            =   1680
      TabIndex        =   4
      Top             =   -80
      Width           =   1215
      Begin VB.PictureBox LogoPic
         Appearance      =   0 'Flat
         BorderStyle     =   0 'None
         ForeColor       =   &H80000008&
         Height          =   375
         Left            =   30
         MouseIcon       =   "Form1.frx":47D4
         MousePointer    =   99 'Custom
         ScaleHeight     =   375
         ScaleWidth      =   1140
         TabIndex        =   5
         Top             =   120
         Width           =   1140
      End
   End
   Begin VB.Frame Frame1
      Height          =   375
      Left            =   0
      TabIndex        =   1
      Top             =   1560
      Width           =   4575
      Begin VB.Label Label4
         Caption         =   "启动成功.注意:修改成功无提示;按下第2次撤消修改!"
         Height          =   195
         Left            =   120
         TabIndex        =   2
         Top             =   135
         Width           =   4305
      End
   End
   Begin VB.Label LabF
      ForeColor       =   &H00FF0000&
      Height          =   1095
      Left            =   105
      TabIndex        =   3
      Top             =   480
      Width           =   255
   End
   Begin VB.Label LabMSG
      Height          =   1095
      Left            =   480
      TabIndex        =   0
      Top             =   480
      Width           =   3975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'请保留作者信息：
'ZCSOR于06-10-4开发
'E-MAIL:shaoyan5@163.com