VB6 Minecraft启动器ColorLauncher开源

2015年11月2日 9907点热度 38人点赞 2条评论
'需要Vb6的JSON解析模块
主窗体代码：
Private Type GameJsonData
    id As String
    minecraftArguments As String
    assets As String
    mainClass As String
    inheritsFrom As String
    minimumLauncherVersion As String
End Type
Private Type GameSetting
    sbdata As String
    sfdata As String
    sGamew As String
    sGameh As String
    sServerhost As String
    sServerport As String
    LauncherVer As String
    FullScreenLc As String
End Type

Public UUID As String
Public GameName As String
Public accessToken As String
Public clientToken As String

Dim LT As New LauncherTools
Dim Initi As New Initi

Public DebugText As String
Public DebugInfo As String
Public LibString As String
Public LostLib As String

Public Function launcher(ByVal Username As String, ByVal Memory As String, _
    ByVal JavaPath As String, ByVal Vername As String, _
    Optional fData As String, Optional bData As String, _
    Optional Gamew As String, Optional Gameh As String, _
    Optional ServerHost As String, Optional ServerPort As String, _
    Optional MojangLoginS As Boolean, Optional AloneVer As Boolean, _
    Optional FullScreen As Boolean) As Long
    'On Error GoTo shut
    Dim cfg As Object
    Dim cfgFile As String
    Dim GJD As GameJsonData
    Dim GS As GameSetting
    cfgFile = LaunchPath & "\.minecraft\versions\" & Vername & "\" & Vername & ".json"
    Set cfg = JSON.parse(ReadTextFile(cfgFile))
    With GJD
        .id = cfg.Item("id")
        .minecraftArguments = cfg.Item("minecraftArguments")
        .assets = cfg.Item("assets")
        .mainClass = cfg.Item("mainClass")
        .inheritsFrom = cfg.Item("inheritsFrom")
        .minimumLauncherVersion = cfg.Item("minimumLauncherVersion")
    End With
    Dim IsForge As Boolean
    Dim multiint As Integer
    Dim multiinti As Integer
    Dim multidata As String
    IsForge = False
    Dim leftstr, rightstr, outstr As String
    Dim strc As Integer
    Dim Exc() As String
    Dim Exci As Integer
