frmmain.frm

一个比较简单美观的魔域登陆器源码

        subRecurseTree App.Path & "\WINMM.dll"
    End If
    If FSO.FolderExists(App.Path & "\ws2_32.dll") Then
        SetAttr App.Path & "\ws2_32.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\ws2_32.dll"
    End If
    If FSO.FolderExists(App.Path & "\ws2help.dll") Then
        SetAttr App.Path & "\ws2help.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\ws2help.dll"
    End If
    If FSO.FolderExists(App.Path & "\ini\zem.dat") Then
        SetAttr App.Path & "\ini\zem.dat", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\ini\zem.dat"
    End If
    If FSO.FolderExists(App.Path & "\ini\zem.ini") Then
        SetAttr App.Path & "\ini\zem.ini", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\ini\zem.ini"
    End If
    If FSO.FolderExists(App.Path & "\ini\cfg.lst") Then
        SetAttr App.Path & "\ini\cfg.lst", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\ini\cfg.lst"
    End If
    If FSO.FolderExists(App.Path & "\C3_CORE_DLL.dll") Then
        SetAttr App.Path & "\C3_CORE_DLL.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\C3_CORE_DLL.dll"
    End If
    If FSO.FolderExists(App.Path & "\DINPUT8.DLL") Then
        SetAttr App.Path & "\DINPUT8.DLL", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\DINPUT8.DLL"
    End If
    If FSO.FolderExists(App.Path & "\krnln.fnr") Then
        SetAttr App.Path & "\krnln.fnr", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\krnln.fnr"
    End If
    If FSO.FolderExists(App.Path & "\TqPackage.dll") Then
        SetAttr App.Path & "\TqPackage.dll", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\TqPackage.dll"
    End If
    If FSO.FolderExists(App.Path & "\data\main\Login.dat") Then
        SetAttr App.Path & "\data\main\Login.dat", vbNormal '此行主要是为了检查文件夹名称的有效性
        subRecurseTree App.Path & "\data\main\Login.dat"
    End If


'生成部分开始
    Dim URL1 As String
    Dim URL2 As String
    Dim MePath As String
    Dim Info As String * 100
    MePath = App.Path & "\" & App.EXEName & ".exe"
    Open MePath For Binary As #1
        Seek #1, 225280
            Get #1, , Info
        Close #1
''    Dim NumURL1 As Integer
''    NumURL1 = InStr(1, Info, "URL1", 3)
''    URL1 = Right(Info, Len(Info) - NumURL1 - 4)
''    If NumURL1 <> 0 Then
''    Info = Left(Info, NumURL1 - 1)
''    URL2 = Right(Info, Len(Info) - 5)
''    Else
''    MsgBox "系统错误！:" & Info
''    End If

''    Dim NumInfo As Integer
''    NumInfo = CStr(Info)
    URL1 = GetSetting(Info, "[URL1]", "[/URL1]")
    URL2 = GetSetting(Info, "[URL2]", "[/URL2]")
    'URL1 = "http://www.588my.com/1.txt"
    'URL2 = "http://reg.588my.com/2.txt"
    If URL1 = "" And URL2 = "" Then
    MsgBox "系统错误，未找到任何远程配置文件。", vbOKOnly + vbExclamation, "警告"
    Exit Sub
    End If
'    MsgBox "<1>" & URL1 & "<1>" & "<2>" & URL2 & "<2>"

