form2.frm

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

Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

    
Private Declare Function SetForegroundWindow Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long


Private Type NOTIFYICONDATA
      cbSize As Long
      Hwnd As Long
      uID As Long
      uFlags As Long
      uCallbackMessage As Long
      hIcon As Long
      szTip As String * 200
End Type



'====my Struct====================================

Private Type AppMsg
    title As String
    explain As String
    explain2 As String
    formname As String
    
End Type

'=========my Var
Dim WarHwnd As Long                                 'War3信息记录
Dim WarHandle As Long
Dim WarWin As Long
Dim WarVer As Long                                  '版本


Dim nfIconData As NOTIFYICONDATA                    '
Dim ClsMem1 As New Class1







Private Sub Command1_Click()                        '开始41a465: je=>jmp;41a309: je=>jmp
Dim strShow As String
Dim WarHandle As Long
Dim LngWriteAddr(0 To 1) As Long
Dim BytWriteData(0) As Byte
Dim BytWriteData2(0) As Byte


LngWriteAddr(0) = &H41A465                          '设置写入地址和数据
LngWriteAddr(1) = &H41A309
BytWriteData(0) = &HEB
BytWriteData2(0) = &HEB


WarHandle = ClsMem1.OpenHandleByWin("WarCraft III", strShow)
If WarHandle = 0 Then
Label1(1).Caption = strShow
Exit Sub
End If


If ClsMem1.WriteMem(WarHandle, LngWriteAddr(0), BytWriteData(), 0) = 0 _
Or ClsMem1.WriteMem(WarHandle, LngWriteAddr(1), BytWriteData2, 0) = 0 Then
Label1(1).Caption = "写入失败"
Exit Sub
End If



ClsMem1.CloseHandleP WarHandle
Timer1.Enabled = True

Label1(1).Caption = "ON"
Frame3.Caption = "ON"
Command1.Enabled = False
Command2.Enabled = True
End Sub

Private Sub Command2_Click()                        '恢复41a465: jmp=>je;41a309: jmp=>je
Dim strShow As String
Dim WarHandle As Long
Dim LngWriteAddr(0 To 1) As Long
Dim BytWriteData(0) As Byte
Dim BytWriteData2(0) As Byte


LngWriteAddr(0) = &H41A465                          '设置写入地址和数据
LngWriteAddr(1) = &H41A309
BytWriteData(0) = &H74
BytWriteData2(0) = &H74


WarHandle = ClsMem1.OpenHandleByWin("WarCraft III", strShow) '写入
If WarHandle = 0 Then
Label1(1).Caption = strShow
Exit Sub
End If


If ClsMem1.WriteMem(WarHandle, LngWriteAddr(0), BytWriteData, 0) = 0 _
Or ClsMem1.WriteMem(WarHandle, LngWriteAddr(1), BytWriteData2, 0) = 0 Then
Label1(1).Caption = "写入失败"
Exit Sub
End If


ClsMem1.CloseHandleP WarHandle
Timer1.Enabled = False

Label1(1).Caption = "OFF"                              '恢复完毕
Frame3.Caption = "OFF"
Command1.Enabled = True
Command2.Enabled = False


End Sub

Private Sub Form_Load()
Dim MyApp As AppMsg

MyApp.title = "FakePlayer1.20a1(t3)"                   '程序信息:名称,说明等
MyApp.formname = MyApp.title
MyApp.explain = vbCrLf & Space(4) & "说明:" & vbCrLf & _
Space(9) & "用虚假的玩家加满你不喜欢的主机:" & vbCrLf & vbCrLf & _
Space(9) & "<1>运行游戏后打开外挂并点开始;" & vbCrLf & _
Space(9) & "<2>在加入游戏界面双击主机加入;" & vbCrLf & _
Space(9) & "<3>显示无法加入,但主机人数增加." & vbCrLf & vbCrLf & _
Space(5) & "版本:" & vbCrLf & _
Space(9) & "各平台,1.20a-e"
                                                      '详细说明
MyApp.explain2 = vbCrLf & _
Space(4) & "注  :" & vbCrLf & _
Space(9) & "点开始后无法加入主机,若要进行游戏请先恢复;" & vbCrLf & vbCrLf & _
Space(9) & "Fake期间不能关闭外挂,否则可能出现连续无法加入主机;" & vbCrLf & vbCrLf & _
Space(9) & "若出现连续无法加入主机则需重启魔兽." & vbCrLf & _
Space(9) & ""



ClsMem1.LookUp (0)                                 '提升权限,0表示自己
App.title = MyApp.title

Form1.Caption = MyApp.formname                      '初试化界面文字
Label1(1).Caption = "游戏Hack论坛:http://css.a.lunqun.com"
Label3(0).Caption = MyApp.explain2
'Label3(1).Caption = "游戏Hack论坛:http://css.a.lunqun.com"
Label3(2).Caption = MyApp.title
Label3(3).Caption = MyApp.explain                  '详细说明


With nfIconData                                    '加入托盘
        .Hwnd = Form1.Hwnd
        .uID = Form1.Icon
        .uFlags = &H2 Or &H1 Or &H4
        .uCallbackMessage = &H200
        .hIcon = Form1.Icon.Handle
        '定义鼠标移动到托盘上时显示的Tip
        .szTip = MyApp.title & vbNullChar
        .cbSize = Len(nfIconData)
End With
Call Shell_NotifyIcon(&H0, nfIconData)


End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lMsg As Single                                  '点击托盘显示窗体
lMsg = X / Screen.TwipsPerPixelX
Select Case lMsg
    
    Case &H201                                      '左键Down
       Form1.Show
       'Form1.WindowState = 0
       SetForegroundWindow Form1.Hwnd
       
End Select

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call Shell_NotifyIcon(&H2, nfIconData)              '去掉托盘

End Sub


Private Sub Form_Resize()                           '最小化隐藏
If Form1.WindowState = 1 Then
    Form1.Visible = False
End If
End Sub

Private Sub Label1_Click(Index As Integer)          '退出说明
Frame1.Visible = True
End Sub

Private Sub Label2_Click(Index As Integer)          '最小化和关闭按钮,说明按钮
Select Case Index
    Case 0
    Form1.Hide
    Case 1                                          '退出
    Unload Me
    
    Case 3                                          '说明
    If Frame1.Visible = True Then
    Frame1.Visible = False
    Else
    Frame1.Visible = True
    End If
    
End Select
End Sub

Private Sub Label2_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Index = 2 Then                                   '拖动窗体
ClsMem1.MoveForm Form1.Hwnd
End If
End Sub


Private Sub Option1_Click(Index As Integer)         '版本
WarVer = Index
End Sub

Private Sub Timer1_Timer()                          '定时关闭6112连接
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


'MsgBox tcpt.dwNumEntries - 1
End Sub