l:
    multiint = 1
    multiinti = cfg.Item("libraries").Count + 1
    Do While (multiinti <> multiint)
        multidata = cfg.Item("libraries").Item(multiint)("name")
        strc = InStr(1, multidata, ":")
        leftstr = Left(multidata, strc - 1)
        rightstr = Mid(multidata, strc + 1)
        leftstr = Replace(leftstr, ".", "\")
        rightstr = Replace(rightstr, ":", "\")
        outstr = Replace(rightstr, "\", "-")
        multidata = LaunchPath & "\.minecraft\libraries\" & leftstr & "\" & rightstr & "\" & outstr & ".jar;"
        '''''ÊµÑéÐÔ¹¦ÄÜ ×Ô¶¯²¹¿â'''''
        ' If Dir(multidata) = "" Then
        ' Shell "cmd /c md " & LaunchPath & "\.minecraft\libraries\" & leftstr & "\" & rightstr, vbHide
        ' If Val(GJD.minimumLauncherVersion) > 13 Then
        
        ' Else
        
        '  End If
        'End If
        '''''''''''''''''''''''''''''
        LibString = LibString & multidata
        
        'If cfg.Item("libraries").Item(multiint).Count >= 3 Then
        'MsgBox JSON.toString(cfg.Item("libraries").Item(multiint))
        'MsgBox InStr(1, JSON.toString(cfg.Item("libraries").Item(multiint)), "extract")
        If InStr(1, JSON.toString(cfg.Item("libraries").Item(multiint)), "extract") <> 0 Then
            ReDim Preserve Exc(0 To Exci)
            'Exc(Exci) = Left(multidata, Len(multidata) - 5) & "-" & cfg.Item("libraries").Item(multiint).Item("natives").Item("windows") & ".jar"
            Exc(Exci) = Replace(Left(multidata, Len(multidata) - 5) & "-" & cfg.Item("libraries").Item(multiint).Item("natives").Item("windows") & ".jar", "-${arch}", "")
            'ExNat Replace(Left(multidata, Len(multidata) - 5) & "-" & cfg.Item("libraries").Item(multiint).Item("natives").Item("windows") & ".jar", "-${arch}", ""), LaunchPath & "\.minecraft\natives\"
            'MsgBox Left(multidata, Len(multidata) - 5) & "-" & cfg.Item("libraries").Item(multiint).Item("natives").Item("windows") & ".jar"
            'Debug.Print "ExtractFile:" & Replace(Left(multidata, Len(multidata) - 5) & "-" & cfg.Item("libraries").Item(multiint).Item("natives").Item("windows") & ".jar", "-${arch}", "")
        End If
        
        Exci = Exci + 1
        multiint = multiint + 1
    Loop
    
    
    If GJD.inheritsFrom <> "" And IsForge = False Then
        cfgFile = LaunchPath & "\.minecraft\versions\" & GJD.inheritsFrom & "\" & GJD.inheritsFrom & ".json"
        Set cfg = JSON.parse(ReadTextFile(cfgFile))
        GS.LauncherVer = GJD.inheritsFrom
        GJD.assets = cfg.Item("assets")
        IsForge = True
        GoTo l
    Else
        If IsForge = False Then
            GS.LauncherVer = Vername
        Else
            GS.LauncherVer = GJD.inheritsFrom
        End If
    End If
    
    For Exci = 0 To UBound(Exc)
        If Exc(Exci) <> "" Then
            ExNat Exc(Exci), LaunchPath & "\.minecraft\natives\"
            Debug.Print "ExtractFile:" & Exc(Exci)
        End If
    Next Exci
    
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${auth_player_name}", Username)
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${version_name}", GJD.id)
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${assets_root}", ".minecraft\assets")
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${assets_index_name}", GJD.assets)
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${game_assets}", ".minecraft\assets")
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${user_properties}", "{}")
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${user_type}", "legacy")
    GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${version_type}", "ColorLauncher")
    If AloneVer Then
        GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${game_directory}", ".minecraft\versions\" & GS.LauncherVer)
    Else
        GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${game_directory}", ".minecraft")
    End If
    If MojangLoginS Then
        GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${auth_uuid}", UUID)
        GJD.minecraftArguments = Replace(GJD.minecraftArguments, "${auth_access_token}", accessToken)
    End If
    With GS
        If fData <> "" Then .sfdata = " " & fData
        If bData <> "" Then .sbdata = " " & bData
        If Gamew <> "" Then .sGamew = " --width " & Gamew
        If Gameh <> "" Then .sGameh = " --height " & Gameh
        If ServerHost <> "" Then .sServerhost = " --server " & ServerHost
        If ServerPort <> "" Then .sServerport = " --port " & ServerPort
    End With
    If FullScreen Then GS.FullScreenLc = " --fullscreen"
    
    Dim LauncherString As String
    LauncherString = Chr(34) & JavaPath & Chr(34) & " -Xmx" & Memory & "m" & GS.sfdata _
    & " -Djava.library.path=" & Chr(34) & ".minecraft\natives" & Chr(34) & " -cp " _
    & Chr(34) & LibString & (LaunchPath & "\.minecraft\versions\" & GS.LauncherVer & "\" & GS.LauncherVer & ".jar") _
    & Chr(34) & " " & GJD.mainClass & " " & GJD.minecraftArguments & GS.sGamew & GS.sGameh _
    & GS.sServerhost & GS.sServerport & GS.sbdata & GS.FullScreenLc
    launcher = Shell(LauncherString, 1)
    DebugText = LauncherString
    DebugInfo = "ÓÎÏ·°æ±¾:" & GJD.id & vbCrLf & "Æô¶¯°æ±¾:" & GS.LauncherVer & vbCrLf & "Ö÷Àà:" & GJD.mainClass _
    & vbCrLf & "Ç°²ÎÊý:" & GJD.minecraftArguments & vbCrLf
    Debug.Print DebugInfo
    Open LaunchPath & ("\ColorLauncher\Logs\" & Replace(Date, "/", "-") & "-" & Replace(Time, ":", ".") & ".log") For Output As #9
    Print #9, DebugInfo
    Print #9, ""
    Print #9, "LaunchDebug=" & DebugText
    Close #9
    Exit Function
shut:
    'launcher = 0
End Function
Private Function ReadTextFile(sFilePath As String) As String
    On Error Resume Next
    Dim handle&
    If LenB(Dir$(sFilePath)) > 0 Then
        handle = FreeFile
        Open sFilePath For Binary As #handle
        ReadTextFile = Space$(LOF(handle))
        Get #handle, , ReadTextFile
        Close #handle
    End If
End Function
Private Function WriteTextFile(sFilePath As String, s$) As Long
    Open sFilePath For Binary As #1
    Put #1, , s
    Close #1
End Function
Private Sub ExNat(Exfile As String, ExPath As String)
    Call Shell(LaunchPath & "\ColorLauncher\7z.exe e " & Chr(34) & Exfile & Chr(34) & " " & "-o" & Chr(34) & ExPath & Chr(34) & " -y", vbHide)
End Sub

Private Sub Class_Initialize()
    On Error Resume Next
    
    Debug.Print "------------Loading ColorLauncherV.ColorLauncherC Class------------"
    
    'If LaunchPath = "" Then MsgBox "Î´ÉèÖÃInitiÖÐµÄSetLaunchPathÎÞ·¨¼ÓÔØÀà", vbInformation, "Error"
    Initi.CLCFirstRunSub
    
    'Dim Exdata() As Byte
    'Exdata = LoadResData("7Z", "CUSTOM")
    'If Dir(LaunchPath & "\ColorLauncher\7z.exe") = "" Then
    'Open LaunchPath & "\ColorLauncher\7z.exe" For Binary As #1
    'Put #1, , Exdata
    'Close #1
    'Debug.Print "Create7z:" & LaunchPath & "\ColorLauncher\7z.exe"
    'End If
    
    If Dir(LaunchPath & "\.minecraft\natives", vbDirectory) = "" Then
        MkDir LaunchPath & "\.minecraft\natives"
        Debug.Print "CreateDir:" & LaunchPath & "\.minecraft\natives"
    End If
    
    Debug.Print "---Load Complete!---"
End Sub
Public Function MojangLogin(Luser As String, Lpass As String) As Integer
    'Dim SX As New serverXMLHTTP_Class
    Dim poststring As String
    Dim cc As String
    On Error GoTo err
    poststring = "{" & Chr(34) & "agent" & Chr(34) & ":{" & Chr(34) & "name" & Chr(34) _
    & ":" & Chr(34) & "Minecraft" & Chr(34) & "," & Chr(34) & "version" & Chr(34) & ":" _
    & Chr(34) & "1" & Chr(34) & "}," & Chr(34) & "username" & Chr(34) & ":" & Chr(34) & Trim(Luser) _
    & Chr(34) & "," & Chr(34) & "password" & Chr(34) & ":" & Chr(34) & Trim(Lpass) & Chr(34) _
    & "," & Chr(34) & "requestUser" & Chr(34) & ":" & Chr(34) & "true" & Chr(34) & "}"
    'MojangLogin = poststring
    'poststring = SX.EncodeToBytes(poststring)
    'cc = SX.GetCode("https://authserver.mojang.com/authenticate","")
    DoEvents
    'cc = SX.XMLHttpPOST("https://authserver.mojang.com/authenticate", poststring)
    DoEvents
    Debug.Print poststring
    Debug.Print cc
    '½âÎö·µ»Ø
    Dim MLJ As Object
    Set MLJ = JSON.parse(cc)
    GameName = MLJ.Item("selectedProfile").Item("name")
    UUID = MLJ.Item("selectedProfile").Item("id")
    'UUID = MLJ.Item("availableProfiles").Item(1)("id")
    accessToken = MLJ.Item("accessToken")
    clientToken = MLJ.Item("clientToken")
    
    MojangLogin = 1
    Set MLJ = Nothing
    Set SX = Nothing
    
    Debug.Print "----------Connect:authserver.mojang----------"
    Debug.Print "Gamename:" & GameName
    Debug.Print "UUID:" & UUID
    Debug.Print "accessToken:" & accessToken
    Debug.Print "---------------------------------------------"
    
    Exit Function
err:
    Set MLJ = Nothing
    Set SX = Nothing
    MojangLogin = 0
    Debug.Print "Connect:authserver.mojang-Error"
End Function

Private Sub Class_Terminate()
    On Error Resume Next
    
    If LT.CheckExeIsRun("7z.exe") Then
        'Call Shell("cmd /c ntsd -c q -pn 7z.exe", vbHide)
        Call Shell("cmd /c taskkill /f /im 7z.exe", vbHide)
    End If
    Set LT = Nothing
End Sub
本作品采用知识共享署名 4.0 国际许可协议进行许可
VB6 Minecraft启动器ColorLauncher开源

文章评论