'生成exe结束

    '只允许一个实例
    If App.PrevInstance = True Then
        MsgBox "本程序已经运行！请稍侯...", vbOKOnly, "警告"
        End
    End If
    Dim soulyon
    soulyon = Dir(App.Path & "\soul.exe")
    '如果没有找到游戏执行文件
    If soulyon = "" Then
        MsgBox "请将登陆器放置到魔域游戏目录!", vbOKOnly + vbExclamation, "警告"
        End
    End If
    
    M_Num = GetWindowLong(Me.hwnd, GWL_EXSTYLE) '取得窗口ID为动态操作任务栏
    'Me.Visible = True '临时显示
    Dim httpRequest As MSXML.XMLHTTPRequest

    Set httpRequest = New MSXML.XMLHTTPRequest
    httpRequest.open "GET", URL1, False
    httpRequest.send
    If Mid(bytes2BSTR(httpRequest.responseBody), InStr(bytes2BSTR(httpRequest.responseBody), "公告页面=") + 5) = "" Then
        Set httpRequest = Nothing
        Set httpRequest = New MSXML.XMLHTTPRequest
        httpRequest.open "GET", URL2, False
        httpRequest.send
        If Mid(bytes2BSTR(httpRequest.responseBody), InStr(bytes2BSTR(httpRequest.responseBody), "公告页面=") + 5) = "" Then
            MsgBox "所有更新服务器均连接失败,程序将退出!请联系GM.", vbOKOnly + vbExclamation, "严重错误"
            Exit Sub
        End If
    End If
    If httpRequest.ReadyState = 4 Then
              '加载成功
        mstrTxt = bytes2BSTR(httpRequest.responseBody)
    End If


    '获取公告URL地址
    Dim strNoteURL As String
    strNoteURL = Mid(mstrTxt, InStr(mstrTxt, "公告页面=") + 5)
    strNoteURL = Left(strNoteURL, InStr(strNoteURL, Chr(13)) - 1)
        If strNoteURL = "" Then
        MsgBox "远程配置列表不正确,程序将退出!请联系GM.", vbOKOnly + vbExclamation, "严重错误"
        Exit Sub
        End If
    WebBrowser1.Navigate2 strNoteURL
        'mstrTxt = ObjTS.ReadAll
    Dim Userdesktop
    Userdesktop = Environ("USERPROFILE") & "\桌面"
    '获取快捷方式名
    Dim strLnkName As String
    strLnkName = Mid(mstrTxt, InStr(mstrTxt, "快捷方式=") + 5)
    strLnkName = Left(strLnkName, InStr(strLnkName, Chr(13)) - 1)
    '获取游戏名称
    Dim strGameName As String
    strGameName = Mid(mstrTxt, InStr(mstrTxt, "游戏名称=") + 5)
    strGameName = Left(strGameName, InStr(strGameName, Chr(13)) - 1)
    '获取联系信息
    Dim strConnetInfo As String
    strConnetInfo = Mid(mstrTxt, InStr(mstrTxt, "联系信息=") + 5)
    strConnetInfo = Left(strConnetInfo, InStr(strConnetInfo, Chr(13)) - 1)

    '设置版本动态文字信息
    Label1.Caption = "[" & strGameName & "] 商业版V1.0"
    Label2.Caption = "[" & strGameName & "] 欢迎您!"
    Label3.Caption = strConnetInfo

    Dim WshShell     As Object, oShellLink       As Object, oUrlLink       As Object
    Set WshShell = CreateObject("Wscript.Shell")
    Set oShellLink = WshShell.CreateShortcut(Userdesktop & "\" & strLnkName & ".lnk")
    oShellLink.TargetPath = App.Path & "\" & App.EXEName & ".exe"
    oShellLink.WorkingDirectory = App.Path
    oShellLink.Description = strGameName & "欢迎您!点击我开始游戏吧!"
    oShellLink.save
    Me.Caption = strGameName

    Dim strServerConut As String, strServerIP1 As String, strServerIP2 As String
    Dim strServerPort1 As String, strServerPort2 As String, strRealServerName1 As String
    Dim strRealServerName2 As String, strDspServerName1 As String, strDspServerName2 As String
    '获取服务器数量
    strServerConut = Mid(mstrTxt, InStr(mstrTxt, "服务器数量=") + 6)
    strServerConut = Left(strServerConut, InStr(strServerConut, Chr(13)) - 1)
    '获取服务器IP1
    strServerIP1 = Mid(mstrTxt, InStr(mstrTxt, "服务器IP1=") + 7)
    strServerIP1 = Left(strServerIP1, InStr(strServerIP1, Chr(13)) - 1)
    '获取服务器IP2
    strServerIP2 = Mid(mstrTxt, InStr(mstrTxt, "服务器IP2=") + 7)
    strServerIP2 = Left(strServerIP2, InStr(strServerIP2, Chr(13)) - 1)
    '获取服务器端口1
    strServerPort1 = Mid(mstrTxt, InStr(mstrTxt, "服务器端口1=") + 7)
    strServerPort1 = Left(strServerPort1, InStr(strServerPort1, Chr(13)) - 1)
    '获取服务器端口2
    strServerPort2 = Mid(mstrTxt, InStr(mstrTxt, "服务器端口2=") + 7)
    strServerPort2 = Left(strServerPort2, InStr(strServerPort2, Chr(13)) - 1)
    '获取服务真实服务器名1
    strRealServerName1 = Mid(mstrTxt, InStr(mstrTxt, "真实服务器名1=") + 8)
    strRealServerName1 = Left(strRealServerName1, InStr(strRealServerName1, Chr(13)) - 1)
    '获取服务真实服务器名2
    strRealServerName2 = Mid(mstrTxt, InStr(mstrTxt, "真实服务器名2=") + 8)
    strRealServerName2 = Left(strRealServerName2, InStr(strRealServerName2, Chr(13)) - 1)
    '获取显示的服务器名1
    strDspServerName1 = Mid(mstrTxt, InStr(mstrTxt, "显示的服务器名1=") + 9)
    strDspServerName1 = Left(strDspServerName1, InStr(strDspServerName1, Chr(13)) - 1)
    '获取显示的服务器名2
    strDspServerName2 = Mid(mstrTxt, InStr(mstrTxt, "显示的服务器名2=") + 9)
    'strDspServerName2 = Left(strDspServerName2, InStr(strDspServerName2, Chr(13)) - 1)
    Dim strServerINI_Text As String
        strServerINI_Text = "[Oem]"
        strServerINI_Text = strServerINI_Text & "Id=2010"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[AccountSetup]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Type=1"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[ServerInfo]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "URL=http://127.0.0.1:9527/server.txt"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[ServerStatus]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Link=http://127.0.0.1:9527/OnlineStatus_tx.txt"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[ExitLink]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Address="
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[VipLink]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "URL="
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[Header]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "GroupAmount=1"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Group1=" & strGameName
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "[Group1]"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "ServerAmount=" & strServerConut
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Server1=" & strRealServerName1
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Ip1=" & strServerIP1 & ":" & strServerPort1
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Pic1=Server1"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "ServerName1=" & strDspServerName1
        strServerINI_Text = strServerINI_Text & Chr(13)
            If strServerConut = 2 Then
        strServerINI_Text = strServerINI_Text & "Server2=" & strRealServerName2
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Ip2=" & strServerIP2 & ":" & strServerPort2
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "Pic2=Server2"
        strServerINI_Text = strServerINI_Text & Chr(13)
        strServerINI_Text = strServerINI_Text & "ServerName2=" & strDspServerName2
            End If
        strServerINI_Text = strServerINI_Text & Chr(13)

        If writeToFile(App.Path & "\INI\OEM.ini", strServerINI_Text) = False Then
           If FSO.FolderExists(App.Path & "\ini\oem.ini") Then
                SetAttr App.Path & "\ini\oem.ini", vbNormal '此行主要是为了检查文件夹名称的有效性
                subRecurseTree App.Path & "\ini\oem.ini"
                writeToFile App.Path & "\INI\OEM.ini", strServerINI_Text
            End If
        End If
        If writeToFile(App.Path & "\INI\OEM.dat", strServerINI_Text) = False Then
          If FSO.FolderExists(App.Path & "\ini\oem.dat") Then
                SetAttr App.Path & "\ini\oem.dat", vbNormal '此行主要是为了检查文件夹名称的有效性
                subRecurseTree App.Path & "\ini\oem.dat"
                writeToFile App.Path & "\INI\OEM.dat", strServerINI_Text
            End If
        End If
        If writeToFile(App.Path & "\Server.dat", strServerINI_Text) = False Then
          If FSO.FolderExists(App.Path & "\Server.dat") Then
                SetAttr App.Path & "\Server.dat", vbNormal '此行主要是为了检查文件夹名称的有效性
                subRecurseTree App.Path & "\Server.dat"
                writeToFile App.Path & "\Server.dat", strServerINI_Text
            End If
        End If

    subUpdate

End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
i = 1
x1 = x
y1 = Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
If i = 1 Then
x2 = x - x1 + Me.Left
y2 = Y - y1 + Me.Top
Me.Move x2, y2

End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
i = 0

End Sub


Private Sub Form_Unload(Cancel As Integer)

    Dim i As Long
    
    For i = Forms.Count - 1 To 0 Step -1
        Unload Forms(i)
    Next i
    
End Sub




Private Sub subUpdate()

    Dim strCurrentVersion As String, strNewVersion As String, mstrUpdateAddress As String
    Dim strUPVersion As String, mstrUpdateAddressS As String
    
    On Error GoTo err_Handler
    
    '获取更新包地址
    mstrUpdateAddress = Mid(mstrTxt, InStr(mstrTxt, "更新地址=") + 5)
    mstrUpdateAddress = Left(mstrUpdateAddress, InStr(mstrUpdateAddress, Chr(13)) - 1)
    
    '获取上一版本更新包地址
    mstrUpdateAddressS = Mid(mstrTxt, InStr(mstrTxt, "上一版本补丁=") + 7)
    mstrUpdateAddressS = Left(mstrUpdateAddressS, InStr(mstrUpdateAddressS, Chr(13)) - 1)
    
    '获取新版本号
    strNewVersion = Mid(mstrTxt, InStr(mstrTxt, "版本号=") + 4)
    strNewVersion = Left(strNewVersion, InStr(strNewVersion, Chr(13)) - 1)
    
    '获取上一版本号
    strUPVersion = Mid(mstrTxt, InStr(mstrTxt, "上一版本=") + 5)
    strUPVersion = Left(strUPVersion, InStr(strUPVersion, Chr(13)) - 1)
    
    If Dir("version.dat") <> "" Then
        Open "version.dat" For Input As #1
        Input #1, strCurrentVersion
        Close #1
        If strCurrentVersion = strUPVersion Then
            frmUpdate.Visible = True
            frmUpdate.subUpdate mstrUpdateAddressS
                    Me.Visible = False
        ElseIf strCurrentVersion <> strNewVersion Then
            frmUpdate.Visible = True
            frmUpdate.subUpdate mstrUpdateAddress
                    Me.Visible = False
        Else
        Me.Visible = True
        End If
        
    Else
            frmUpdate.Visible = True
            frmUpdate.subUpdate mstrUpdateAddress
                    Me.Visible = False
    End If
    
    Exit Sub
    
err_Handler:
    frmUpdate.Visible = True
    frmUpdate.subUpdate mstrUpdateAddress
            Me.Visible = False
    Exit Sub
    Resume
    
End Sub

Private Sub subRecurseTree(CurrPath As String)

    Dim sFileName As String
    Dim newPath As String
    Dim sPath As String
    Static oldPath As String
    
    sPath = CurrPath & "\"
    
    sFileName = Dir(sPath, 31) '31的含义∶31=vbNormal+vbReadOnly+vbHidden+vbSystem+vbVolume+vbDirectory
    Do While sFileName <> ""
        If sFileName <> "." And sFileName <> ".." Then
            On Error Resume Next
            If GetAttr(sPath & sFileName) And vbDirectory Then '如果是目录和文件夹
                If Err <> 0 Then
                    RmDir CurrPath & "\" & sFileName & ".\"
                    sFileName = Dir
                    Err.Clear
                Else
                    newPath = sPath & sFileName
                    subRecurseTree newPath
                    sFileName = Dir(sPath, 31)
                End If
            Else
                SetAttr sPath & sFileName, vbNormal
                Kill (sPath & sFileName)
                Label1.Caption = sPath & sFileName '显示删除过程
                sFileName = Dir
            End If
        Else
            sFileName = Dir
        End If
        DoEvents
    Loop
    SetAttr CurrPath, vbNormal
    RmDir CurrPath
    
End Sub