[開源] 新楓之谷洋蔥(OpenSource MSOnion for NewBF)
楓之谷洋蔥是我目前堅持過最久的一個 Project,從我開始學習寫程式到現在...
現在來實現之前說過的開源吧~
裡面也沒有什麼特別的東西,不過是一段學習的歷程而已 =w=
半夜偷偷發,大大請無視,大牛請繞過,神馬請漂走...
版本演進:
當然過程中大大小小也改了無數、發佈了無數的版本,只不過這幾個是我部落格有紀錄的版本而已...
其實當初在寫的時候就有想過哪一天一定會發出來,所以很多地方都有加註解,不過時間拖得久了,很多地方就亂了...
其實裡面模組很多都是開源的網路上找的到喔 (笑
Form1.frm:主程式,帳密儲存、樂豆登入、遊戲啟動、遊戲登入、功能寫入、驅動調用、後台按鍵、指標讀取等等。
clsHack.cls:原創作者 Inndy,此為修改版,加入 Je、Jne 函數,刪除 DLLInject 函數(當初是為了改善誤判)
modPst.bas:我也不大清楚這是誰源創的,已經流傳很久的後台腳本... 有加入一些 KeyCode...
Module1.bas:一些雜亂的副程式、函數:加密法、按鍵判斷、Ini 設定檔讀寫...
歡迎有需要者拿去參考,可是不要名字改一改拿去賣之類的喔 XD
現在來實現之前說過的開源吧~
裡面也沒有什麼特別的東西,不過是一段學習的歷程而已 =w=
半夜偷偷發,大大請無視,大牛請繞過,神馬請漂走...
版本演進:
- 從練習調用 AutoAsm 的數據執行工具(由於論壇資料遺失,已不可朔..)
- 後來把當時有的東西全部拼湊起來的版本(楓之谷洋蔥 2.1)
- 慢慢看得懂程式碼會用比較多元件整理後的版本(楓之谷洋蔥 v2.1.0.56)
- 在經過大大施捨的部分登入用程式碼之後終於學起來的版本(楓之谷洋蔥4.1.2)
- 過了半年全部重寫,正值樂逗改版的版本(NewMSOnion Alpha)
- 趨於穩定的版本,持續修正、更新,並加入自動更新器,目前的版本(新楓之谷洋蔥)
當然過程中大大小小也改了無數、發佈了無數的版本,只不過這幾個是我部落格有紀錄的版本而已...
其實當初在寫的時候就有想過哪一天一定會發出來,所以很多地方都有加註解,不過時間拖得久了,很多地方就亂了...
其實裡面模組很多都是開源的網路上找的到喔 (笑
Form1.frm:主程式,帳密儲存、樂豆登入、遊戲啟動、遊戲登入、功能寫入、驅動調用、後台按鍵、指標讀取等等。
Option Explicit Private Declare Function CEAutoAsm Lib "CEAutoAssembler.dll" (ByVal script As String, ByVal AllocID As Boolean, Alloc As Integer) As Boolean Private Declare Function CEInitialize Lib "CEAutoAssembler.dll" (ByVal ngPassedPID As Long, ByVal Phandle As Long) As Integer Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long Private Declare Function GetForegroundWindow Lib "user32" () As Long Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim Hp As Long, Mp As Long, Monster As Integer, RedPoint As Integer, Breath As Integer Dim tBot1 As Integer, tBot2 As Integer, tBot3 As Integer, tBot4 As Integer, tBot5 As Integer, tBot6 As Integer, tAtkDown As Integer, tCh As Integer, TimeCheck As Single Dim SystemBaseAdr As Long, MpAlarmBaseAdr As Long, MpAlarmOffest As Long, HpValueBaseAdr As Long, HpValueOffest As Long, ChrBaseAdr As Long, ChrBreathOffest As Long, RedBaseAdr As Long, MonBaseAdr As Long Dim AutoLRICSEntry As Long, AutoLRICSCallRet As Long, AutoLRJne As Long, GetFocus As Long, WPMAutoLR As Boolean, AutoLRICS As Long, AutoLRValue As Long Dim IntersectRect As Long, FullMapICS As Long Dim IsRectEmpty As Long, PhysicalGodICS As Long Dim mCount As Date, mCountEnd As Date Dim LoadScript As String Dim MSBlack As Boolean, MultiON As Boolean, ReRun As Boolean Dim HACK As New clsHack '========== 遊戲連結 ========== Private Sub AttachGame_Click() HACK.Pid = 0: HACK.Handle = 0: HACK.hWnd = 0: HACK.Inited = False If HACK.OpenProcessByWindow(vbNullString, "MapleStoryClass") Then Call AttachInitialize Call SetForegroundWindow(HACK.hWnd) Call SetWindowPos(HACK.hWnd, -2, 0, 5, 0, 0, &H1) ElseIf HACK.OpenProcessByWindow("MapleStory", "StartUpDlgClass") Then Call AttachInitialize Else Me.Caption = "楓之谷洋蔥" Call MsgBox("Game Not Found", vbCritical, "Faild") End If End Sub Private Sub AttachInitialize() Me.Caption = "MSOnion - " & HACK.Pid Call HACK.WritePointer(MpAlarmBaseAdr, MpAlarmOffest - 4, &H20): Call HACK.WritePointer(MpAlarmBaseAdr, MpAlarmOffest, &H20) Call ICSAdrInitialize Call ReAutoASM Call SetForegroundWindow(Me.hWnd) TmDCCheck.Enabled = CkDcCheck.value MSBlack = False: BlackMS.Caption = "脫機ON" End Sub Private Sub ICSAdrInitialize() IsRectEmpty = 0 AutoLRICSEntry = "&H" & ReadData("AutoLR", "ICSEntry") AutoLRICSCallRet = "&H" & ReadData("AutoLR", "CallRet") AutoLRJne = "&H" & ReadData("AutoLR", "Jne") WPMAutoLR = False IntersectRect = 0 If CkGod.value = 1 Then CkGod_Click If CkAutoLR.value = 1 Then CkAutoLR_Click If CkFullMap.value = 1 Then CkFullMap_Click End Sub Private Sub ReAutoASM() Dim i As Integer For i = 0 To lstScripts.ListCount - 1 If lstScripts.Selected(i) = True Then Call lstScripts_ItemCheck(i) Next End Sub Private Sub CheckPic_Click() Call GetImage End Sub Private Sub CheckUpdate_Click() On Error GoTo Er 'Call Shell("rundll32.exe url.dll,FileProtocolHandler http://knowlet3389.blogspot.tw/p/msonion.html", vbHide) Dim http As Object, verCheck As String, Ver() As String Set http = CreateObject("MSXML2.ServerXMLHTTP") http.Open "GET", "http://knowlet3389.blogspot.tw/p/msonion.html", False http.setRequestHeader "Pragma", "no-cache" http.send verCheck = http.responseBody verCheck = StrConv(verCheck, vbUnicode) verCheck = Split(Mid(verCheck, InStr(34780, verCheck, "Latest Ver."), 20), "<")(0) Ver = Split(verCheck, ".") Set http = Nothing If Ver(1) > App.Major Or Ver(2) > App.Minor Or Ver(3) > App.Revision Then Call MsgBox("Your Ver." & App.Major & "." & App.Minor & "." & App.Revision & " is out of date. Please Update to the latest version!", vbInformation, verCheck) _ : Call Shell("rundll32.exe url.dll,FileProtocolHandler http://knowlet3389.blogspot.tw/p/msonion.html", vbHide): End 'MsgBox "檔案版本:" & App.Major & "." & App.Minor & "." & App.Revision & vbCrLf & Ver, vbInformation, "目前版本" Exit Sub Er: Call MsgBox("This Application can't be used anymore!", vbCritical, "Error"): End End Sub Private Sub CkAutoStart_Click() If CkAutoStart.value = 1 And lstBFAccount.ListIndex = -1 Then CkAutoStart.value = 0: Call MsgBox("No Account Chosen!", vbCritical, "Error") End Sub Private Sub CloseGame_Click() On Error Resume Next Call HACK.CloseGame HACK.Pid = 0: HACK.Handle = 0: HACK.hWnd = 0: HACK.Inited = False End Sub '========== 選單功能 ========== Private Sub BlackMS_Click() If MSBlack = False Then Call ShowWindow(HACK.hWnd, 0) BlackMS.Caption = "脫機OFF" MSBlack = True Else Call ShowWindow(HACK.hWnd, 1) BlackMS.Caption = "脫機ON" MSBlack = False End If End Sub Private Sub DelScript_Click() On Error GoTo Er: If MsgBox("確認刪除" & lstScripts.List(lstScripts.ListIndex) & "?", 4 + 32, "確認") = vbYes Then Kill (App.Path & "\Scripts\" & lstScripts.List(lstScripts.ListIndex)) lstScripts.RemoveItem (lstScripts.ListIndex) End If Exit Sub Er: Call MsgBox(Err.Description, vbCritical, Err.Number) End Sub Private Sub GotoFolder_Click() Call Shell("rundll32.exe url.dll,FileProtocolHandler " & App.Path & "/Scripts", vbNormalFocus) End Sub Private Sub lstScripts_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) On Error GoTo Err If Len(Trim(Data.Files(1))) Then Dim s For Each s In Data.Files Dim fileName As String fileName = Mid(s, InStrRev(s, "\") + 1) If LCase(Right(fileName, 3)) = "txt" Then FileCopy s, App.Path & "\Scripts\" & fileName lstScripts.AddItem (fileName) End If Next Else: Exit Sub: End If Err: End Sub Private Sub WriteInPlay_Click() WriteInPlay.Checked = Not WriteInPlay.Checked End Sub Private Sub lstScripts_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button And vbRightButton Then PopupMenu Scripts End Sub Private Sub lxlX_Click() Frame5.Visible = False End Sub Private Sub CmdSaveScript_Click() If Len(txtSaveScript) = 0 Then Exit Sub Dim str() As String, fileName As String, i As Integer str = Split(txtSaveScript, Chr(13)) fileName = InputBox("請輸入檔名", "Name", Replace(str(0), "/", vbNullString)) If Len(fileName) = 0 Then Exit Sub If Not Right(fileName, 4) = ".txt" Then fileName = fileName & ".txt" Frame5.Visible = False For i = 0 To lstScripts.ListCount - 1 If fileName = lstScripts.List(i) Then If OverWrite(App.Path & "\Scripts\" & fileName, txtSaveScript) = True Then Exit Sub End If Next If OverWrite(App.Path & "\Scripts\" & fileName, txtSaveScript) Then lstScripts.AddItem (fileName) Exit Sub Er: Call MsgBox(Err.Description, vbCritical, Err.Number) End Sub Private Function OverWrite(lpFileName As String, strS As String) As Boolean Dim FileNum As Integer OverWrite = False On Error GoTo OWError If Len(Dir(lpFileName, vbArchive Or vbHidden Or vbNormal Or vbReadOnly)) > 0 Then Kill lpFileName FileNum = FreeFile Open lpFileName For Binary As FileNum Put FileNum, , strS & vbCrLf Close FileNum OverWrite = True Exit Function OWError: MsgBox "檔案操作失敗!" & vbCrLf & lpFileName, 16 End Function Private Sub MultiMS_Click() Dim CMD As String If MultiON = False Then Call MsgBox("本多開只支援x86系統,且無繞過HS多開檢測!" & vbCrLf & "如置於中文路徑下將可能多開啟動失敗!", vbInformation, "提示") 'Call CHLoadDriver(App.Path & "\MultiDriver.dll") CMD = "cmd.exe /c sc create NtUserCallOneParam binpath= " + App.Path + "\MultiDriver.dll type= kernel start= auto && cmd.exe /c sc start NtUserCallOneParam" Shell CMD, vbHide CMD = vbNullString MultiMS.Caption = "多開OFF" MultiON = True Else 'Call CHUnLoadDriver CMD = "cmd.exe /c sc stop NtUserCallOneParam && cmd.exe /c sc delete NtUserCallOneParam" Shell CMD, vbHide CMD = vbNullString MultiMS.Caption = "多開ON" MultiON = False End If End Sub Private Sub AddScript_Click() txtSaveScript = Chr(0) Frame5.Left = 0 Frame5.Visible = True Frame5.ZOrder End Sub Private Sub ReadScript_Click() Call Shell("Notepad.exe " & App.Path & "\Scripts\" & lstScripts.List(lstScripts.ListIndex), vbNormalFocus) End Sub Private Sub Reload_Click() Call LoadScripts End Sub Private Sub SetCloseGame_Click() On Error GoTo Er: Dim Hr As Integer, Mn As Integer Hr = InputBox("請輸入小時數", "關閉遊戲設置", 0) Mn = InputBox("請輸入分鐘數", "關閉遊戲設置", 1) mCountEnd = Now mCount = SetCount(Hr, Mn, 0) TmCloseGame.Enabled = True MsgBox "將於" & Hr & "小時" & Mn & "分後關閉遊戲", vbInformation, "遊戲關閉設定完成" Er: End Sub Private Sub SetClosGameA_Click() TmCloseGame.Enabled = False SetCloseGame.Caption = "定時關遊戲" End Sub Private Function SetCount(ByVal vHour As Long, ByVal vMinute As Long, vSecond As Long) As Date SetCount = mCountEnd + CDate(vHour & ":" & vMinute & ":" & vSecond) End Function Private Sub TmCloseGame_Timer() On Error GoTo Er: mCount = mCount - CDate("00:00:01") SetCloseGame.Caption = mCount If mCount < mCountEnd Then CkAutoStart.value = 0 HACK.CloseGame TmCloseGame.Enabled = 0 SetCloseGame.Caption = "定時關遊戲" End If Er: End Sub Private Sub ShutdownPC_Click() Dim SD_Time As String SD_Time = InputBox("請輸入分鐘數" & vbCrLf & "*如果輸入錯誤可能導致立刻關機", "自動關機", 60) Call Shell("cmd /c shutdown -s -t " & Val(SD_Time) * 60, vbHide) End Sub Private Sub ShutodownA_Click() Call Shell("cmd /c shutdown -a", vbHide) End Sub '========== 功能鉤子 ========== Private Sub CkAutoLR_Click() If WPMAutoLR = False Then GetFocus = HACK.ReadLong(AutoLRICSEntry) AutoLRICS = HACK.Alloc(128) AutoLRValue = HACK.Alloc(4) Call HACK.WriteAOBByString(AutoLRICS, "81 3C 24" & HACK.Address2Aob(AutoLRICSCallRet) & "00 75 07 C7 04 24" & HACK.Address2Aob((AutoLRICS + &H16)) & "68 34 3A BA 77 C3 50 FF 05" & HACK.Address2Aob(AutoLRValue) & "B8 0A 00 00 00 3B 05" & HACK.Address2Aob(AutoLRValue) & "7D 15 83 C0 0A 3B 05" & HACK.Address2Aob(AutoLRValue) & "7D 14 C7 05" & HACK.Address2Aob(AutoLRValue) & "01 00 00 00 C7 45 FC FF FF FF FF 58 EB 08 C7 45 FC 01 00 00 00 58 68" & HACK.Address2Aob(AutoLRJne) & "00 C3") WPMAutoLR = True End If If CkAutoLR.value = 1 Then Call HACK.WriteLong(AutoLRICSEntry, AutoLRICS) Else: Call HACK.WriteLong(AutoLRICSEntry, GetFocus) End Sub Private Sub CkFullMap_Click() IntersectRect = GetProcAddress(GetModuleHandleA("User32"), "IntersectRect") If IntersectRect = 0 Then Exit Sub FullMapICS = HACK.Alloc(64) Call HACK.WriteAOBByString(FullMapICS, "8B 04 24 81 38 85 C0 75 08 75 06 31 C0 40 C2 0C 00 55 8B EC") Call HACK.MakeJmp(FullMapICS + 20, IntersectRect + 5) If CkFullMap.value = 1 Then Call HACK.MakeJmp(IntersectRect, FullMapICS) Else: Call HACK.WriteAOBByString(IntersectRect, "8B FF 55 8B EC") End Sub Private Sub CkGod_Click() IsRectEmpty = GetProcAddress(GetModuleHandleA("User32"), "IsRectEmpty") If IsRectEmpty = 0 Then Exit Sub PhysicalGodICS = HACK.Alloc(64) Call HACK.WriteAOBByString(PhysicalGodICS, "8B 04 24 81 38 85 C0 74 11 75 06 31 C0 40 C2 04 00 55 8B EC") Call HACK.MakeJmp(PhysicalGodICS + 20, IsRectEmpty + 5) If CkGod.value = 1 Then Call HACK.MakeJmp(IsRectEmpty, PhysicalGodICS) Else: Call HACK.WriteAOBByString(IsRectEmpty, "8B FF 55 8B EC") End Sub Private Sub CkChrCut_Click() TmChrCut.Enabled = CkChrCut.value Call HACK.WritePointer(ChrBaseAdr, ChrBreathOffest - 8, 0) End Sub Private Sub CkDcCheck_Click() 'TmDCCheck.Enabled = CkDcCheck.value End Sub Private Sub CkLoli_Click() TmLoli.Enabled = CkLoli.value Call HACK.WritePointer(ChrBaseAdr, ChrBreathOffest - &H78, 0) End Sub Private Sub CkNoDelay_Click() TmNoDelay.Enabled = CkNoDelay.value End Sub '========== 按鍵鉤子 ========== Private Sub CkAttackBot_Click() TmAttack.Enabled = CkAttackBot.value TmAttack.Interval = Val(txtAttackSet) txtAttackSet.Enabled = Not CBool(CkAttackBot.value) End Sub Private Sub CkPickBot_Click() TmPick.Enabled = CkPickBot.value TmPick.Interval = Val(txtPickSet) txtPickSet.Enabled = Not CBool(CkPickBot.value) End Sub Private Sub CkBot1_Click() tBot1 = Val(txtBotSet1) TmBot1.Enabled = CkBot1.value Call RingPst(HACK.hWnd, "Press", txtBot1) End Sub Private Sub CkBot2_Click() tBot2 = Val(txtBotSet2) TmBot2.Enabled = CkBot2.value Call RingPst(HACK.hWnd, "Press", txtBot2) End Sub Private Sub CkBot3_Click() tBot3 = Val(txtBotSet3) TmBot3.Enabled = CkBot3.value Call RingPst(HACK.hWnd, "Press", txtBot3) End Sub Private Sub CkBot4_Click() tBot4 = Val(txtBotSet4) TmBot4.Enabled = CkBot4.value Call RingPst(HACK.hWnd, "Press", txtBot4) End Sub Private Sub CkBot5_Click() tBot5 = Val(txtBotSet5) TmBot5.Enabled = CkBot5.value Call RingPst(HACK.hWnd, "Press", txtBot5) End Sub Private Sub CkBot6_Click() tBot6 = Val(txtBotSet6) TmBot6.Enabled = CkBot6.value Call RingPst(HACK.hWnd, "Press", txtBot6) End Sub Private Sub CkAtkDown_Click() tAtkDown = Val(txtAtkDownSet) TmAtkDown.Enabled = CkAtkDown.value Call RingPst(HACK.hWnd, "Up", txtAtkDown) End Sub Private Sub CkTalk_Click() TmTalk.Enabled = CkTalk.value End Sub '========== Frame切換 ========== Private Sub CmdAutoBot_Click() Frame2.ZOrder End Sub Private Sub CmdBeanfun_Click() Frame3.ZOrder End Sub Private Sub CmdScripts_Click() Frame1.ZOrder End Sub '========== 自動換頻 ========== Private Sub CmdCh_Click() TmLoli.Enabled = 1 Do Until Breath = 0 TmAttack.Enabled = 0: TmPick.Enabled = 0: TmAtkDown.Enabled = 0 Sleep (300) DoEvents Loop Call RingPst(HACK.hWnd, "Press", "Esc"): Call RingPst(HACK.hWnd, "Press", "Enter"): Call RingPst(HACK.hWnd, "Press", "Left"): Call RingPst(HACK.hWnd, "Press", "Enter") CkLoli_Click TmAttack.Enabled = CkAttackBot.value: TmPick.Enabled = CkPickBot.value: tAtkDown = Val(txtAtkDownSet) End Sub Private Sub TmBreath_Timer() If CkChR.value = 1 And RedPoint > Val(txtChR) Then CmdCh_Click If CkChT.value = 1 Then tCh = tCh - 1 If tCh <= 0 Then CmdCh_Click: tCh = Val(txtChT) Else tCh = Val(txtChT) End If End Sub '========== Form設定 ========== Private Sub Form_Load() On Error Resume Next Call CheckUpdate_Click Me.Show Call SetWindowPos(Me.hWnd, -1, 0, 0, 0, 0, 3) With Me .Frame1.Left = 0 .Frame2.Left = 0 .Frame3.Left = 0 .Frame1.ZOrder End With Call PointerInitialize Call ReadSetting_Click Call CheckFiles Call LoadScripts Call LoadAccountList Call HACK.ChangeImagePath MSBlack = False: MultiON = False: ReRun = False: WriteInPlay.Checked = False Call WebB.Navigate("http://tw.new.beanfun.com/game_zone/default.aspx"): WebB.Silent = 1: WebB.ZOrder End Sub Private Sub Form_Resize() On Error Resume Next Me.Height = 7010 Me.Width = 3225 End Sub Private Sub Form_Unload(Cancel As Integer) Cancel = True: Me.WindowState = 1 End Sub Private Sub Form_Terminate() UnloadMe_Click End Sub Private Sub UnloadMe_Click() Call Shell("taskkill.exe /F /PID " & GetCurrentProcessId, vbHide) End Sub '========== 初始化 ========== Private Sub CheckFiles() On Error GoTo hErr If Dir(App.Path & "\Account", vbDirectory) = "" Then Call MkDir(App.Path & "\Account") If Dir(App.Path & "\Scripts", vbDirectory) = "" Then Call MkDir(App.Path & "\Scripts") If Dir$(App.Path & "\CEAutoAssembler.dll") = "" Then Call MsgBox("CEAutoAssembler.dll Lost!", vbCritical, "Lost") Exit Sub hErr: MsgBox Err.Number & Err.Description End Sub '========== 數據部分 ========== Private Sub LoadScripts() On Error GoTo Er: Dim strScriptsPath As String strScriptsPath = Dir(App.Path & "\Scripts\*.txt") lstScripts.Clear Do While Not Len(strScriptsPath) = 0 lstScripts.AddItem (strScriptsPath) strScriptsPath = Dir() Loop: Exit Sub Er: MsgBox Err.Number & Err.Description End Sub Private Sub LoadSelectedScript(strScriptFile As String) On Error GoTo Er Dim strScriptPath As String strScriptPath = App.Path & "\Scripts\" & strScriptFile Dim a() As Byte: ReDim a(FileLen(strScriptPath)) Open strScriptPath For Binary As #1: Get #1, , a: Close #1 LoadScript = StrConv(a, vbUnicode) Exit Sub Er: MsgBox Err.Number & Err.Description End Sub Private Sub lstScripts_ItemCheck(Item As Integer) If CEInitialize(HACK.Pid, HACK.Handle) = 0 Then Exit Sub Dim AllocID As Integer If lstScripts.Selected(Item) = True Then Call LoadSelectedScript(lstScripts.List(Item)) If Len(LoadScript) = 0 Then Exit Sub Call CEAutoAsm(LoadScript, True, AllocID) Else Call LoadSelectedScript(lstScripts.List(Item)) If Len(LoadScript) = 0 Then Exit Sub Call CEAutoAsm(LoadScript, False, AllocID) End If LoadScript = vbNullString End Sub '========== Pointer初始化 ========== Private Sub PointerInitialize() SystemBaseAdr = "&H" & ReadData("Pointer", "SystemBaseAdr") MpAlarmBaseAdr = "&H" & ReadData("Pointer", "MpAlarmBaseAdr") MpAlarmOffest = "&H" & ReadData("Pointer", "MpAlarmOffest") HpValueBaseAdr = "&H" & ReadData("Pointer", "HpValueBaseAdr") HpValueOffest = "&H" & ReadData("Pointer", "HpValueOffest") ChrBaseAdr = "&H" & ReadData("Pointer", "ChrBaseAdr") ChrBreathOffest = "&H" & ReadData("Pointer", "ChrBreathOffest") RedBaseAdr = MpAlarmBaseAdr + 4 MonBaseAdr = MpAlarmBaseAdr + 8 End Sub '========== 個人設定存取 ========== Private Sub SaneSetting_Click() Call WriteIniString("HpMp", "HpSet", txtHpSet) Call WriteIniString("HpMp", "HpBot", txtHpBot) Call WriteIniString("HpMp", "MpSet", txtMpSet) Call WriteIniString("HpMp", "MpBot", txtMpBot) Call WriteIniString("Detect", "RedSet", txtRedSet) Call WriteIniString("Detect", "MonSet", txtMonSet) Call WriteIniString("BotSet", "AttackSet", txtAttackSet) Call WriteIniString("BotSet", "AttackBot", txtAttackBot) Call WriteIniString("BotSet", "PickSet", txtPickSet) Call WriteIniString("BotSet", "PickBot", txtPickBot) Call WriteIniString("BotSet", "BotSet1", txtBotSet1) Call WriteIniString("BotSet", "Bot1", txtBot1) Call WriteIniString("BotSet", "BotSet2", txtBotSet2) Call WriteIniString("BotSet", "Bot2", txtBot2) Call WriteIniString("BotSet", "BotSet3", txtBotSet3) Call WriteIniString("BotSet", "Bot3", txtBot3) Call WriteIniString("BotSet", "BotSet4", txtBotSet4) Call WriteIniString("BotSet", "Bot4", txtBot4) Call WriteIniString("BotSet", "BotSet5", txtBotSet5) Call WriteIniString("BotSet", "Bot5", txtBot5) Call WriteIniString("BotSet", "BotSet6", txtBotSet6) Call WriteIniString("BotSet", "Bot6", txtBot6) Call WriteIniString("BotSet", "AtkDownSet", txtAtkDownSet) Call WriteIniString("BotSet", "AtkDown", txtAtkDown) Call WriteIniString("Detect", "ChR", txtChR) Call WriteIniString("Detect", "ChT", txtChT) Call WriteIniString("Login", "Delay", txtDelay) End Sub Private Sub ReadSetting_Click() txtHpSet = ReadIniInt("HpMp", "HpSet") txtHpBot = ReadIniString("HpMp", "HpBot") txtMpSet = ReadIniInt("HpMp", "MpSet") txtMpBot = ReadIniString("HpMp", "MpBot") txtRedSet = ReadIniInt("Detect", "RedSet") txtMonSet = ReadIniInt("Detect", "MonSet") txtAttackSet = ReadIniInt("BotSet", "AttackSet") txtAttackBot = ReadIniString("BotSet", "AttackBot") txtPickSet = ReadIniInt("BotSet", "PickSet") txtPickBot = ReadIniString("BotSet", "PickBot") txtBotSet1 = ReadIniInt("BotSet", "BotSet1") txtBot1 = ReadIniString("BotSet", "Bot1") txtBotSet2 = ReadIniInt("BotSet", "BotSet2") txtBot2 = ReadIniString("BotSet", "Bot2") txtBotSet3 = ReadIniInt("BotSet", "BotSet3") txtBot3 = ReadIniString("BotSet", "Bot3") txtBotSet4 = ReadIniInt("BotSet", "BotSet4") txtBot4 = ReadIniString("BotSet", "Bot4") txtBotSet5 = ReadIniInt("BotSet", "BotSet5") txtBot5 = ReadIniString("BotSet", "Bot5") txtBotSet6 = ReadIniInt("BotSet", "BotSet6") txtBot6 = ReadIniString("BotSet", "Bot6") txtAtkDownSet = ReadIniInt("BotSet", "AtkDownSet") txtAtkDown = ReadIniString("BotSet", "AtkDown") txtChR = ReadIniInt("Detect", "ChR") txtChT = ReadIniInt("Detect", "ChT") txtDelay = ReadIniInt("Login", "Delay") End Sub '========== Label控制 ========== Private Sub lblBreath_Change() lblBreath.Left = (Frame2.Width - lblBreath.Width) / 2 End Sub Private Sub lblHpMp_Change() lblHpMp.Left = (Frame2.Width - lblHpMp.Width) / 2 End Sub Private Sub lblRedMon_Change() lblRedMon.Left = (Frame2.Width - lblRedMon.Width) / 2 End Sub '========== Pointer功能 ========== Private Sub TmChrCut_Timer() Call HACK.WritePointer(ChrBaseAdr, ChrBreathOffest - 8, 1) End Sub Private Sub TmDCCheck_Timer() If HACK.ReadLong(ChrBaseAdr) = 0 Then Call RingPst(HACK.hWnd, "Press", "Enter") End Sub Private Sub TmLoli_Timer() Call HACK.WritePointer(ChrBaseAdr, ChrBreathOffest - &H78, 9) End Sub Private Sub TmNoDelay_Timer() Call HACK.WritePointer(ChrBaseAdr, ChrBreathOffest + 4, &HFFFFFFFF) End Sub '========== 遊戲檢查 ========== Private Sub TmGameCheck_Timer() If Not HACK.ReadPointer(SystemBaseAdr, &H1C) = 0 Then TmHpMp.Enabled = 1: TmPointer.Enabled = 1: TmHotKey.Enabled = 1: TmBreath.Enabled = 1 HACK.hWnd = HACK.ReadPointer(SystemBaseAdr, &H4) If CkDcCheck.value = 0 And HACK.ReadLong(ChrBaseAdr) = 0 Then Call RingPst(HACK.hWnd, "Press", "Enter") ElseIf FindWindow("#32770", "MapleStory") Then Call PostMessage(FindWindow("#32770", "MapleStory"), WM_CLOSE, 0, 0) ' HACK.CloseGame Else TmHpMp.Enabled = 0: TmPointer.Enabled = 0: TmHotKey.Enabled = 0: TmBreath.Enabled = 0 HACK.Pid = 0: HACK.Handle = 0: HACK.Inited = False MSBlack = False: BlackMS.Caption = "脫機ON" If CkAutoStart.value = 1 Then Call lstBFAccount_DblClick End If End Sub '========== 按鍵Timer ========== Private Sub TmAttack_Timer() If CkRed.value = 1 And Val(txtRedSet) < RedPoint Then Exit Sub If CkMon.value = 1 And Val(txtMonSet) > Monster Then Exit Sub Call RingPst(HACK.hWnd, "Press", txtAttackBot) End Sub Private Sub TmPick_Timer() Call RingPst(HACK.hWnd, "Press", txtPickBot) End Sub Private Sub TmBot1_Timer() tBot1 = tBot1 - 1 If tBot1 <= 0 Then Delay (2): Call RingPst(HACK.hWnd, "Press", txtBot1): Sleep (300): Call RingPst(HACK.hWnd, "Press", txtBot1): tBot1 = Val(txtBotSet1) End Sub Private Sub TmBot2_Timer() tBot2 = tBot2 - 1 If tBot2 <= 0 Then Delay (2): Call RingPst(HACK.hWnd, "Press", txtBot2): Sleep (300): Call RingPst(HACK.hWnd, "Press", txtBot2): tBot2 = Val(txtBotSet2) End Sub Private Sub TmBot3_Timer() tBot3 = tBot3 - 1 If tBot3 <= 0 Then Delay (2): Call RingPst(HACK.hWnd, "Press", txtBot3): Sleep (300): Call RingPst(HACK.hWnd, "Press", txtBot3): tBot3 = Val(txtBotSet3) End Sub Private Sub TmBot4_Timer() tBot4 = tBot4 - 1 If tBot4 <= 0 Then Delay (2): Call RingPst(HACK.hWnd, "Press", txtBot4): Sleep (300): Call RingPst(HACK.hWnd, "Press", txtBot4): tBot4 = Val(txtBotSet4) End Sub Private Sub TmBot5_Timer() tBot5 = tBot5 - 1 If tBot5 <= 0 Then Delay (2): Call RingPst(HACK.hWnd, "Press", txtBot5): Sleep (300): Call RingPst(HACK.hWnd, "Press", txtBot5): tBot5 = Val(txtBotSet5) End Sub Private Sub TmBot6_Timer() tBot6 = tBot6 - 1 If tBot6 <= 0 Then Delay (2): Call RingPst(HACK.hWnd, "Press", txtBot6): Sleep (300): Call RingPst(HACK.hWnd, "Press", txtBot6): tBot6 = Val(txtBotSet6) End Sub Private Sub TmAtkDown_Timer() If CkRed.value = 1 And Val(txtRedSet) < RedPoint Then Call RingPst(HACK.hWnd, "Up", txtAtkDown): Exit Sub If CkMon.value = 1 And Val(txtMonSet) > Monster Then Call RingPst(HACK.hWnd, "Up", txtAtkDown): Exit Sub Call RingPst(HACK.hWnd, "Down", txtAtkDown) tAtkDown = tAtkDown - 1 If tAtkDown <= 0 Then Delay (3): Call RingPst(HACK.hWnd, "Press", txtAtkDown): tAtkDown = Val(txtAtkDownSet): Sleep (300) End Sub '========== Pointer讀取 ========== Private Sub TmHpMp_Timer() Hp = HACK.ReadPointer(HpValueBaseAdr, HpValueOffest) Mp = HACK.ReadPointer(HpValueBaseAdr, HpValueOffest + 4) lblHpMp = "Hp:" & Hp & " Mp:" & Mp If CkHp = 1 And Hp < Val(txtHpSet) Then RingPst HACK.hWnd, "Press", txtHpBot If CkMp = 1 And Mp < Val(txtMpSet) Then RingPst HACK.hWnd, "Press", txtMpBot End Sub Private Sub TmPointer_Timer() RedPoint = HACK.ReadPointer(RedBaseAdr, &H2C) Monster = HACK.ReadPointer(MonBaseAdr, &H24) lblRedMon = "紅點:" & RedPoint & " 怪物:" & Monster Breath = HACK.ReadPointer(ChrBaseAdr, ChrBreathOffest - 4) lblBreath = "呼吸值:" & Breath End Sub Private Sub TmTalk_Timer() Call RingPst(HACK.hWnd, "Press", "Enter") Call RingPst(HACK.hWnd, "Press", "Down") End Sub '========== 設定鍵控制 ========== Private Sub txtHpSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtMpSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtRedSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtMonSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtAttackSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 If Val(txtAttackSet) > 10000 Then txtAttackSet = 100 End Sub Private Sub txtPickSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 If Val(txtPickSet) > 10000 Then txtPickSet = 100 End Sub Private Sub txtBotSet1_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtBotSet2_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtBotSet3_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtBotSet4_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtBotSet5_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtBotSet6_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtAtkDownSet_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtChR_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtChT_KeyPress(KeyAscii As Integer) If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then KeyAscii = 0 End Sub Private Sub txtHpBot_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtHpBot, KeyCode) End Sub Private Sub txtMpBot_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtMpBot, KeyCode) End Sub Private Sub txtAttackBot_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtAttackBot, KeyCode) End Sub Private Sub txtPickBot_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtPickBot, KeyCode) End Sub Private Sub txtBot1_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtBot1, KeyCode) End Sub Private Sub txtBot2_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtBot2, KeyCode) End Sub Private Sub txtBot3_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtBot3, KeyCode) End Sub Private Sub txtBot4_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtBot4, KeyCode) End Sub Private Sub txtBot5_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtBot5, KeyCode) End Sub Private Sub txtBot6_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtBot6, KeyCode) End Sub Private Sub txtAtkDown_KeyUp(KeyCode As Integer, Shift As Integer) Call SetKey(txtAtkDown, KeyCode) End Sub '========== HotKey ========== Private Sub TmHotKey_Timer() If Not GetForegroundWindow = HACK.hWnd Then Exit Sub If GetKeyState(&H12) < 0 And GetKeyState(&H58) < 0 Then Call CheckValue(CkAttackBot): Sleep (300) 'Alt+X If GetKeyState(&H12) < 0 And GetKeyState(&H5A) < 0 Then Call CheckValue(CkPickBot): Sleep (300) 'Alt+Z End Sub Private Sub CheckValue(CK As CheckBox) If CK.value = 0 Then CK.value = 1 Else: CK.value = 0 End Sub '========== BeanFun ========== Private Sub Cmd_Ok_Click() On Error GoTo Er If Len(txt_User.Text) = 0 Or Len(txt_Pass.Text) = 0 Or Len(txt_Check.Text) = 0 Then Exit Sub With WebB.Document.Frames.ifmForm1.Document .GetElementById("t_AccountID").value = txt_User.Text .GetElementById("t_Password").value = txt_Pass.Text .GetElementById("CodeTextBox").value = txt_Check.Text .GetElementById("btn_login").Click End With txt_Check.Text = vbNullString Do: DoEvents: Loop While WebB.Busy If InStr(WebB.Document.Frames.ifmForm1.Document.GetElementById("DivMsgBoxContainer").innertext, "錯誤") Then MsgBox "帳密或驗證碼錯誤", vbInformation, "ERROR" WebB.Document.Frames.ifmForm1.Document.GetElementById("MsgBoxOkBtn").Click Exit Sub End If Er: WebB.Navigate "http://tw.new.beanfun.com/game_zone/default.aspx" End Sub Private Sub Cmd_ReGet_Click() On Error Resume Next 'WebB.Navigate "http://tw.new.beanfun.com/game_zone/default.aspx" 'Cmd_Ok.Enabled = False 'Cmd_ReGet.Enabled = False WebB.Document.Frames.ifmForm1.Document.GetElementById("c_login_idpass_form_samplecaptcha_ReloadLink").Click Do: DoEvents: Loop Until WebB.ReadyState = READYSTATE_COMPLETE Delay (1) Call GetImage End Sub Private Sub txt_Check_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then Cmd_Ok_Click End Sub Private Sub Update_Click() On Error Resume Next If Shell("Data自動更新器") Then If MsgBox("使用 Data自動更新器 成功後請按下「是」來重新載入", vbYesNo, "更新中") = vbYes Then Call PointerInitialize Else: End Else MsgBox "自動更新器檔案遺失", vbCritical, "Miss" End If End Sub Private Sub WebB_DocumentComplete(ByVal pDisp As Object, URL As Variant) On Error Resume Next If InStr(URL, "game_zone") Then 'Call ClickBtn(WebB, "BF_anchorLoginBtn", "a") WebB.Document.GetElementById("BF_anchorLoginBtn").Click CheckPic.Cls Cmd_Ok.Enabled = 0: Cmd_ReGet.Enabled = 0: txt_Check.Enabled = 0 WebB.ZOrder lblStatue.Caption = "狀態:歡迎使用" End If If InStr(URL, "loginform.aspx") Or InStr(URL, "id-pass_form.aspx") Then If ReRun = False Then ReRun = True Cmd_Ok.Enabled = 1: Cmd_ReGet.Enabled = 1: txt_Check.Enabled = 1 Call GetImage Frame4.ZOrder lblStatue.Caption = "狀態:登入介面" End If If InStr(URL, "logout.aspx") Then WebB.ZOrder WebB.Navigate "http://tw.new.beanfun.com/game_zone/default.aspx" End If End Sub Private Sub GetImage() On Error GoTo Er Dim ctrlRange As Object Set ctrlRange = WebB.Document.Frames.ifmForm1.Document.body.createControlRange() ctrlRange.Add (WebB.Document.Frames.ifmForm1.Document.GetElementById("c_login_idpass_form_samplecaptcha_CaptchaImage")) 'ctrlRange.Add (WebB.Document.Frames.ifmForm1.Document.images(1)) ctrlRange.execCommand ("Copy") Delay (1) '修正剪貼簿無法開啟問題 CheckPic.Picture = Clipboard.GetData Clipboard.Clear Er: End Sub Private Sub LoadAccountList() On Error GoTo Er: lstAccount.Clear Dim File As String File = Dir(App.Path & "\Account\" & "*.ini") While Len(File) lstAccount.AddItem File File = Dir() Wend Exit Sub Er: MsgBox "帳戶讀取錯誤", , "Fail" End Sub Private Sub Home_Click() WebB.ZOrder Call WebB.Navigate("http://tw.new.beanfun.com/game_zone/default.aspx") CmdBeanfun_Click End Sub Private Sub Login_Click() On Error Resume Next WebB.ZOrder WebB.Navigate "https://tw.newlogin.beanfun.com/logout.aspx?service=999999_T0" End Sub Private Sub forcelogun_Click() WebB.Stop If InStr(WebB.LocationURL, "loginform.aspx") Then Call GetImage If ReRun = False Then ReRun = True Cmd_Ok.Enabled = 1: Cmd_ReGet.Enabled = 1: txt_Check.Enabled = 1 Frame4.ZOrder lblStatue.Caption = "狀態:登入介面" ElseIf MsgBox("頁面錯誤!是否強制顯示登入介面?", vbYesNo + vbCritical, "確認") = vbYes Then Frame4.ZOrder End If End Sub Private Sub AddAccount_Click() CmdBeanfun_Click If Len(txt_User) = 0 Or Len(txt_Pass) = 0 Then Exit Sub Dim fileName As String fileName = InputBox("請輸入儲存的檔名:" & vbCrLf & "提示:請避免使用帳號作為檔名,儲存後檔案將會加密,不使用帳號為檔名可降低被猜中帳密的機率。", "請輸入檔名", txt_User.Text) Call SaveAccount(txt_User, txt_Pass, fileName) Call LoadAccountList End Sub Private Sub lstAccount_Click() txt_User = ReadUserName(lstAccount.List(lstAccount.ListIndex)) txt_Pass = ReadPassword(lstAccount.List(lstAccount.ListIndex)) End Sub Private Sub DelAccount_Click() CmdBeanfun_Click On Error Resume Next If MsgBox("是否刪除" & lstAccount.List(lstAccount.ListIndex), vbYesNo, "確認") = vbYes Then Kill (Replace(App.Path & "\" & lstAccount.List(lstAccount.ListIndex), "\\", "\")) Call LoadAccountList End If End Sub Private Sub ReAccount_Click() Call LoadAccountList CmdBeanfun_Click End Sub Private Sub ReLoadBeanfun_Click() Call Shell("taskkill.exe /im BFWidgetKernel.exe /f", vbHide) WebB.Navigate "http://tw.new.beanfun.com/game_zone/default.aspx" End Sub Private Sub GotoBeanfun_Click() Call Shell("rundll32.exe url.dll,FileProtocolHandler http://tw.new.beanfun.com/game_zone/default.aspx", vbHide) End Sub '========== 取得快速列表 ========== Private Sub CmdGetAccount_Click() On Error Resume Next WebB.Navigate "javascript:BeanFunBlock.WebTrendCounter('DCSext.bf_GameZone','610074T9_StartGame');BeanFunBlock.StartGameByService('610074', 'T9');" Do: DoEvents: Loop While WebB.Busy Delay (1) lblStatue.Caption = "狀態:取得帳號列表" Dim strAccountData As String 'WebB.Document.GetElementById("BF_btnQuickStart").Click ' Delay (1) 'strAccountData = WebB.Document.GetElementById("BF_divPopWindow").Document.GetElementById("BF_BaseList").OuterHtml strAccountData = WebB.Document.Frames.fbContent.Document.GetElementById("ulServiceAccountList").innerhtml 'WebB.Document.GetElementById("BF_btnQuickStart").Click Dim strAccount() As String 'strAccount() = Split(strAccountData, "LI onclick=""") strAccount() = Split(strAccountData, "LI onclick=""GameAccount.StartGame(") lbAccount.Clear lstBFAccount.Clear Dim i As Integer For i = 1 To UBound(strAccount) 'lbAccount.AddItem (Split(strAccount(i), """>")(0)) 'lstBFAccount.AddItem (Split(Split(strAccount(i), "")(1), " ")(0)) lbAccount.AddItem ("BeanFunBlock.StartGameWithAccountData('610074','T9'," & Split(Split(strAccount(i), "GameAccount"">")(0), ";")(0)) lstBFAccount.AddItem (Split(Split(strAccount(i), ">")(2), "<")(0)) Next If lstBFAccount.ListCount = 0 Then GoTo Er lblStatue.Caption = "狀態:列表取得成功" WebB.Document.GetElementById("fbClose").Click Exit Sub Er: MsgBox "網頁正在載入或帳號未登入" & vbCrLf & "P.s 如還是無法解決請至BF首頁查詢", vbInformation, "請稍後在試!" WebB.ZOrder End Sub Private Sub lstBFAccount_DblClick() Call WebB.Navigate("javascript:" & lbAccount.List(lstBFAccount.ListIndex)) 'Do: DoEvents: Loop Until WebB.ReadyState = READYSTATE_COMPLETE Dim GetCaption As Boolean TimeCheck = 10: TmTimeCheck.Enabled = 1 Do Until GetCaption On Error Resume Next GetCaption = Len(WebB.Document.GetElementById("fbCaption")) lblStatue.Caption = "檢查起始狀態:" & TimeCheck If TimeCheck <= 0 Then GoTo Er Sleep (300) DoEvents Loop If WebB.Document.Frames.fbContent.Document.GetElementById("lblFriendlyReminder").innertext = "友善提醒" Then lblStatue.Caption = "狀態:友情提醒處理中..." Delay (7) WebB.Document.Frames.fbContent.Document.GetElementById("cbxRemoveServiceFriendlyReminder").Click WebB.Document.Frames.fbContent.Document.GetElementById("btnFriendlyReminderOK").Click End If Er: TmTimeCheck.Enabled = 0 If CkAutoStart.value = 1 Then Call StartGame End Sub '========== 遊戲啟動 ========== Private Sub StartGame() On Error Resume Next TmDCCheck.Enabled = False: HACK.CloseGame Delay (1) TimeCheck = 59: TmTimeCheck.Enabled = 1 Do Until HACK.Inited If TimeCheck <= 0 Then GoTo Er lblStatue.Caption = "等待遊戲啟動視窗:" & TimeCheck Call HACK.OpenProcessByWindow("MapleStory", "StartUpDlgClass") DoEvents Loop TmTimeCheck.Enabled = 0 If CkPlay.value = 0 Then Call PostMessage(HACK.hWnd, WM_CLOSE, 0, 0) If WriteInPlay.Checked Then ReAutoASM TimeCheck = 23: TmTimeCheck.Enabled = 1 Do While HACK.ReadPointer(SystemBaseAdr, &H4) = 0 If TimeCheck <= 0 Then GoTo Er lblStatue.Caption = "等待視窗初始:" & TimeCheck Sleep (900) DoEvents Loop TmTimeCheck.Enabled = 0 TimeCheck = 150: TmTimeCheck.Enabled = 1 Do While HACK.ReadPointer(SystemBaseAdr, &H1C) = 0 If TimeCheck <= 0 Or HACK.ReadPointer(SystemBaseAdr, &H4) = 0 Then GoTo Er lblStatue.Caption = "等待登入畫面:" & TimeCheck Sleep (900) DoEvents Loop TmTimeCheck.Enabled = 0 'Call RingPst(HACK.hWnd, "Press", "Enter") '跳過開場動畫 lblStatue.Caption = "狀態:啟動完成" Delay Val(txtDelay) lblStatue.Caption = "狀態:完成延遲" Delay (13) Call CmdLoginMe_Click Exit Sub Er: lblStatue.Caption = "狀態:啟動失敗" Call HACK.CloseGame HACK.Pid = 0: HACK.Handle = 0: HACK.hWnd = 0: HACK.Inited = False End Sub '========== 角色登入 ========== Private Sub CmdLoginMe_Click() On Error Resume Next HACK.hWnd = HACK.ReadPointer(SystemBaseAdr, &H4) If HACK.Inited = False Then GoTo Er lblStatue.Caption = "狀態:正在登入伺服器" Dim i As Integer For i = 0 To (21 - lstServer.ListIndex) '登入伺服器 Call RingPst(HACK.hWnd, "Press", "Tab") Next Delay (1) Call RingPst(HACK.hWnd, "Press", "Enter") If HACK.ReadPointer(SystemBaseAdr, &H4) = 0 Then GoTo Er Delay (1) lblStatue.Caption = "狀態:正在登入頻道" For i = 1 To lstChannel.ListIndex '登入頻道 Call RingPst(HACK.hWnd, "Press", "Tab") Next RingPst HACK.hWnd, "Press", "Enter" lblStatue.Caption = "狀態:正在登入延遲" Delay Val(txtDelay) If HACK.ReadPointer(SystemBaseAdr, &H4) = 0 Then GoTo Er lblStatue.Caption = "狀態:正在選擇角色" For i = 1 To 15 '至最左邊 Call RingPst(HACK.hWnd, "Press", "Left") Next For i = 1 To lstChrNum.ListIndex '選擇角色 Call RingPst(HACK.hWnd, "Press", "Right") Next Delay (1) Call RingPst(HACK.hWnd, "Press", "Enter") Call RingPst(HACK.hWnd, "Press", "Enter") Call SetWindowPos(HACK.hWnd, -2, 0, 5, 0, 0, &H1) Call RingPst(HACK.hWnd, "Press", "Enter") TimeCheck = 23: TmTimeCheck.Enabled = 1 Do While HACK.ReadPointer(ChrBaseAdr, ChrBreathOffest + 4) = 0 If TimeCheck <= 0 Or HACK.ReadPointer(SystemBaseAdr, &H4) = 0 Then GoTo Er lblStatue.Caption = "正在檢查登入狀態:" & TimeCheck Sleep (900) DoEvents Loop TmTimeCheck.Enabled = 0 lblStatue.Caption = "登入成功,歡迎使用!" Call AttachInitialize Call SetForegroundWindow(HACK.hWnd) Exit Sub Er: lblStatue.Caption = "狀態:登入失敗" Call HACK.CloseGame HACK.Pid = 0: HACK.Handle = 0: HACK.hWnd = 0: HACK.Inited = False End Sub '========== 資訊儲存 ========== Private Sub lstServer_Click() Call WriteIniString("Account", "Server", lstServer.ListIndex) End Sub Private Sub lstChannel_Click() Call WriteIniString("Account", "Channel", lstChannel.ListIndex) End Sub Private Sub lstChrNum_Click() Call WriteIniString("Account", "ChrNum", lstChrNum.ListIndex) End Sub Private Sub CmdReadSet_Click() lstServer.ListIndex = ReadIniInt("Account", "Server") lstChannel.ListIndex = ReadIniInt("Account", "Channel") lstChrNum.ListIndex = ReadIniInt("Account", "ChrNum") End Sub Private Sub TmTimeCheck_Timer() TimeCheck = TimeCheck - 1 '倒數 End Sub還有模組...
clsHack.cls:原創作者 Inndy,此為修改版,加入 Je、Jne 函數,刪除 DLLInject 函數(當初是為了改善誤判)
'====================================================================================== '=本Class由秋楓落葉 (Inndy) 撰寫,請隨意使用但勿移除本註解 '================================================================================ '===這裡面有什麼?=============================================================== '================================================================================ '=====OpenProcess部分,統一用Process_All_Access開啟 '=======OpenProcessByWindow (FindWindow取得PID並開啟進程) '=======OpenProcessByProcessName (例舉進程,根據進程名稱取得PID並開啟) '=======OpenProcess (只需填入PID) '================================================================================ '=====寫入部分 '=======WriteMemory (幾乎等於WriteProcessMemory這條API) '=======WriteByte、WriteLong、WriteString、WriteCurrency...等寫入函數 '=======WriteAOBByString (字串AOB寫入) '=======WriteMultiPointerByString (寫入多重指標) '================================================================================ '=====讀取部份 '=======ReadMemory (幾乎等於ReadProcessMemory這條API) '=======ReadByte、ReadLong、ReadString、ReadCurrency...等讀取函數 '=======ReadMultiPointerByString (讀取多重指標) '================================================================================ '====多重Pointer表示式:5A3B08=>460:A8:C '====================================================================================== Option Explicit '=====================================SETTING===================================== Private Const PreAllocSize As Long = &H10000 * 8 '=======================================API======================================= 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 OpenProcessAPI Lib "kernel32" Alias "OpenProcess" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function WriteProcessMemoryAPI Lib "kernel32" Alias "WriteProcessMemory" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long 'Private Declare Function ReadProcessMemoryAPI Lib "kernel32" Alias "ReadProcessMemory" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Private Declare Function ZwReadVirtualMemory Lib "ntdll" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode 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 CloseHandleAPI Lib "kernel32" Alias "CloseHandle" (ByVal hObject As Long) As Long Private Declare Function VirtualAlloc Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long '=====================================Consts====================================== Private Const PROCESS_ALL_ACCESS = &H1F0FFF Private Const MEM_COMMIT = &H1000 Private Const PAGE_READWRITE = &H4 '==================================VarsForClass=================================== Private PreAllocAddress As Long Private AllocedSize As Long '======================================Vars======================================= Public Inited As Boolean Public hWnd, Handle, Pid As Long Public Function OpenProcess(Optional ByVal lpPID As Long = -1) As Long If lpPID = 0 And Pid = 0 Then Exit Function 'If lpPID > 0 And Pid = 0 Then Pid = lpPID If lpPID > 0 Then Pid = lpPID Handle = OpenProcessAPI(PROCESS_ALL_ACCESS, False, Pid) OpenProcess = Handle If Handle > 0 Then Inited = True End Function Public Function OpenProcessByWindow(ByVal lpWindowName As String, Optional ByVal lpClassName As String = vbNullString) As Long hWnd = FindWindow(lpClassName, lpWindowName) GetWindowThreadProcessId hWnd, Pid OpenProcessByWindow = OpenProcess End Function Public Function CloseHandle() As Long If Not Inited Then Exit Function CloseHandle = CloseHandleAPI(Handle) Handle = 0 hWnd = 0 Pid = 0 Inited = False End Function Public Function CloseGame() As Long If Not Inited Then Exit Function CloseGame = TerminateProcess(Handle, 0&) CloseHandle Handle = 0 Pid = 0 hWnd = 0 End Function Public Function ChangeImagePath(Optional ByVal lpImagePath As String = "C:\WINDOWS\system32\taskmgr.exe") As Long Static BeUsed As Boolean If BeUsed = False Then Dim hProcess As Long hProcess = OpenProcessAPI(PROCESS_ALL_ACCESS, 0, GetCurrentProcessId) If hProcess = 0 Then Exit Function Dim sLenth As Long Dim BaseAddress As Long sLenth = LenB(lpImagePath) + 1 + 26 BaseAddress = VirtualAllocEx(hProcess, ByVal 0&, ByVal sLenth, MEM_COMMIT, PAGE_READWRITE) If BaseAddress = 0 Then Exit Function WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 0, ByVal VarPtr(&H30058B64), 4, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 4, ByVal VarPtr(&H8B000000), 4, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 8, ByVal VarPtr(&HC0831040), 4, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 12, ByVal VarPtr(&H245C8B3C), 4, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 16, ByVal VarPtr(&H89188904), 4, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 20, ByVal VarPtr(&HC2042444), 4, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 24, ByVal VarPtr(&H10), 2, False WriteProcessMemoryAPI hProcess, ByVal BaseAddress + 26, ByVal StrPtr(lpImagePath), sLenth, False CloseHandleAPI hProcess CallWindowProc BaseAddress, BaseAddress + 26, 0, 0, 0 BeUsed = True ChangeImagePath = BaseAddress End If End Function Public Function WriteMemory(ByVal lpAddress As Long, ByVal lpBuffer As Long, ByVal lpSize As Long) As Long WriteMemory = WriteProcessMemoryAPI(Handle, ByVal lpAddress, ByVal lpBuffer, ByVal lpSize, False) End Function Public Function WriteByte(ByVal lpAddress As Long, ByVal lpValue As Byte) As Long WriteByte = WriteProcessMemoryAPI(Handle, ByVal lpAddress, ByVal VarPtr(lpValue), ByVal LenB(lpValue), False) End Function Public Function WriteLong(ByVal lpAddress As Long, ByVal lpValue As Long) As Long WriteLong = WriteProcessMemoryAPI(Handle, ByVal lpAddress, ByVal VarPtr(lpValue), ByVal LenB(lpValue), False) End Function Public Function WriteString(ByVal lpAddress As Long, ByVal lpValue As String) As Long WriteString = WriteProcessMemoryAPI(Handle, ByVal lpAddress, ByVal VarPtr(lpValue), ByVal LenB(lpValue), False) End Function Public Function WriteAOBByString(ByVal lpAddress As Long, ByVal lpAobString As String) As Long Dim WriteI As Integer Dim WriteStr() As String Dim WriteBuff() As Byte lpAobString = Trim(lpAobString) WriteStr() = Split(lpAobString, " ") ReDim WriteBuff(UBound(WriteStr)) For WriteI = 0 To UBound(WriteStr) WriteBuff(WriteI) = (Val("&H" + WriteStr(WriteI))) Next WriteI WriteAOBByString = WriteProcessMemoryAPI(Handle, ByVal lpAddress, ByVal VarPtr(WriteBuff(0)), UBound(WriteBuff) + 1, 0&) End Function Public Function WritePointer(ByVal lpAddress As Long, ByVal lpOffset As Long, ByVal lpValue As Long) As Long WritePointer = WriteLong(ReadLong(lpAddress) + lpOffset, lpValue) End Function Public Function WriteMultiPointerByString(ByVal lpPointerList As String, ByVal lpBuffer As Long, ByVal lpSize As Long) As Long 'HACK.WriteMultiPointerByString "5A3B08=>460:A8:0", VarPtr(Gold), 4 Dim PointerList() As String Dim tmp1, tmp2, i As Long tmp1 = Val("&H" & Split(lpPointerList, "=>")(0)) PointerList = Split(Split(lpPointerList, "=>")(1), ":") For i = 0 To UBound(PointerList) tmp2 = ReadLong(tmp1) + Val("&H" & PointerList(i)) tmp1 = tmp2 Next tmp2 = WriteMemory(tmp1, lpBuffer, lpSize) WriteMultiPointerByString = tmp2 End Function Public Function ReadMemory(ByVal lpAddress As Long, ByVal lpBuffer As Long, ByVal lpSize As Long) As Long ReadMemory = ZwReadVirtualMemory(Handle, ByVal lpAddress, ByVal lpBuffer, ByVal lpSize, False) End Function Public Function ReadLong(ByVal lpAddress As Long) As Long Dim value As Long ZwReadVirtualMemory Handle, ByVal lpAddress, ByVal VarPtr(value), ByVal 4, False ReadLong = value End Function Public Function ReadDouble(ByVal lpAddress As Long) As Double Dim value As Double ZwReadVirtualMemory Handle, ByVal lpAddress, ByVal VarPtr(value), ByVal 8, False ReadDouble = value End Function Public Function ReadString(ByVal lpAddress As Long, ByVal lpSize As Long) As String Dim value As String value = Space(lpSize) ZwReadVirtualMemory Handle, ByVal lpAddress, ByVal StrPtr(value), ByVal lpSize, False ReadString = value value = "" End Function Public Function ReadPointer(ByVal lpAddress As Long, ByVal lpOffset As Long) As Long ReadPointer = ReadLong(ReadLong(lpAddress) + lpOffset) End Function Public Function ReadMultiPointerByString(ByVal lpPointerList As String, ByVal lpBuffer As Long, ByVal lpSize As Long) As Long 'HACK.ReadMultiPointerByString "5A3B08=>460:A8:C", VarPtr(Gold), 4 Dim PointerList() As String Dim tmp1, tmp2, i As Long tmp1 = Val("&H" & Split(lpPointerList, "=>")(0)) PointerList = Split(Split(lpPointerList, "=>")(1), ":") For i = 0 To UBound(PointerList) tmp2 = ReadLong(tmp1) + Val("&H" & PointerList(i)) tmp1 = tmp2 Next tmp2 = ReadMemory(tmp1, lpBuffer, lpSize) ReadMultiPointerByString = tmp2 End Function Public Function Alloc(ByVal lpSize As Long, Optional ByVal lpAddress As Long = 0) As Long If Not Inited Then Exit Function If PreAllocAddress = 0 Then PreAllocAddress = VirtualAllocEx(Handle, ByVal lpAddress, ByVal PreAllocSize, MEM_COMMIT, PAGE_READWRITE) End If If lpSize > (PreAllocSize / 4) Then '大於1/4的預先申請空間,就另外申請 Alloc = VirtualAllocEx(Handle, ByVal lpAddress, ByVal lpSize, MEM_COMMIT, PAGE_READWRITE) Exit Function End If If lpSize + AllocedSize > PreAllocSize Then '申請空間會超出預先申請空間時,多申請一些空間 PreAllocAddress = VirtualAllocEx(Handle, ByVal lpAddress, ByVal PreAllocSize, MEM_COMMIT, PAGE_READWRITE) AllocedSize = 0 End If Alloc = PreAllocAddress + AllocedSize AllocedSize = AllocedSize + lpSize End Function Public Function MakeJmp(ByVal lpAddress As Long, ByVal lpJmpAddress As Long, Optional ByVal lpNops As Long = 0) As Long MakeJmp = CBool(WriteByte(lpAddress, &HE9)) And CBool(WriteLong(lpAddress + 1, lpJmpAddress - lpAddress - 5)) If lpNops = 0 Then Exit Function MakeJmp = MakeJmp And CBool(MakeNops(lpAddress + 5, lpNops)) End Function Public Function MakeCall(ByVal lpAddress As Long, ByVal lpCallAddress As Long, Optional ByVal lpNops As Long = 0) As Long MakeCall = CBool(WriteByte(lpAddress, &HE8)) And CBool(WriteLong(lpAddress + 1, lpCallAddress - lpAddress - 5)) If lpNops = 0 Then Exit Function MakeCall = MakeCall And CBool(MakeNops(lpAddress + 5, lpNops)) End Function Public Function MakeNops(ByVal lpAddress As Long, ByVal lpSize As Long) As Long If lpSize = 0 Then MakeNops = True Exit Function End If Dim NOP() As Byte ReDim NOP(lpSize) Dim i As Long For i = 0 To lpSize - 1 NOP(i) = &H90 Next MakeNops = WriteMemory(lpAddress, VarPtr(NOP(0)), lpSize) End Function Public Function Address2Aob(ByVal Address As Long) As String Dim tmpAOB As String, reAOB As String, i As Integer tmpAOB = Hex(Address) For i = 1 To 7 If (i Mod 2) = 1 Then reAOB = Mid(tmpAOB, i, 2) & " " & reAOB Next Address2Aob = Chr(32) & Trim(reAOB) & Chr(32) End Function Public Function asm_Je(ByVal FromAdd As Long, ByVal TargetAdd As Long) As String Dim jneAdd As String, reAOB As String, i As Integer jneAdd = Hex(TargetAdd - (FromAdd + 6)) For i = 1 To 7 If (i Mod 2) = 1 Then reAOB = Mid(jneAdd, i, 2) & " " & reAOB Next asm_Je = Chr(32) & Trim(reAOB) & Chr(32) End Function Public Function asm_Jne(ByVal FromAdd As Long, ByVal TargetAdd As Long) As String Dim jneAdd As String, reAOB As String, i As Integer jneAdd = Hex(TargetAdd - (FromAdd + 6)) For i = 1 To 7 If (i Mod 2) = 1 Then reAOB = Mid(jneAdd, i, 2) & " " & reAOB Next asm_Jne = Chr(32) & Trim(reAOB) & Chr(32) End Function
modPst.bas:我也不大清楚這是誰源創的,已經流傳很久的後台腳本... 有加入一些 KeyCode...
Public opIndex As Long Public OpCode() As Byte Dim hModuleNoFree As Long Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long Public Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpDllName As String) As Long Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Any, ByVal lpSource As Any, ByVal cBytes As Long) Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Integer Public Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long Public Const WM_CLOSE = &H10 Public Function RingPst(Handle As Long, KeyType As String, KeyCode As String) Dim KeyValue As Long KeyValue = 0 ' '判斷按鍵並轉換成code If KeyCode = "`" Then KeyValue = &HE5 If KeyCode = "Esc" Then KeyValue = &H1B If KeyCode = "Left" Then KeyValue = &H25 If KeyCode = "Up" Then KeyValue = &H26 If KeyCode = "Right" Then KeyValue = &H27 If KeyCode = "Down" Then KeyValue = &H28 If KeyCode = "Enter" Then KeyValue = &HD If KeyCode = "Tab" Then KeyValue = &H9 If KeyCode = "Shift" Then KeyValue = &H10 If KeyCode = "Ctrl" Then KeyValue = &H11 If KeyCode = "Alt" Then KeyValue = &H12 If KeyCode = "Space" Then KeyValue = &H20 If KeyCode = "PageUp" Then KeyValue = &H21 If KeyCode = "PageDown" Then KeyValue = &H22 If KeyCode = "End" Then KeyValue = &H23 If KeyCode = "Home" Then KeyValue = &H24 If KeyCode = "Insert" Then KeyValue = &H2D If KeyCode = "Delete" Then KeyValue = &H2E If KeyCode = "0" Then KeyValue = &H30 If KeyCode = "1" Then KeyValue = &H31 If KeyCode = "2" Then KeyValue = &H32 If KeyCode = "3" Then KeyValue = &H33 If KeyCode = "4" Then KeyValue = &H34 If KeyCode = "5" Then KeyValue = &H35 If KeyCode = "6" Then KeyValue = &H36 If KeyCode = "7" Then KeyValue = &H37 If KeyCode = "8" Then KeyValue = &H38 If KeyCode = "9" Then KeyValue = &H39 If KeyCode = "A" Then KeyValue = &H41 If KeyCode = "B" Then KeyValue = &H42 If KeyCode = "C" Then KeyValue = &H43 If KeyCode = "D" Then KeyValue = &H44 If KeyCode = "E" Then KeyValue = &H45 If KeyCode = "F" Then KeyValue = &H46 If KeyCode = "G" Then KeyValue = &H47 If KeyCode = "H" Then KeyValue = &H48 If KeyCode = "I" Then KeyValue = &H49 If KeyCode = "J" Then KeyValue = &H4A If KeyCode = "K" Then KeyValue = &H4B If KeyCode = "L" Then KeyValue = &H4C If KeyCode = "M" Then KeyValue = &H4D If KeyCode = "N" Then KeyValue = &H4E If KeyCode = "O" Then KeyValue = &H4F If KeyCode = "P" Then KeyValue = &H50 If KeyCode = "Q" Then KeyValue = &H51 If KeyCode = "R" Then KeyValue = &H52 If KeyCode = "S" Then KeyValue = &H53 If KeyCode = "T" Then KeyValue = &H54 If KeyCode = "U" Then KeyValue = &H55 If KeyCode = "V" Then KeyValue = &H56 If KeyCode = "W" Then KeyValue = &H57 If KeyCode = "X" Then KeyValue = &H58 If KeyCode = "Y" Then KeyValue = &H59 If KeyCode = "Z" Then KeyValue = &H5A If KeyCode = "F1" Then KeyValue = &H70 If KeyCode = "F2" Then KeyValue = &H71 If KeyCode = "F3" Then KeyValue = &H72 If KeyCode = "F4" Then KeyValue = &H73 If KeyCode = "F5" Then KeyValue = &H74 If KeyCode = "F6" Then KeyValue = &H75 If KeyCode = "F7" Then KeyValue = &H76 If KeyCode = "F8" Then KeyValue = &H77 If KeyCode = "F9" Then KeyValue = &H78 If KeyCode = "F10" Then KeyValue = &H79 If KeyCode = "F11" Then KeyValue = &H7A If KeyCode = "F12" Then KeyValue = &H7B If KeyCode = "None" Then Exit Function '判斷按件格式 Select Case KeyType Case "Press" '按下彈起 rundll32 "user32", "PostMessageA", Handle, &H100, KeyValue, MakeKeyLparam(KeyValue, &H100) rundll32 "user32", "PostMessageA", Handle, &H101, KeyValue, MakeKeyLparam(KeyValue, &H101) Case "Down" '按下 rundll32 "user32", "PostMessageA", Handle, &H100, KeyValue, MakeKeyLparam(KeyValue, &H100) Case "Up" '彈起 rundll32 "user32", "PostMessageA", Handle, &H101, KeyValue, MakeKeyLparam(KeyValue, &H101) End Select End Function Function MakeKeyLparam(ByVal VirtualKey As Long, ByVal flag As Long) As Long '參數VirtualKey表示按鍵虛擬碼,flag表示是按下鍵還是釋放鍵,用WM_KEYDOWN和WM_KEYUP這兩個常數表示 Dim s As String Dim Firstbyte As String 'lparam參數的24-31位 If flag = WM_KEYDOWN Then '如果是按下鍵 Firstbyte = "00" Else Firstbyte = "C0" '如果是釋放鍵 End If Dim Scancode As Long '獲得鍵的掃描碼 Scancode = MapVirtualKey(VirtualKey, 0) Dim Secondbyte As String 'lparam參數的16-23位元,即虛擬鍵掃描碼 Secondbyte = Right("00" & Hex(Scancode), 2) s = Firstbyte & Secondbyte & "0001" '0001為lparam參數的0-15位,即發送次數和其他擴展資訊 MakeKeyLparam = Val("&H" & s) End Function Public Sub AddByteToCode(bData As Byte) OpCode(opIndex) = bData opIndex = opIndex + 1 End Sub Public Sub AddLongToCode(lData As Long) CopyMemory VarPtr(OpCode(opIndex)), VarPtr(lData), 4 opIndex = opIndex + 4 End Sub '將Integer型態的變數寫到OpCode種 Public Sub AddIntToCode(iData As Byte) CopyMemory VarPtr(OpCode(opIndex)), VarPtr(iData), 2 opIndex = opIndex + 2 End Sub Public Function RunDll32NoFree(LibFileName As String, ProcName As String, ParamArray Params()) As Long Dim hProc As Long Dim hModule As Long Dim i As Long, CodeStar As Long ReDim OpCode(400 + 6 * UBound(Params)) '保留用來寫OPCODE '讀取模組 If hModuleNoFree <> 0 Then hModule = hModuleNoFree Else hModule = LoadLibrary(ByVal LibFileName) If hModule = 0 Then MsgBox "Library讀取失敗" Exit Function End If hModuleNoFree = hModule End If '取得函數位址 hProc = GetProcAddress(hModule, ByVal ProcName) If hProc = 0 Then MsgBox "函數讀取失敗", vbCritical FreeLibrary hModule Exit Function End If '---以下為Assembly-- '程式起始位址必須是16的倍數 CodeStar = (VarPtr(OpCode(0)) Or &HF) + 1 opIndex = CodeStar - VarPtr(OpCode(0)) '程式開始的元素位置 '前端部份以中斷點填滿 For i = 0 To opIndex - 1 OpCode(i) = &HCC 'int 3 Next '--------以下開始放入所需的程式---------- '將參數push到堆疊 '由於是STDCall CALL 參數由最後一個開始放到堆疊 For i = UBound(Params) To 0 Step -1 AddByteToCode &H68 'push AddLongToCode CLng(Params(i)) '參數位址 Next i 'call hProc AddByteToCode &HE8 'call AddLongToCode hProc - VarPtr(OpCode(opIndex)) - 4 '函數位址 用call的定址 '-----------結束所需的程式-------------- '返回呼叫函數 AddByteToCode &HC2 'ret 10h AddByteToCode &H10 AddByteToCode &H0 '執行剛剛寫完的Assembly Code RunDll32NoFree = CallWindowProc(CodeStar, 0, 1, 2, 3) 'FreeLibrary hModule '釋放模組 End Function Public Function rundll32(LibFileName As String, ProcName As String, ParamArray Params()) As Long Dim hProc As Long Dim hModule As Long Dim i As Long, CodeStar As Long ReDim OpCode(400 + 6 * UBound(Params)) '保留用來寫OPCODE '讀取模組 hModule = LoadLibrary(ByVal LibFileName) If hModule = 0 Then MsgBox "Library讀取失敗" Exit Function End If '取得函數位址 hProc = GetProcAddress(hModule, ByVal ProcName) If hProc = 0 Then MsgBox "函數讀取失敗", vbCritical FreeLibrary hModule Exit Function End If '---以下為Assembly-- '程式起始位址必須是16的倍數 CodeStar = (VarPtr(OpCode(0)) Or &HF) + 1 opIndex = CodeStar - VarPtr(OpCode(0)) '程式開始的元素位置 '前端部份以中斷點填滿 For i = 0 To opIndex - 1 OpCode(i) = &HCC 'int 3 Next '--------以下開始放入所需的程式---------- '將參數push到堆疊 '由於是STDCall CALL 參數由最後一個開始放到堆疊 For i = UBound(Params) To 0 Step -1 AddByteToCode &H68 'push AddLongToCode CLng(Params(i)) '參數位址 Next i 'call hProc AddByteToCode &H68 '// push AddLongToCode VarPtr(OpCode(opIndex)) + 5 + 4 + 5 '// add 5 bytes AddByteToCode &H8B AddByteToCode &HFF '// mov edi,edi AddByteToCode &H55 '// push ebp AddByteToCode &H8B AddByteToCode &HEC '// mov ebp,esp AddByteToCode &HE9 AddLongToCode hProc - VarPtr(OpCode(opIndex)) + 1 '函數位址 用call的定址 'AddByteToCode &HE8 'call 'AddLongToCode hProc - VarPtr(OpCode(opIndex)) - 4 '函數位址 用call的定址 '-----------結束所需的程式-------------- '返回呼叫函數 AddByteToCode &HC2 'ret 10h AddByteToCode &H10 AddByteToCode &H0 '執行剛剛寫完的Assembly Code rundll32 = CallWindowProc(CodeStar, 0, 1, 2, 3) FreeLibrary hModule '釋放模組 End Function Public Function RunDll32Add5(LibFileName As String, ProcName As String, ParamArray Params()) As Long Dim hProc As Long Dim hModule As Long Dim i As Long, CodeStar As Long ReDim OpCode(400 + 6 * UBound(Params)) '保留用來寫OPCODE '讀取模組 hModule = LoadLibrary(ByVal LibFileName) If hModule = 0 Then MsgBox "Library讀取失敗" Exit Function End If '取得函數位址 hProc = GetProcAddress(hModule, ByVal ProcName) If hProc = 0 Then MsgBox "函數讀取失敗", vbCritical FreeLibrary hModule Exit Function End If '---以下為Assembly-- '程式起始位址必須是16的倍數 CodeStar = (VarPtr(OpCode(0)) Or &HF) + 1 opIndex = CodeStar - VarPtr(OpCode(0)) '程式開始的元素位置 '前端部份以中斷點填滿 For i = 0 To opIndex - 1 OpCode(i) = &HCC 'int 3 Next '--------以下開始放入所需的程式---------- '將參數push到堆疊 '由於是STDCall CALL 參數由最後一個開始放到堆疊 For i = UBound(Params) To 0 Step -1 AddByteToCode &H68 'push AddLongToCode CLng(Params(i)) '參數位址 Next i 'call hProc AddByteToCode &H68 '// push AddLongToCode VarPtr(OpCode(opIndex)) + 5 + 4 + 5 '// add 5 bytes AddByteToCode &H8B AddByteToCode &HFF '// mov edi,edi AddByteToCode &H55 '// push ebp AddByteToCode &H8B AddByteToCode &HEC '// mov ebp,esp AddByteToCode &HE9 AddLongToCode hProc - VarPtr(OpCode(opIndex)) + 1 '函數位址 用call的定址 'AddByteToCode &HE8 'call 'AddLongToCode hProc - VarPtr(OpCode(opIndex)) - 4 '函數位址 用call的定址 '-----------結束所需的程式-------------- '返回呼叫函數 AddByteToCode &HC2 'ret 10h AddByteToCode &H10 AddByteToCode &H0 '執行剛剛寫完的Assembly Code RunDll32Add5 = CallWindowProc(CodeStar, 0, 1, 2, 3) FreeLibrary hModule '釋放模組 End Function
Module1.bas:一些雜亂的副程式、函數:加密法、按鍵判斷、Ini 設定檔讀寫...
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long Public Sub SetKey(Text As TextBox, KeyCode As Integer) Select Case KeyCode Case 16 Text = "Shift" Case 17 Text = "Ctrl" Case 18 Text = "Alt" Case 33 Text = "PageUp" Case 34 Text = "PageDown" Case 35 Text = "End" Case 36 Text = "Home" Case 38 Text = "Up" Case 40 Text = "Down" Case 45 Text = "Insert" Case 46 Text = "Delete" Case 48 To 57 Text = Chr(KeyCode) Case 65 To 90 Text = Chr(KeyCode) Case Else Text = "None" End Select End Sub Public Sub Delay(ByVal Sec As Single) Dim sgnThisTime As Single, sgnCount As Single sgnThisTime = Timer Do While sgnCount < Sec sgnCount = Timer - sgnThisTime DoEvents Loop End Sub Public Sub WriteIniString(ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) Call WritePrivateProfileString(lpApplicationName, lpKeyName, lpString, App.Path & "\Setting.ini") End Sub Public Function ReadIniString(ByVal lpApplicationName, ByVal lpKeyName As String) As String Dim Out As String * 50 GetPrivateProfileString lpApplicationName, lpKeyName, "按鍵設定", Out, 50, App.Path & "\Setting.ini" ReadIniString = Out End Function Public Function ReadIniInt(ByVal lpApplicationName, ByVal lpKeyName As String) As Integer ReadIniInt = GetPrivateProfileInt(lpApplicationName, lpKeyName, 100, App.Path & "\Setting.ini") End Function Public Function ReadData(ByVal lpApplicationName, ByVal lpKeyName As String) As String Dim Out As String * 50 GetPrivateProfileString lpApplicationName, lpKeyName, 0, Out, 50, App.Path & "\Data.ini" ReadData = Out End Function Public Sub SaveAccount(ByVal lpUserName As String, ByVal lpPassword As String, ByVal lpFileName As String) Call WritePrivateProfileString("Account", "User", Encryption(lpUserName), App.Path & "\Account\" & lpFileName & ".ini") Call WritePrivateProfileString("Account", "Pass", Encryption(lpPassword), App.Path & "\Account\" & lpFileName & ".ini") End Sub Public Function ReadUserName(ByVal lpFileName As String) As String Dim UserName As String * 50 GetPrivateProfileString "Account", "User", Chr(0), UserName, 50, App.Path & "\Account\" & lpFileName ReadUserName = Decryption(UserName) End Function Public Function ReadPassword(ByVal lpFileName As String) As String Dim UserName As String * 50 GetPrivateProfileString "Account", "Pass", Chr(0), UserName, 50, App.Path & "\Account\" & lpFileName ReadPassword = Decryption(UserName) End Function '加密函數 Public Function Encryption(str As String, Optional ByVal pwd As String = "KNowlet3389") As String Dim cipher_text As String Const MIN_ASC = 32 ' Const MAX_ASC = 126 ' ~. Const NUM_ASC = MAX_ASC - MIN_ASC + 1 Dim offset As Long Dim str_len As Integer Dim i As Integer Dim ch As Integer offset = NumericPassword(pwd) Rnd -1 Randomize offset str_len = Len(str) For i = 1 To str_len ch = Asc(Mid$(str, i, 1)) If ch >= MIN_ASC And ch <= MAX_ASC Then ch = ch - MIN_ASC offset = Int((NUM_ASC + 1) * Rnd) ch = ((ch + offset) Mod NUM_ASC) ch = ch + MIN_ASC cipher_text = cipher_text & Chr$(ch) End If Next i Encryption = cipher_text End Function '解密函數 Public Function Decryption(str As String, Optional ByVal pwd As String = "KNowlet3389") As String Dim plain_text As String Const MIN_ASC = 32 ' Space. Const MAX_ASC = 126 ' ~. Const NUM_ASC = MAX_ASC - MIN_ASC + 1 Dim offset As Long Dim str_len As Integer Dim i As Integer Dim ch As Integer offset = NumericPassword(pwd) Rnd -1 Randomize offset str_len = Len(str) For i = 1 To str_len ch = Asc(Mid$(str, i, 1)) If ch >= MIN_ASC And ch <= MAX_ASC Then ch = ch - MIN_ASC offset = Int((NUM_ASC + 1) * Rnd) ch = ((ch - offset) Mod NUM_ASC) If ch < 0 Then ch = ch + NUM_ASC ch = ch + MIN_ASC plain_text = plain_text & Chr$(ch) End If Next i Decryption = plain_text End Function Private Function NumericPassword(ByVal Password As String) As Long Dim value As Long Dim ch As Long Dim shift1 As Long Dim shift2 As Long Dim i As Integer Dim str_len As Integer str_len = Len(Password) For i = 1 To str_len ch = Asc(Mid$(Password, i, 1)) value = value Xor (ch * 2 ^ shift1) value = value Xor (ch * 2 ^ shift2) shift1 = (shift1 + 7) Mod 19 shift2 = (shift2 + 13) Mod 23 Next i NumericPassword = value End Function不知道有沒有漏貼什麼,總之專案點此下載:Google
歡迎有需要者拿去參考,可是不要名字改一改拿去賣之類的喔 XD
學程式設計這條路是非常艱辛...
回覆刪除本人我也僅是個業餘...
看蔥大一路下來的過程...
真的感到佩服^_^
我也不是專業阿,謝謝支持 :)
刪除大大 您的樂豆搜尋帳號列表搜尋不到喔 <(_ _)>
回覆刪除這就是我說得奇怪 Bug 之一,在我換了新版的取得方式之後,有些電腦不知道是不是因為 IE 的關係,居然會無法順利取得帳號...
刪除因該是程式碼問題巴 ~.~ 我跟我朋友都無法取得
刪除本專案為開源,如果認為是程式碼問題請把問題部份提出來,或者你可以考慮提供你的系統環境讓我做測試。就像我說的,這程式本人在兩台電腦編譯、測試、取得帳號、啟動遊戲都是沒有問題的,那問題我也遇過,但我目前無法把問題重現出來,所以看你是要自己 debug 獲這你把電腦借我 de
刪除站長~
回覆刪除請問你的code這段是如何用的@@
我怎都用不出來....
編輯 Html 加入一段 CSS 才可以用喔,詳細請看
刪除fly2sky999.blogspot.tw/2012/03/blogger-css-block-google-code-prettify.html
恩恩 謝謝 !!!
刪除對我這這些不會地來說 已經是很厲害了
回覆刪除感謝大大的分享
站長您好
回覆刪除我目前正學習Java和C# java已經考到了 SE 得證照了 所以這兩個物件導向都還算蠻熟了 還在專研中
現在想說 難得學了這些 當年覺得高攀不起的外掛這些希望能嘗試看看
但現在苦於不知該從何處開始下手
我對外掛的了解大概只知道他是 改封包數據這些
可以詳細一點說明一下 外掛的原理嗎
讓我可以有個頭開始努力
簡單來說外怪有改封包(傳或者攔截修改)或者修改本地記憶體(造成不同的運算結果)如果你要入門,現在的資源比較少了,你可以看你對封包還是組與比較有趣雖然是都要會拉 XD
刪除那麼想請問一下站長 這你這樣說的話 您的洋蔥算是改封包的嗎
刪除封包的攔截和修改要如何達成 您是另外用工具攔截和修改的嗎 還世也是自己重新手寫一個程式
還有 那注入DLL DLL據我寫程式所知應該是動太函式庫吧 這又是什麼回事呢
可以得話希望有站長的聯絡方式 EMAIL之類的
放暑假沒事作 希望可以努力看看 但網路上這方面資源真的不多
除了原文英文的 但那我實在無法 所以希望可以多請教您
楓之谷洋蔥其實並沒有做什麼,這隻程式其實很簡單,只是負責把別人的數據寫入到楓之谷的記憶體裡面去
刪除並沒有修改封包,也沒有什麼深奧的程式碼
要攔截封包可以直接撈(Wireshark、MapleShark 等等)或者 Hook 遊戲收發封包的函數
注入 DLL,其實就只是讓遊戲加載我們所寫的 DLL 而已,那如果你 DLL 有設計界面(Form)那就可以另外建立執行序去顯示,不然你要顯示 Console 界面也是可以
聯絡方式請參考 http://knowlet3389.blogspot.tw/p/blog-page_17.html
不知道大大能不能組一個小團
刪除讓想學習的人幫你做一些你不想做的無聊工作,藉此吸一點趴
多無聊多基本的工作都願意
可以貼Vb.net的原碼嗎?
回覆刪除洋蔥並無 .net 版本,不過你可以參考 cheatbox
刪除http://knowlet3389.blogspot.tw/2014/06/vb.html
好的 那我問一下大大哦
刪除風谷更新 CE不能DBG了嗎?
因為我CE一直被偵測
恩 想請教蔥大一個問題@@
回覆刪除因為有很長一段時間沒碰MS了
發現有DLL注入然後才把GUI顯示出來
跟普通寫成EXE開啟直接鎖定會有差嗎?@@?
有差,一個是 MapleStory.exe 一個是你自己的處理程序
刪除