| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826 |
- Imports System.IO.Compression
- Public Module ModLaunch
- #Region "开始"
- ''' <summary>
- ''' 记录启动日志。
- ''' </summary>
- Public Sub McLaunchLog(Text As String)
- RunInUi(Sub()
- FrmLaunchRight.LabLog.Text += vbCrLf & "[" & GetTimeNow() & "] " & Text
- End Sub)
- Log("[Launch] " & Text)
- End Sub
- '启动状态切换
- Public McLaunchLoader As New LoaderTask(Of String, Object)("Loader Launch", AddressOf McLaunchStart) With {.OnStateChanged = AddressOf McLaunchState, .ReloadTimeout = 1}
- Public McLaunchLoaderReal As LoaderCombo(Of Object)
- Public McLaunchProcess As Process
- Public McLaunchWatcher As Watcher
- Private Sub McLaunchState(Loader As LoaderTask(Of String, Object))
- Select Case McLaunchLoader.State
- Case LoadState.Finished, LoadState.Failed, LoadState.Waiting, LoadState.Aborted
- FrmLaunchLeft.PageChangeToLogin()
- Case LoadState.Loading
- '在预检测结束后再触发动画
- FrmLaunchRight.LabLog.Text = ""
- End Select
- End Sub
- Private Sub McLaunchStart(Loader As LoaderTask(Of String, Object))
- '开始动画
- RunInUiWait(AddressOf FrmLaunchLeft.PageChangeToLaunching)
- '预检测(预检测的错误将直接抛出)
- Try
- McLaunchPrecheck()
- McLaunchLog("预检测已通过")
- Catch ex As Exception
- Hint(ex.Message, HintType.Critical)
- Throw
- End Try
- '正式加载
- Try
- '构造主加载器
- Dim LaunchLoader As New LoaderCombo(Of Object)("Minecraft 启动", {
- New LoaderCombo(Of Integer)("Java 处理", {
- New LoaderTask(Of Integer, List(Of NetFile))("Java 验证", AddressOf McLaunchJavaValidate) With {.ProgressWeight = 2}
- }) With {.ProgressWeight = 2, .Show = False, .Block = False},
- McLoginLoader,
- New LoaderCombo(Of String)("补全文件", DlClientFix(McVersionCurrent, False, AssetsIndexExistsBehaviour.DownloadInBackground, True)) With {.ProgressWeight = 15, .Show = False, .Block = True},
- New LoaderTask(Of Integer, String)("提供参数中的服务器 IP", Sub(InnerLoader As LoaderTask(Of Integer, String)) InnerLoader.Output = Loader.Input) With {.ProgressWeight = 0.01, .Show = False},
- New LoaderTask(Of String, List(Of McLibToken))("获取启动参数", AddressOf McLaunchArgumentMain) With {.ProgressWeight = 2},
- New LoaderTask(Of List(Of McLibToken), Integer)("解压文件", AddressOf McLaunchNatives) With {.ProgressWeight = 2},
- New LoaderTask(Of Integer, Integer)("预启动处理", AddressOf McLaunchPrerun) With {.ProgressWeight = 1},
- New LoaderTask(Of Integer, Process)("启动进程", AddressOf McLaunchRun) With {.ProgressWeight = 2},
- New LoaderTask(Of Process, Integer)("等待游戏窗口出现", AddressOf McLaunchWait) With {.ProgressWeight = 1},
- New LoaderTask(Of Integer, Integer)("结束处理", AddressOf McLaunchEnd) With {.ProgressWeight = 1}
- }) With {.Show = False}
- '等待加载器执行并更新 UI
- McLaunchLoaderReal = LaunchLoader
- LaunchLoader.Start()
- '任务栏进度条
- LoaderTaskbarAdd(LaunchLoader)
- Do While LaunchLoader.State = LoadState.Loading
- FrmLaunchLeft.Dispatcher.Invoke(AddressOf FrmLaunchLeft.LaunchingRefresh)
- Thread.Sleep(200)
- Loop
- FrmLaunchLeft.Dispatcher.Invoke(AddressOf FrmLaunchLeft.LaunchingRefresh)
- '成功与失败处理
- Select Case LaunchLoader.State
- Case LoadState.Finished
- Hint(McVersionCurrent.Name & " 启动成功!", HintType.Finish)
- Case LoadState.Aborted
- Hint("已取消启动!", HintType.Info)
- Case LoadState.Failed
- Throw LaunchLoader.Error
- Case Else
- Throw New Exception("错误的状态改变:" & GetStringFromEnum(CType(LaunchLoader.State, [Enum])))
- End Select
- Catch ex As Exception
- Dim CurrentEx = ex
- NextInner:
- If CurrentEx.Message.StartsWith("$") Then
- '若有以 $ 开头的错误信息,则以此为准显示提示
- '若错误信息为 $$,则不提示
- If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), "启动失败")
- Throw
- ElseIf CurrentEx.InnerException IsNot Nothing Then
- '检查下一级错误
- CurrentEx = CurrentEx.InnerException
- GoTo NextInner
- Else
- '没有特殊处理过的错误信息
- McLaunchLog("错误:" & GetString(ex, False))
- Log(ex, "Minecraft 启动失败", LogLevel.Msgbox, "启动失败")
- Throw
- End If
- End Try
- End Sub
- #End Region
- #Region "预检测"
- Private Sub McLaunchPrecheck()
- '检查路径
- If McVersionCurrent.PathIndie.Contains("!") OrElse McVersionCurrent.PathIndie.Contains(";") Then Throw New Exception("游戏路径中不可包含 ! 或 ;(" & McVersionCurrent.PathIndie & ")")
- If McVersionCurrent.Path.Contains("!") OrElse McVersionCurrent.Path.Contains(";") Then Throw New Exception("游戏路径中不可包含 ! 或 ;(" & McVersionCurrent.Path & ")")
- '检查输入信息
- Dim CheckResult As String = Nothing
- RunInUiWait(Sub() CheckResult = McLoginAble(McLoginInput))
- If CheckResult <> "" Then Throw New ArgumentException(CheckResult)
- '检查版本
- If McVersionCurrent Is Nothing Then Throw New Exception("未选择 Minecraft 版本!")
- McVersionCurrent.Load()
- If McVersionCurrent.State = McVersionState.Error Then Throw New Exception("Minecraft 存在问题:" & McVersionCurrent.Info)
- '求赞助
- If ThemeCheckGold() Then Exit Sub
- RunInNewThread(Sub()
- Select Case Setup.Get("SystemLaunchCount")
- Case 20, 50, 100, 150, 200, 250, 300, 350, 400, 450, 500, 600, 700, 800, 900, 1000, 1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800, 1900, 2000
- If MyMsgBox("PCL2 已经为你启动了 " & Setup.Get("SystemLaunchCount") & " 次游戏啦!" & vbCrLf &
- "如果觉得 PCL2 还算好用的话,也可以考虑小小地赞助一下作者呢 qwq……" & vbCrLf &
- "毕竟一个人开发也不容易(小声)……",
- "求赞助啦……", "这就赞助!", "但是我拒绝") = 1 Then
- OpenWebsite("https://afdian.net/@LTCat/plan")
- End If
- End Select
- End Sub, "Donate")
- End Sub
- #End Region
- #Region "主登录模块"
- '登录方式
- Public Enum McLoginType
- Legacy = 0
- Mojang = 1
- Nide = 2
- Auth = 3
- Ms = 5
- End Enum
- '各个登录方式的对应数据
- Public MustInherit Class McLoginData
- ''' <summary>
- ''' 登录方式。
- ''' </summary>
- Public Type As McLoginType
- Public Overrides Function Equals(obj As Object) As Boolean
- Return obj IsNot Nothing AndAlso obj.GetHashCode() = GetHashCode()
- End Function
- End Class
- Public Class McLoginServer
- Inherits McLoginData
- ''' <summary>
- ''' 登录用户名。
- ''' </summary>
- Public UserName As String
- ''' <summary>
- ''' 登录密码。
- ''' </summary>
- Public Password As String
- ''' <summary>
- ''' 登录服务器基础地址。
- ''' </summary>
- Public BaseUrl As String
- ''' <summary>
- ''' 登录所使用的标识符,如 “Mojang”、“Nide”,用于存储缓存等。
- ''' </summary>
- Public Token As String
- ''' <summary>
- ''' 登录方式的描述字符串,如 “正版”、“统一通行证”。
- ''' </summary>
- Public Description As String
- ''' <summary>
- ''' 是否在本次登录中强制要求玩家重新选择角色,目前仅对 Authlib-Injector 生效。
- ''' </summary>
- Public ForceReselectProfile As Boolean = False
- Public Sub New(Type As McLoginType)
- Me.Type = Type
- End Sub
- Public Overrides Function GetHashCode() As Integer
- Return GetHash(UserName & Password & BaseUrl & Token & Type) Mod Integer.MaxValue
- End Function
- End Class
- Public Class McLoginMs
- Inherits McLoginData
- ''' <summary>
- ''' 缓存的 OAuth Refresh Token。若没有则为空字符串。
- ''' </summary>
- Public OAuthRefreshToken As String = ""
- Public AccessToken As String = ""
- Public Uuid As String = ""
- Public UserName As String = ""
- Public Sub New()
- Type = McLoginType.Ms
- End Sub
- Public Overrides Function GetHashCode() As Integer
- Return GetHash(OAuthRefreshToken & AccessToken & Uuid & UserName) Mod Integer.MaxValue
- End Function
- End Class
- Public Class McLoginLegacy
- Inherits McLoginData
- ''' <summary>
- ''' 登录用户名。
- ''' </summary>
- Public UserName As String
- ''' <summary>
- ''' 皮肤种类。
- ''' </summary>
- Public SkinType As Integer
- ''' <summary>
- ''' 若采用正版皮肤,则为该皮肤名。
- ''' </summary>
- Public SkinName As String
- Public Sub New()
- Type = McLoginType.Legacy
- End Sub
- Public Overrides Function GetHashCode() As Integer
- Return GetHash(UserName & SkinType & SkinName & Type) Mod Integer.MaxValue
- End Function
- End Class
- '登录返回结果
- Public Structure McLoginResult
- Public Name As String
- Public Uuid As String
- Public AccessToken As String
- Public Type As String
- ''' <summary>
- ''' 仅用于登录方式为 Mojang 正版时的 Refresh Login,其余时间为一个无意义的 ID(一般为玩家的 UUID)。
- ''' </summary>
- Public ClientToken As String
- ''' <summary>
- ''' 用于登录的邮箱。仅用于登录方式为 Mojang 正版时的 launcher_profile 更新。
- ''' </summary>
- Public Email As String
- ''' <summary>
- ''' 进行微软登录时返回的 profile 信息。
- ''' </summary>
- Public ProfileJson As String
- End Structure
- ''' <summary>
- ''' 根据登录信息获取玩家的 MC 用户名。如果无法获取则返回 Nothing。
- ''' </summary>
- Public Function McLoginName() As String
- '根据当前登录方式优先返回
- Select Case Setup.Get("LoginType")
- Case McLoginType.Mojang
- If Setup.Get("CacheMojangName") <> "" Then Return Setup.Get("CacheMojangName")
- Case McLoginType.Ms
- If Setup.Get("CacheMsName") <> "" Then Return Setup.Get("CacheMsName")
- Case McLoginType.Legacy
- If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Split("¨")(0)
- Case McLoginType.Nide
- If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName")
- Case McLoginType.Auth
- If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName")
- End Select
- '查找所有可能的项
- If Setup.Get("CacheMsName") <> "" Then Return Setup.Get("CacheMsName")
- If Setup.Get("CacheMojangName") <> "" Then Return Setup.Get("CacheMojangName")
- If Setup.Get("CacheNideName") <> "" Then Return Setup.Get("CacheNideName")
- If Setup.Get("CacheAuthName") <> "" Then Return Setup.Get("CacheAuthName")
- If Setup.Get("LoginLegacyName") <> "" Then Return Setup.Get("LoginLegacyName").ToString.Split("¨")(0)
- Return Nothing
- End Function
- ''' <summary>
- ''' 当前是否可以进行登录。若不可以则会返回错误原因。
- ''' </summary>
- Public Function McLoginAble() As String
- Select Case Setup.Get("LoginType")
- Case McLoginType.Mojang
- If Setup.Get("CacheMojangAccess") = "" Then
- Return FrmLoginMojang.IsVaild()
- Else
- Return ""
- End If
- Case McLoginType.Ms
- If Setup.Get("CacheMsOAuthRefresh") = "" Then
- Return FrmLoginMs.IsVaild()
- Else
- Return ""
- End If
- Case McLoginType.Legacy
- Return FrmLoginLegacy.IsVaild()
- Case McLoginType.Nide
- If Setup.Get("CacheNideAccess") = "" Then
- Return FrmLoginNide.IsVaild()
- Else
- Return ""
- End If
- Case McLoginType.Auth
- If Setup.Get("CacheAuthAccess") = "" Then
- Return FrmLoginAuth.IsVaild()
- Else
- Return ""
- End If
- Case Else
- Return "未知的登录方式"
- End Select
- End Function
- ''' <summary>
- ''' 登录输入是否可以进行登录。若不可以则会返回错误原因。
- ''' </summary>
- Public Function McLoginAble(LoginData As McLoginData) As String
- Select Case LoginData.Type
- Case McLoginType.Mojang
- Return PageLoginMojang.IsVaild(LoginData)
- Case McLoginType.Ms
- Return PageLoginMs.IsVaild(LoginData)
- Case McLoginType.Legacy
- Return PageLoginLegacy.IsVaild(LoginData)
- Case McLoginType.Nide
- Return PageLoginNide.IsVaild(LoginData)
- Case McLoginType.Auth
- Return PageLoginAuth.IsVaild(LoginData)
- Case Else
- Return "未知的登录方式"
- End Select
- End Function
- '登录主模块加载器
- Public McLoginLoader As New LoaderTask(Of McLoginData, McLoginResult)("登录", AddressOf McLoginStart, AddressOf McLoginInput, ThreadPriority.BelowNormal) With {.ReloadTimeout = 1, .ProgressWeight = 15, .Block = False}
- Public Function McLoginInput() As McLoginData
- Dim LoginData As McLoginData = Nothing
- Dim LoginType As McLoginType = Setup.Get("LoginType")
- Try
- Select Case LoginType
- Case McLoginType.Legacy
- LoginData = PageLoginLegacy.GetLoginData()
- Case McLoginType.Mojang
- If Setup.Get("CacheMojangAccess") = "" Then
- LoginData = PageLoginMojang.GetLoginData()
- Else
- LoginData = PageLoginMojangSkin.GetLoginData()
- End If
- Case McLoginType.Ms
- If Setup.Get("CacheMsOAuthRefresh") = "" Then
- LoginData = PageLoginMs.GetLoginData()
- Else
- LoginData = PageLoginMsSkin.GetLoginData()
- End If
- Case McLoginType.Nide
- If Setup.Get("CacheNideAccess") = "" Then
- LoginData = PageLoginNide.GetLoginData()
- Else
- LoginData = PageLoginNideSkin.GetLoginData()
- End If
- Case McLoginType.Auth
- If Setup.Get("CacheAuthAccess") = "" Then
- LoginData = PageLoginAuth.GetLoginData()
- Else
- LoginData = PageLoginAuthSkin.GetLoginData()
- End If
- End Select
- Catch ex As Exception
- Log(ex, "获取登录输入信息失败(" & GetStringFromEnum(LoginType) & ")", LogLevel.Feedback)
- End Try
- Return LoginData
- End Function
- Private Sub McLoginStart(Data As LoaderTask(Of McLoginData, McLoginResult))
- McLaunchLog("登录线程已启动")
- '校验登录信息
- Dim CheckResult As String = McLoginAble(Data.Input)
- If Not CheckResult = "" Then Throw New ArgumentException(CheckResult)
- '获取对应加载器
- Dim Loader As LoaderBase = Nothing
- Select Case Data.Input.Type
- Case McLoginType.Mojang
- Loader = McLoginMojangLoader
- Case McLoginType.Ms
- Loader = McLoginMsLoader
- Case McLoginType.Legacy
- Loader = McLoginLegacyLoader
- Case McLoginType.Nide
- Loader = McLoginNideLoader
- Case McLoginType.Auth
- Loader = McLoginAuthLoader
- End Select
- '尝试加载
- Loader.WaitForExit(Data.Input, McLoginLoader, Data.IsForceRestarting)
- Data.Output = CType(Loader, Object).Output
- RunInUi(Sub() FrmLaunchLeft.RefreshPage(True, False)) '刷新自动填充列表
- End Sub
- #End Region
- #Region "分方式登录模块"
- '各个登录方式的主对象与输入构造
- Public McLoginMojangLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Mojang", AddressOf McLoginServerStart) With {.ReloadTimeout = 60000}
- Public McLoginMsLoader As New LoaderTask(Of McLoginMs, McLoginResult)("Loader Login Ms", AddressOf McLoginMsStart) With {.ReloadTimeout = 300000}
- Public McLoginLegacyLoader As New LoaderTask(Of McLoginLegacy, McLoginResult)("Loader Login Legacy", AddressOf McLoginLegacyStart)
- Public McLoginNideLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Nide", AddressOf McLoginServerStart) With {.ReloadTimeout = 60000}
- Public McLoginAuthLoader As New LoaderTask(Of McLoginServer, McLoginResult)("Loader Login Auth", AddressOf McLoginServerStart) With {.ReloadTimeout = 60000}
- '主加载函数,返回所有需要的登录信息
- Private Sub McLoginMsStart(Data As LoaderTask(Of McLoginMs, McLoginResult))
- Dim Input As McLoginMs = Data.Input
- Dim LogUsername As String = Input.UserName
- McLaunchLog("登录方式:微软正版(" & If(LogUsername = "", "尚未登录", LogUsername) & ")")
- Data.Progress = 0.05
- '检查是否已经登录完成
- If Input.AccessToken <> "" AndAlso Not Data.IsForceRestarting Then
- Data.Output = New McLoginResult With {.AccessToken = Input.AccessToken, .Name = Input.UserName, .Uuid = Input.Uuid, .Type = "Microsoft", .ClientToken = Input.Uuid}
- GoTo SkipLogin
- End If
- '尝试登录
- Dim OAuthTokens As String()
- If Setup.Get("CacheMsOAuthRefresh") = "" Then
- '无 RefreshToken
- Relogin:
- Dim OAuthCode As String = MsLoginStep1(Data)
- If Data.IsAborted Then Throw New ThreadInterruptedException
- Data.Progress = 0.2
- OAuthTokens = MsLoginStep2(OAuthCode, False)
- Else
- '有 RefreshToken
- OAuthTokens = MsLoginStep2(Setup.Get("CacheMsOAuthRefresh"), True)
- End If
- '要求重新打开登录网页认证
- If OAuthTokens(0) = "Relogin" Then GoTo Relogin
- Data.Progress = 0.35
- If Data.IsAborted Then Throw New ThreadInterruptedException
- Dim OAuthAccessToken As String = OAuthTokens(0)
- Dim OAuthRefreshToken As String = OAuthTokens(1)
- Dim XBLToken As String = MsLoginStep3(OAuthAccessToken)
- Data.Progress = 0.5
- If Data.IsAborted Then Throw New ThreadInterruptedException
- Dim Tokens = MsLoginStep4(XBLToken)
- Data.Progress = 0.65
- If Data.IsAborted Then Throw New ThreadInterruptedException
- Dim AccessToken As String = MsLoginStep5(Tokens)
- Data.Progress = 0.8
- If Data.IsAborted Then Throw New ThreadInterruptedException
- Dim Result = MsLoginStep6(AccessToken)
- '输出登录结果
- Setup.Set("CacheMsOAuthRefresh", OAuthRefreshToken)
- Setup.Set("CacheMsAccess", AccessToken)
- Setup.Set("CacheMsUuid", Result(0))
- Setup.Set("CacheMsName", Result(1))
- Data.Output = New McLoginResult With {.AccessToken = AccessToken, .Name = Result(1), .Uuid = Result(0), .Type = "Microsoft", .ClientToken = Result(0), .ProfileJson = Result(2)}
- '解锁主题
- SkipLogin:
- McLaunchLog("微软登录完成")
- Data.Progress = 0.95
- If ThemeUnlock(10, False) Then MyMsgBox("感谢你对正版游戏的支持!" & vbCrLf & "隐藏主题 跳票红 已解锁!", "提示")
- End Sub
- Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult))
- Dim Input As McLoginServer = Data.Input
- Dim NeedRefresh As Boolean = False
- Dim LogUsername As String = Input.UserName
- If LogUsername.Contains("@") AndAlso Setup.Get("UiLauncherEmail") Then
- LogUsername = AccountFilter(LogUsername)
- End If
- McLaunchLog("登录方式:" & Input.Description & "(" & LogUsername & ")")
- Data.Progress = 0.05
- '尝试登录
- If (Not Data.Input.ForceReselectProfile) AndAlso Setup.Get("Cache" & Input.Token & "Username") = Data.Input.UserName AndAlso Setup.Get("Cache" & Input.Token & "Pass") = Data.Input.Password AndAlso Not Setup.Get("Cache" & Input.Token & "Access") = "" AndAlso Not Setup.Get("Cache" & Input.Token & "Client") = "" AndAlso Not Setup.Get("Cache" & Input.Token & "Uuid") = "" AndAlso Not Setup.Get("Cache" & Input.Token & "Name") = "" Then
- '尝试验证登录
- Try
- If Data.IsAborted Then Throw New ThreadInterruptedException
- McLoginRequestValidate(Data)
- GoTo LoginFinish
- Catch ex As Exception
- Dim AllMessage = GetString(ex)
- McLaunchLog("验证登录失败:" & AllMessage)
- If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then
- McLaunchLog("已触发超时登录失败")
- Throw New Exception("$登录失败:连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好,或尝试使用 VPN!")
- End If
- End Try
- Data.Progress = 0.25
- '尝试刷新登录
- Refresh:
- Try
- If Data.IsAborted Then Throw New ThreadInterruptedException
- McLoginRequestRefresh(Data, NeedRefresh)
- GoTo LoginFinish
- Catch ex As Exception
- McLaunchLog("刷新登录失败:" & GetString(ex))
- End Try
- Data.Progress = If(NeedRefresh, 0.85, 0.45)
- End If
- '尝试普通登录
- Try
- If Data.IsAborted Then Throw New ThreadInterruptedException
- NeedRefresh = McLoginRequestLogin(Data)
- Catch ex As Exception
- McLaunchLog("登录失败:" & GetString(ex))
- Throw
- End Try
- If NeedRefresh Then
- Data.Progress = 0.65
- GoTo Refresh
- End If
- LoginFinish:
- Data.Progress = 0.95
- '保存启动记录
- Dim Dict As New Dictionary(Of String, String)
- Dim Emails As New List(Of String)
- Dim Passwords As New List(Of String)
- Try
- If Not Setup.Get("Login" & Input.Token & "Email") = "" Then Emails.AddRange(Setup.Get("Login" & Input.Token & "Email").ToString.Split("¨"))
- If Not Setup.Get("Login" & Input.Token & "Pass") = "" Then Passwords.AddRange(Setup.Get("Login" & Input.Token & "Pass").ToString.Split("¨"))
- For i = 0 To Emails.Count - 1
- Dict.Add(Emails(i), Passwords(i))
- Next
- Dict.Remove(Input.UserName)
- Emails = New List(Of String)(Dict.Keys)
- Emails.Insert(0, Input.UserName)
- Passwords = New List(Of String)(Dict.Values)
- Passwords.Insert(0, Input.Password)
- Setup.Set("Login" & Input.Token & "Email", Join(Emails, "¨"))
- Setup.Set("Login" & Input.Token & "Pass", Join(Passwords, "¨"))
- Catch ex As Exception
- Log(ex, "保存启动记录失败", LogLevel.Hint)
- Setup.Set("Login" & Input.Token & "Email", "")
- Setup.Set("Login" & Input.Token & "Pass", "")
- End Try
- End Sub
- Private Sub McLoginLegacyStart(Data As LoaderTask(Of McLoginLegacy, McLoginResult))
- Dim Input As McLoginLegacy = Data.Input
- McLaunchLog("登录方式:离线(" & Input.UserName & ")")
- Data.Progress = 0.1
- With Data.Output
- .Name = Input.UserName
- .Uuid = McLoginLegacyUuid(Input.UserName)
- .Type = "Legacy"
- End With
- '根据离线皮肤获取实际使用的 Uuid
- Select Case Input.SkinType
- Case 0
- '默认,不需要处理
- Case 1
- 'Steve
- Do Until McSkinSex(Data.Output.Uuid) = "Steve"
- If Data.Output.Uuid.EndsWith("FFFFF") Then Data.Output.Uuid = Mid(Data.Output.Uuid, 1, 32 - 5) & "00000"
- Data.Output.Uuid = Mid(Data.Output.Uuid, 1, 32 - 5) & (Long.Parse(Right(Data.Output.Uuid, 5), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X")
- Loop
- Case 2
- 'Alex
- Do Until McSkinSex(Data.Output.Uuid) = "Alex"
- If Data.Output.Uuid.EndsWith("FFFFF") Then Data.Output.Uuid = Mid(Data.Output.Uuid, 1, 32 - 5) & "00000"
- Data.Output.Uuid = Mid(Data.Output.Uuid, 1, 32 - 5) & (Long.Parse(Right(Data.Output.Uuid, 5), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X")
- Loop
- Case 3
- '使用正版用户名
- Try
- If Not Input.SkinName = "" Then
- Log("[Skin] 由于离线皮肤设置,使用正版 UUID:" & Input.SkinName)
- Data.Output.Uuid = McLoginMojangUuid(Input.SkinName, False)
- End If
- Catch ex As Exception
- Log(ex, "离线启动时使用的正版皮肤获取失败")
- MyMsgBox("由于设置的离线启动时使用的正版皮肤获取失败,游戏将以无皮肤的方式启动。" & vbCrLf & "请检查你的网络是否通畅,或尝试使用 VPN!" & vbCrLf & vbCrLf & "详细的错误信息:" & ex.Message, "皮肤获取失败")
- End Try
- Case 4
- '自定义
- Do Until McSkinSex(Data.Output.Uuid) = If(Setup.Get("LaunchSkinSlim"), "Alex", "Steve")
- If Data.Output.Uuid.EndsWith("FFFFF") Then Data.Output.Uuid = Mid(Data.Output.Uuid, 1, 32 - 5) & "00000"
- Data.Output.Uuid = Mid(Data.Output.Uuid, 1, 32 - 5) & (Long.Parse(Right(Data.Output.Uuid, 5), Globalization.NumberStyles.AllowHexSpecifier) + 1).ToString("X")
- Loop
- End Select
- '将结果扩展到所有项目中
- 'Data.Output.AccessToken = Setup.Get("CacheMojangAccess") '不能优先使用缓存的 AccessToken,这会导致离线用户名设置失效
- 'If Data.Output.AccessToken.Length < 300 Then
- Data.Output.AccessToken = Data.Output.Uuid
- 'Data.Output.ClientToken = Setup.Get("CacheMojangClient")
- 'If Data.Output.AccessToken.Length <> 32 Then
- Data.Output.ClientToken = Data.Output.Uuid
- '保存启动记录
- Dim Names As New List(Of String)
- If Not Setup.Get("LoginLegacyName") = "" Then Names.AddRange(Setup.Get("LoginLegacyName").ToString.Split("¨"))
- Names.Remove(Input.UserName)
- Names.Insert(0, Input.UserName)
- Setup.Set("LoginLegacyName", Join(Names.ToArray, "¨"))
- End Sub
- 'Server 登录:三种验证方式的请求
- Private Sub McLoginRequestValidate(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult))
- McLaunchLog("验证登录开始(Validate, " & Data.Input.Token & ")")
- '提前缓存信息,否则如果在登录请求过程中退出登录,设置项目会被清空,导致输出存在空值
- Dim AccessToken As String = Setup.Get("Cache" & Data.Input.Token & "Access")
- Dim ClientToken As String = Setup.Get("Cache" & Data.Input.Token & "Client")
- Dim Uuid As String = Setup.Get("Cache" & Data.Input.Token & "Uuid")
- Dim Name As String = Setup.Get("Cache" & Data.Input.Token & "Name")
- '发送登录请求
- NetRequestRetry(
- Url:=Data.Input.BaseUrl & "/validate",
- Method:="POST",
- Data:="{""accessToken"":""" & AccessToken & """,""clientToken"":""" & ClientToken & """,""requestUser"":true}",
- ContentType:="application/json; charset=utf-8") '没有返回值的
- '将登录结果输出
- Data.Output.AccessToken = AccessToken
- Data.Output.ClientToken = ClientToken
- Data.Output.Uuid = Uuid
- Data.Output.Name = Name
- Data.Output.Type = Data.Input.Token
- Data.Output.Email = Data.Input.UserName
- '不更改缓存,直接结束
- McLaunchLog("验证登录成功(Validate, " & Data.Input.Token & ")")
- End Sub
- Private Sub McLoginRequestRefresh(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult), RequestUser As Boolean)
- McLaunchLog("刷新登录开始(Refresh, " & Data.Input.Token & ")")
- Dim LoginJson As JObject = GetJson(NetRequestRetry(
- Url:=Data.Input.BaseUrl & "/refresh",
- Method:="POST",
- Data:="{" &
- If(RequestUser, "
- ""requestUser"": true,
- ""selectedProfile"": {
- ""id"":""" & Setup.Get("Cache" & Data.Input.Token & "Uuid") & """,
- ""name"":""" & Setup.Get("Cache" & Data.Input.Token & "Name") & """},", "") & "
- ""accessToken"":""" & Setup.Get("Cache" & Data.Input.Token & "Access") & """,
- ""clientToken"":""" & Setup.Get("Cache" & Data.Input.Token & "Client") & """}",
- ContentType:="application/json; charset=utf-8"))
- '将登录结果输出
- If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效!")
- Data.Output.AccessToken = LoginJson("accessToken").ToString
- Data.Output.ClientToken = LoginJson("clientToken").ToString
- Data.Output.Uuid = LoginJson("selectedProfile")("id").ToString
- Data.Output.Name = LoginJson("selectedProfile")("name").ToString
- Data.Output.Type = Data.Input.Token
- Data.Output.Email = Data.Input.UserName
- '保存缓存
- Setup.Set("Cache" & Data.Input.Token & "Access", Data.Output.AccessToken)
- Setup.Set("Cache" & Data.Input.Token & "Client", Data.Output.ClientToken)
- Setup.Set("Cache" & Data.Input.Token & "Uuid", Data.Output.Uuid)
- Setup.Set("Cache" & Data.Input.Token & "Name", Data.Output.Name)
- Setup.Set("Cache" & Data.Input.Token & "Username", Data.Input.UserName)
- Setup.Set("Cache" & Data.Input.Token & "Pass", Data.Input.Password)
- McLaunchLog("刷新登录成功(Refresh, " & Data.Input.Token & ")")
- End Sub
- Private Function McLoginRequestLogin(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult)) As Boolean
- Try
- Dim NeedRefresh As Boolean = False
- McLaunchLog("登录开始(Login, " & Data.Input.Token & ")")
- Dim LoginJson As JObject = GetJson(NetRequestRetry(
- Url:=Data.Input.BaseUrl & "/authenticate",
- Method:="POST",
- Data:="{""agent"": {""name"": ""Minecraft"",""version"": 1},""username"":""" & Data.Input.UserName & """,""password"":""" & Data.Input.Password & """,""requestUser"":true}",
- ContentType:="application/json; charset=utf-8"))
- '检查登录结果
- If LoginJson("availableProfiles").Count = 0 Then
- If Data.Input.Type = McLoginType.Auth Then
- If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色,无法更换!", HintType.Critical)
- Throw New Exception("$你还没有创建角色,请在创建角色后再试!")
- Else
- Throw New Exception("$你还没有购买 Minecraft 正版,请在购买后再试!")
- End If
- ElseIf Data.Input.ForceReselectProfile AndAlso LoginJson("availableProfiles").Count = 1 Then
- Hint("你的账户中只有一个角色,无法更换!", HintType.Critical)
- End If
- Dim SelectedName As String = Nothing
- Dim SelectedId As String = Nothing
- If (LoginJson("selectedProfile") Is Nothing OrElse Data.Input.ForceReselectProfile) AndAlso LoginJson("availableProfiles").Count > 1 Then
- '要求选择档案;优先从缓存读取
- NeedRefresh = True
- Dim CacheId As String = Setup.Get("Cache" & Data.Input.Token & "Uuid")
- For Each Profile In LoginJson("availableProfiles")
- If Profile("id").ToString = CacheId Then
- SelectedName = Profile("name").ToString
- SelectedId = Profile("id").ToString
- McLaunchLog("根据缓存选择的角色:" & SelectedName)
- End If
- Next
- '缓存无效,要求玩家选择
- If SelectedName Is Nothing Then
- McLaunchLog("要求玩家选择角色")
- RunInUiWait(Sub()
- Dim SelectionControl As New List(Of IMyRadio)
- Dim SelectionJson As New List(Of JToken)
- For Each Profile In LoginJson("availableProfiles")
- SelectionControl.Add(New MyRadioBox With {.Text = Profile("name").ToString})
- SelectionJson.Add(Profile)
- Next
- Dim SelectedIndex As Integer = MyMsgBoxSelect(SelectionControl, "选择使用的角色")
- SelectedName = SelectionJson(SelectedIndex)("name").ToString
- SelectedId = SelectionJson(SelectedIndex)("id").ToString
- End Sub)
- McLaunchLog("玩家选择的角色:" & SelectedName)
- End If
- Else
- SelectedName = LoginJson("selectedProfile")("name").ToString
- SelectedId = LoginJson("selectedProfile")("id").ToString
- End If
- '将登录结果输出
- Data.Output.AccessToken = LoginJson("accessToken").ToString
- Data.Output.ClientToken = LoginJson("clientToken").ToString
- Data.Output.Name = SelectedName
- Data.Output.Uuid = SelectedId
- Data.Output.Type = Data.Input.Token
- Data.Output.Email = Data.Input.UserName
- '保存缓存
- Setup.Set("Cache" & Data.Input.Token & "Access", Data.Output.AccessToken)
- Setup.Set("Cache" & Data.Input.Token & "Client", Data.Output.ClientToken)
- Setup.Set("Cache" & Data.Input.Token & "Uuid", Data.Output.Uuid)
- Setup.Set("Cache" & Data.Input.Token & "Name", Data.Output.Name)
- Setup.Set("Cache" & Data.Input.Token & "Username", Data.Input.UserName)
- Setup.Set("Cache" & Data.Input.Token & "Pass", Data.Input.Password)
- McLaunchLog("登录成功(Login, " & Data.Input.Token & ")")
- Return NeedRefresh
- Catch ex As Exception
- Dim AllMessage As String = GetString(ex)
- Log(ex, "登录失败原始错误信息", LogLevel.Normal)
- If AllMessage.Contains("410") AndAlso AllMessage.Contains("Migrated") Then
- Throw New Exception("$登录失败:该 Mojang 账号已迁移至微软账号,请在上方的登录方式中选择 微软 并再次尝试登录!")
- ElseIf AllMessage.Contains("403") Then
- Select Case Data.Input.Type
- Case McLoginType.Auth
- Throw New Exception("$登录失败,以下为可能的原因:" & vbCrLf &
- " - 输入的账号或密码错误。" & vbCrLf &
- " - 登录尝试过于频繁,导致被暂时屏蔽。请不要操作,等待 10 分钟后再试。" & vbCrLf &
- " - 只注册了账号,但没有在皮肤站新建角色。")
- Case McLoginType.Legacy
- Throw
- Case McLoginType.Mojang
- If AllMessage.Contains("Invalid username or password") Then
- Throw New Exception("$登录失败:输入的账号或密码有误。")
- Else
- Throw New Exception("$登录尝试过于频繁,导致被 Mojang 暂时屏蔽。请不要操作,等待 10 分钟后再试。")
- End If
- Case McLoginType.Ms
- Throw New Exception("$登录失败,以下为可能的原因:" & vbCrLf &
- " - 登录尝试过于频繁,导致被暂时屏蔽。请不要操作,等待 10 分钟后再试。" & vbCrLf &
- " - 账号类别错误。如果你在使用 Mojang 账号,请将登录方式切换为 Mojang。")
- Case McLoginType.Nide
- Throw New Exception("$登录失败,以下为可能的原因:" & vbCrLf &
- " - 输入的账号或密码错误。" & vbCrLf &
- " - 密码错误次数过多,导致被暂时屏蔽。请不要操作,等待 10 分钟后再试。" & vbCrLf &
- If(Data.Input.UserName.Contains("@"), "", " - 登录账号应为邮箱或统一通行证账号,而非游戏角色 ID。" & vbCrLf) &
- " - 只注册了账号,但没有加入对应服务器。")
- End Select
- ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") Then
- Throw New Exception("$登录失败:连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好,或尝试使用 VPN!")
- ElseIf AllMessage.Contains("网络请求失败") Then
- Throw New Exception("$登录失败:连接登录服务器失败。" & vbCrLf & "请检查你的网络状况是否良好,或尝试使用 VPN!")
- ElseIf ex.Message.StartsWith("$") Then
- Throw
- Else
- Throw New Exception("登录失败:" & ex.Message, ex)
- End If
- Return False
- End Try
- End Function
- '微软登录步骤 1:打开网页认证,获取 OAuth Code
- Private Function MsLoginStep1(Data As LoaderTask(Of McLoginMs, McLoginResult)) As String
- McLaunchLog("开始微软登录步骤 1")
- If OsVersion <= New Version(10, 0, 17763, 0) Then 'TODO: 添加设置以强制使用网页中继登录
- 'Windows 7 或老版 Windows 10 登录
- MyMsgBox("PCL2 即将打开登录网页。登录后会转到一个空白页面(这代表登录成功了),请将该空白页面的网址复制到 PCL2。" & vbCrLf &
- "如果网络环境不佳,登录网页可能一直加载不出来,此时请尝试使用 VPN 或代理服务器,然后再试。", "登录说明", "开始", ForceWait:=True)
- OpenWebsite(FormLoginOAuth.LoginUrl1)
- Dim Result As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {New ValidateRegex("(?<=code\=)[^&]+", "返回网址应以 https://login.live.com/oauth20_desktop.srf?code= 开头")}, "https://login.live.com/oauth20_desktop.srf?code=XXXXXX", "输入登录返回码", "确定", "取消")
- If Result Is Nothing Then
- McLaunchLog("微软登录已在步骤 1 被取消")
- Throw New ThreadInterruptedException("$$")
- Else
- Return RegexSeek(Result, "(?<=code\=)[^&]+")
- End If
- Else
- 'Windows 10 登录
- Dim ReturnCode As String = Nothing
- Dim ReturnEx As Exception = Nothing
- Dim IsFinished As LoadState = LoadState.Loading
- Dim LoginForm As FormLoginOAuth = Nothing
- RunInUi(Sub()
- Try
- LoginForm = New FormLoginOAuth
- LoginForm.Show()
- AddHandler LoginForm.OnLoginSuccess, Sub(Code As String)
- ReturnCode = Code
- IsFinished = LoadState.Finished
- End Sub
- AddHandler LoginForm.OnLoginCanceled, Sub() IsFinished = LoadState.Aborted
- Catch ex As Exception
- ReturnEx = ex
- IsFinished = LoadState.Failed
- End Try
- End Sub)
- Do While IsFinished = LoadState.Loading AndAlso Not Data.IsAborted
- Thread.Sleep(20)
- Loop
- RunInUi(Sub() If LoginForm IsNot Nothing Then LoginForm.Close())
- If IsFinished = LoadState.Finished Then
- Return ReturnCode
- ElseIf IsFinished = LoadState.Failed Then
- Throw ReturnEx
- Else
- McLaunchLog("微软登录已在步骤 1 被取消")
- Throw New ThreadInterruptedException("$$")
- End If
- End If
- End Function
- '微软登录步骤 2:从 OAuth Code 或 OAuth RefreshToken 获取 {OAuth AccessToken, OAuth RefreshToken}
- Private Function MsLoginStep2(Code As String, IsRefresh As Boolean) As String()
- McLaunchLog("开始微软登录步骤 2(" & If(IsRefresh, "", "非") & "刷新登录)")
- Dim Request As String
- If IsRefresh Then
- Request = "client_id=00000000402b5328" & "&" &
- "refresh_token=" & Uri.EscapeDataString(Code) & "&" &
- "grant_type=refresh_token" & "&" &
- "redirect_uri=" & Uri.EscapeDataString("https://login.live.com/oauth20_desktop.srf") & "&" &
- "scope=" & Uri.EscapeDataString("service::user.auth.xboxlive.com::MBI_SSL")
- Else
- Request = "client_id=00000000402b5328" & "&" &
- "code=" & Uri.EscapeDataString(Code) & "&" &
- "grant_type=authorization_code" & "&" &
- "redirect_uri=" & Uri.EscapeDataString("https://login.live.com/oauth20_desktop.srf") & "&" &
- "scope=" & Uri.EscapeDataString("service::user.auth.xboxlive.com::MBI_SSL")
- End If
- Dim Result As String
- Try
- Result = NetRequestMuity("https://login.live.com/oauth20_token.srf", "POST", Request, "application/x-www-form-urlencoded", 1)
- Catch ex As Exception
- If ex.Message.Contains("must sign in again") Then
- Return {"Relogin", ""}
- Else
- Throw
- End If
- End Try
- Dim ResultJson As JObject = GetJson(Result)
- Dim AccessToken As String = ResultJson("access_token").ToString
- Dim RefreshToken As String = ResultJson("refresh_token").ToString
- Return {AccessToken, RefreshToken}
- End Function
- '微软登录步骤 3:从 OAuth AccessToken 获取 XBLToken
- Private Function MsLoginStep3(AccessToken As String) As String
- McLaunchLog("开始微软登录步骤 3")
- Dim Request As String = "{
- ""Properties"": {
- ""AuthMethod"": ""RPS"",
- ""SiteName"": ""user.auth.xboxlive.com"",
- ""RpsTicket"": """ & AccessToken & """
- },
- ""RelyingParty"": ""http://auth.xboxlive.com"",
- ""TokenType"": ""JWT""
- }"
- Dim Result As String = NetRequestMuity("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
- Dim ResultJson As JObject = GetJson(Result)
- Dim XBLToken As String = ResultJson("Token").ToString
- Return XBLToken
- End Function
- '微软登录步骤 4:从 XBLToken 获取 {XSTSToken, UHS}
- Private Function MsLoginStep4(XBLToken As String) As String()
- McLaunchLog("开始微软登录步骤 4")
- Dim Request As String = "{
- ""Properties"": {
- ""SandboxId"": ""RETAIL"",
- ""UserTokens"": [
- """ & XBLToken & """
- ]
- },
- ""RelyingParty"": ""rp://api.minecraftservices.com/"",
- ""TokenType"": ""JWT""
- }"
- Dim Result As String
- Try
- Result = NetRequestMuity("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
- Catch ex As Net.WebException
- If ex.Message.Contains("2148916233") Then
- Throw New Exception("$该微软账号尚未购买 Minecraft Java 版或注册 XBox 账户!")
- ElseIf ex.Message.Contains("2148916238") Then
- If MyMsgBox("该账号年龄不足,你需要先修改出生日期,然后才能登录。" & vbCrLf &
- "该账号目前填写的年龄是否在 13 岁以上?", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then
- OpenWebsite("https://account.live.com/editprof.aspx")
- MyMsgBox("请在打开的网页中修改账号的出生日期(至少改为 18 岁以上)。" & vbCrLf &
- "在修改成功后等待一分钟,然后再回到 PCL2,就可以正常登录了!", "登录提示")
- Else
- OpenWebsite("https://support.microsoft.com/zh-cn/account-billing/如何更改-microsoft-帐户上的出生日期-837badbc-999e-54d2-2617-d19206b9540a")
- MyMsgBox("请根据打开的网页的说明,修改账号的出生日期(至少改为 18 岁以上)。" & vbCrLf &
- "在修改成功后等待一分钟,然后再回到 PCL2,就可以正常登录了!", "登录提示")
- End If
- Throw New Exception("$$")
- Else
- Throw
- End If
- End Try
- Dim ResultJson As JObject = GetJson(Result)
- Dim XSTSToken As String = ResultJson("Token").ToString
- Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
- Return {XSTSToken, UHS}
- End Function
- '微软登录步骤 5:从 {XSTSToken, UHS} 获取 Minecraft AccessToken
- Private Function MsLoginStep5(Tokens As String()) As String
- McLaunchLog("开始微软登录步骤 5")
- Dim Request As String = "{""identityToken"": ""XBL3.0 x=" & Tokens(1) & ";" & Tokens(0) & """}"
- Dim Result As String
- Try
- Result = NetRequestMuity("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json", 2)
- Catch ex As Net.WebException
- Dim Message As String = GetString(ex)
- If Message.Contains("(429)") Then
- Log(ex, "微软登录第 5 步汇报 429")
- Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
- ElseIf Message.Contains("(403)") Then
- Log(ex, "微软登录第 5 步汇报 403")
- Throw New Exception("$当前 IP 的登录尝试异常。" & vbCrLf & "如果你使用了 VPN 或加速器,请把它们关掉或更换节点后再试!")
- Else
- Throw
- End If
- End Try
- Dim ResultJson As JObject = GetJson(Result)
- Dim AccessToken As String = ResultJson("access_token").ToString
- Return AccessToken
- End Function
- '微软登录步骤 6:从 Minecraft AccessToken 获取 {UUID, UserName, ProfileJson}
- Private Function MsLoginStep6(AccessToken As String) As String()
- McLaunchLog("开始微软登录步骤 6")
- Dim Result As String
- Try
- Result = NetRequestMuity("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
- Catch ex As Net.WebException
- Dim Message As String = GetString(ex)
- If Message.Contains("(429)") Then
- Log(ex, "微软登录第 6 步汇报 429")
- Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
- ElseIf Message.Contains("(404)") Then
- Log(ex, "微软登录第 6 步汇报 404")
- Throw New Exception("$你可能没有在购买后去 Minecraft 官网创建游戏档案,或者没有购买 Minecraft。")
- Else
- Throw
- End If
- End Try
- Dim ResultJson As JObject = GetJson(Result)
- Dim UUID As String = ResultJson("id").ToString
- Dim UserName As String = ResultJson("name").ToString
- Return {UUID, UserName, Result}
- End Function
- '根据用户名返回对应 Uuid,需要多线程
- Public Function McLoginMojangUuid(Name As String, ThrowOnNotFound As Boolean)
- If Name.Trim.Length = 0 Then Return StrFill("", "0", 32)
- '从缓存获取
- Dim Uuid As String = ReadIni(PathTemp & "Cache\Uuid\Mojang.ini", Name, "")
- If Len(Uuid) = 32 Then Return Uuid
- '从官网获取
- Try
- Dim GotJson As JObject = NetGetCodeByRequestRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, IsJson:=True)
- If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在(" & Name & ")")
- Uuid = If(GotJson("id"), "")
- Catch ex As Exception
- Log(ex, "从官网获取正版 Uuid 失败(" & Name & ")")
- If Not ThrowOnNotFound AndAlso ex.GetType.Name = "FileNotFoundException" Then
- Uuid = McLoginLegacyUuid(Name) '玩家档案不存在
- Else
- Throw New Exception("从官网获取正版 Uuid 失败", ex)
- End If
- End Try
- '写入缓存
- If Not Len(Uuid) = 32 Then Throw New Exception("获取的正版 Uuid 长度不足(" & Uuid & ")")
- WriteIni(PathTemp & "Cache\Uuid\Mojang.ini", Name, Uuid)
- Return Uuid
- End Function
- Public Function McLoginLegacyUuid(Name As String)
- Dim FullUuid As String = StrFill(Name.Length.ToString("X"), "0", 16) & StrFill(GetHash(Name).ToString("X"), "0", 16)
- Return FullUuid.Substring(0, 12) & "3" & FullUuid.Substring(13, 3) & "9" & FullUuid.Substring(17, 15)
- End Function
- #End Region
- #Region "Java 处理"
- Private McLaunchJavaSelected As JavaEntry = Nothing
- Private Sub McLaunchJavaValidate()
- Dim MinVer As New Version(0, 0, 0, 0), MaxVer As New Version(999, 999, 999, 999)
- 'MC 大版本检测
- If (McVersionCurrent.ReleaseTime >= New Date(2021, 11, 16) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
- (McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain <> 99) Then
- '1.18 pre2+:至少 Java 17
- MinVer = New Version(1, 17, 0, 0)
- ElseIf (McVersionCurrent.ReleaseTime >= New Date(2021, 5, 11) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
- (McVersionCurrent.Version.McCodeMain >= 17 AndAlso McVersionCurrent.Version.McCodeMain <> 99) Then
- '21w19a+:至少 Java 16
- MinVer = New Version(1, 16, 0, 0)
- ElseIf McVersionCurrent.ReleaseTime.Year >= 2017 Then 'Minecraft 1.12 与 1.11 的分界线正好是 2017 年,太棒了
- '1.12+:至少 Java 8
- MinVer = New Version(1, 8, 0, 0)
- ElseIf McVersionCurrent.ReleaseTime.Year >= 2001 Then '避免某些版本的 1960 癌
- '1.11-:最高 Java 12
- MaxVer = New Version(1, 12, 999, 999)
- End If
- 'Forge 检测
- If McVersionCurrent.Version.HasForge Then
- If McVersionCurrent.Version.McName = "1.7.2" Then
- '1.7.2:必须 Java 7
- MinVer = New Version(1, 7, 0, 0) : MaxVer = New Version(1, 7, 999, 999)
- ElseIf McVersionCurrent.Version.McCodeMain <= 12 AndAlso McVersionCurrent.Version.McCodeMain <> -1 AndAlso VersionSortBoolean("14.23.5.2855", McVersionCurrent.Version.ForgeVersion) Then
- '1.12,Forge 14.23.5.2855 及更低:Java 8
- MaxVer = New Version(1, 8, 999, 999)
- ElseIf McVersionCurrent.Version.McCodeMain <= 14 AndAlso McVersionCurrent.Version.McCodeMain <> -1 AndAlso VersionSortBoolean("28.2.23", McVersionCurrent.Version.ForgeVersion) Then
- '1.13 - 1.14,Forge 28.2.23 及更低:Java 8 - 10
- MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 10, 999, 999)
- ElseIf McVersionCurrent.Version.McCodeMain <= 16 AndAlso McVersionCurrent.Version.McCodeMain <> -1 Then
- '1.15 - 1.16:Java 8 - 12, 12 - 15未测试
- MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 15, 999, 999)
- End If
- End If
- '统一通行证检测
- If Setup.Get("LoginType") = McLoginType.Nide Then
- '至少 Java 8.101 (1.8.0.101)
- MinVer = If(New Version(1, 8, 0, 101) > MinVer, New Version(1, 8, 0, 101), MinVer)
- End If
- '选择 Java
- McLaunchLog("Java 版本需求:最低 " & MinVer.ToString & ",最高 " & MaxVer.ToString)
- McLaunchJavaSelected = JavaSelect(MinVer, MaxVer, McVersionCurrent)
- If McLaunchJavaSelected IsNot Nothing Then
- McLaunchLog("选择的 Java:" & McLaunchJavaSelected.ToString)
- Exit Sub
- End If
- '无合适的 Java
- McLaunchLog("无合适的 Java,取消启动")
- If MinVer >= New Version(1, 17, 0, 0) Then
- '缺少 Java 17
- JavaMissing(17)
- ElseIf MinVer >= New Version(1, 16, 0, 0) Then
- '缺少 Java 16
- JavaMissing(16)
- ElseIf MaxVer < New Version(1, 8, 0, 0) Then
- '缺少 Java 7
- JavaMissing(7)
- Else
- '缺少 Java 8 较新版
- JavaMissing(8)
- End If
- Throw New Exception("$$")
- End Sub
- #End Region
- #Region "启动参数"
- Private McLaunchArgument As String
- '主方法,合并 Jvm、Game、Replace 三部分的参数数据
- Private Sub McLaunchArgumentMain(Loader As LoaderTask(Of String, List(Of McLibToken)))
- McLaunchLog("开始获取 Minecraft 启动参数")
- '获取基准字符串与参数信息
- Dim Arguments As String
- If McVersionCurrent.JsonObject("arguments") IsNot Nothing AndAlso McVersionCurrent.JsonObject("arguments")("jvm") IsNot Nothing Then
- McLaunchLog("获取新版 JVM 参数")
- Arguments = McLaunchArgumentsJvmNew(McVersionCurrent)
- McLaunchLog("新版 JVM 参数获取成功:")
- McLaunchLog(Arguments)
- Else
- McLaunchLog("获取旧版 JVM 参数")
- Arguments = McLaunchArgumentsJvmOld(McVersionCurrent)
- McLaunchLog("旧版 JVM 参数获取成功:")
- McLaunchLog(Arguments)
- End If
- If McVersionCurrent.JsonObject("minecraftArguments") IsNot Nothing Then
- McLaunchLog("获取旧版 Game 参数")
- Arguments += " " & McLaunchArgumentsGameOld(McVersionCurrent)
- McLaunchLog("旧版 Game 参数获取成功")
- End If
- If McVersionCurrent.JsonObject("arguments") IsNot Nothing AndAlso McVersionCurrent.JsonObject("arguments")("game") IsNot Nothing Then
- McLaunchLog("获取新版 Game 参数")
- Arguments += " " & McLaunchArgumentsGameNew(McVersionCurrent)
- McLaunchLog("新版 Game 参数获取成功")
- End If
- '替换参数
- Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader)
- If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then
- '若自定义信息为空,则去掉该部分
- Arguments = Arguments.Replace(" --versionType ${version_type}", "")
- ReplaceArguments("${version_type}") = """"""
- End If
- For Each entry As KeyValuePair(Of String, String) In ReplaceArguments
- Arguments = Arguments.Replace(entry.Key, If(entry.Value.Contains(" ") OrElse entry.Value.Contains(":\"), """" & entry.Value & """", entry.Value))
- Next
- 'MJSB
- Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""")
- '全屏
- If Setup.Get("LaunchArgumentWindowType") = 0 Then Arguments += " --fullscreen"
- '进服
- Dim Server As String = If(String.IsNullOrEmpty(Loader.Input), Setup.Get("VersionServerEnter", McVersionCurrent), Loader.Input)
- If Server.Length > 0 Then
- If Server.Contains(":") Then
- '包含端口号
- Arguments += " --server " & Server.Split(":")(0) & " --port " & Server.Split(":")(1)
- Else
- '不包含端口号
- Arguments += " --server " & Server & " --port 25565"
- End If
- 'OptiFine 警告
- If McVersionCurrent.Version.HasOptiFine Then
- Hint("OptiFine 与自动进入服务器可能不兼容,有概率导致材质丢失甚至游戏崩溃!", HintType.Critical)
- End If
- End If
- '自定义
- Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent)
- Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)
- '输出
- McLaunchLog("Minecraft 启动参数:")
- McLaunchLog(Arguments.Replace(McLoginLoader.Output.AccessToken, McLoginLoader.Output.AccessToken.Substring(0, 22) & "[数据删除]" & McLoginLoader.Output.AccessToken.Substring(30)))
- McLaunchArgument = Arguments
- End Sub
- 'Jvm 部分(第一段)
- Private Function McLaunchArgumentsJvmOld(Version As McVersion) As String
- '存储以空格为间隔的启动参数列表
- Dim DataList As New List(Of String)
- '输出固定参数
- DataList.Add("-XX:HeapDumpPath=MojangTricksIntelDriversForPerformance_javaw.exe_minecraft.exe.heapdump")
- Dim ArgumentJvm As String = Setup.Get("VersionAdvanceJvm", Version:=McVersionCurrent)
- If ArgumentJvm = "" Then ArgumentJvm = Setup.Get("LaunchAdvanceJvm")
- If Not ArgumentJvm.Contains("-Dlog4j2.formatMsgNoLookups=true") Then ArgumentJvm += " -Dlog4j2.formatMsgNoLookups=true"
- DataList.Insert(0, ArgumentJvm) '可变 JVM 参数
- DataList.Add("-Xmn256m")
- DataList.Add("-Xmx" & Math.Floor(PageVersionSetup.GetRam(McVersionCurrent) * 1024) & "m")
- DataList.Add("""-Djava.library.path=" & Version.Path & Version.Name & "-natives""")
- DataList.Add("-cp ${classpath}") '把支持库添加进启动参数表
- '统一通行证
- If McLoginLoader.Output.Type = "Nide" Then
- DataList.Insert(0, "-Dnide8auth.client=true -javaagent:nide8auth.jar=" & Setup.Get("VersionServerNide", Version:=McVersionCurrent))
- End If
- 'Authlib-Injector
- If McLoginLoader.Output.Type = "Auth" Then
- Dim Server As String = Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)
- Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
- DataList.Insert(0, "-javaagent:authlib-injector.jar=" & Server &
- " -Dauthlibinjector.side=client" &
- " -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
- End If
- '添加 MainClass
- If Version.JsonObject("mainClass") Is Nothing Then
- Throw New Exception("版本 Json 中没有 mainClass 项!")
- Else
- DataList.Add(Version.JsonObject("mainClass"))
- End If
- Return Join(DataList, " ")
- End Function
- Private Function McLaunchArgumentsJvmNew(Version As McVersion) As String
- Dim DataList As New List(Of String)
- '获取 Json 中的 DataList
- Dim CurrentVersion As McVersion = Version
- NextVersion:
- If CurrentVersion.JsonObject("arguments") IsNot Nothing AndAlso CurrentVersion.JsonObject("arguments")("jvm") IsNot Nothing Then
- For Each SubJson As JToken In CurrentVersion.JsonObject("arguments")("jvm")
- If SubJson.Type = JTokenType.String Then
- '字符串类型
- DataList.Add(SubJson.ToString)
- Else
- '非字符串类型
- If McJsonRuleCheck(SubJson("rules")) Then
- '满足准则
- If SubJson("value").Type = JTokenType.String Then
- DataList.Add(SubJson("value").ToString)
- Else
- For Each value As JToken In SubJson("value")
- DataList.Add(value.ToString)
- Next
- End If
- End If
- End If
- Next
- End If
- If CurrentVersion.InheritVersion <> "" Then
- CurrentVersion = New McVersion(CurrentVersion.InheritVersion)
- GoTo NextVersion
- End If
- '内存、Log4j 防御参数等
- SecretLaunchJvmArgs(DataList)
- '统一通行证
- If McLoginLoader.Output.Type = "Nide" Then
- DataList.Insert(0, "-javaagent:nide8auth.jar=" & Setup.Get("VersionServerNide", Version:=McVersionCurrent))
- End If
- 'Authlib-Injector
- If McLoginLoader.Output.Type = "Auth" Then
- Dim Server As String = Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)
- Try
- Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
- DataList.Insert(0, "-javaagent:authlib-injector.jar=" & Server &
- " -Dauthlibinjector.side=client" &
- " -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
- Catch ex As Exception
- Throw New Exception("无法连接到第三方登录服务器(" & If(Server, Nothing) & ")")
- End Try
- End If
- '将 "-XXX" 与后面 "XXX" 合并到一起
- '如果不合并,会导致 Forge 1.17 启动无效,它有两个 --add-exports,进一步导致其中一个在后面被去重
- Dim DeDuplicateDataList As New List(Of String)
- For i = 0 To DataList.Count - 1
- Dim CurrentEntry As String = DataList(i)
- If DataList(i).StartsWith("-") Then
- Do While i < DataList.Count - 1
- If DataList(i + 1).StartsWith("-") Then
- Exit Do
- Else
- i += 1
- CurrentEntry += " " + DataList(i)
- End If
- Loop
- End If
- DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu="))
- Next
- '去重
- Dim Result As String = Join(ArrayNoDouble(DeDuplicateDataList), " ")
- '添加 MainClass
- If Version.JsonObject("mainClass") Is Nothing Then
- Throw New Exception("版本 Json 中没有 mainClass 项!")
- Else
- Result += " " & Version.JsonObject("mainClass").ToString
- End If
- Return Result
- End Function
- 'Game 部分(第二段)
- Private Function McLaunchArgumentsGameOld(Version As McVersion) As String
- Dim DataList As New List(Of String)
- '本地化 Minecraft 启动信息
- Dim BasicString As String = Version.JsonObject("minecraftArguments").ToString
- If Not BasicString.Contains("--height") Then BasicString += " --height ${resolution_height} --width ${resolution_width}"
- DataList.Add(BasicString)
- McLaunchArgumentsGameOld = Join(DataList, " ")
- '特别改变 OptiFineTweaker
- If (Version.Version.HasForge OrElse Version.Version.HasLiteLoader) AndAlso Version.Version.HasOptiFine Then
- '把 OptiFineForgeTweaker 放在最后,不然会导致崩溃!
- If McLaunchArgumentsGameOld.Contains("--tweakClass optifine.OptiFineForgeTweaker") Then
- Log("[Launch] 发现正确的 OptiFineForge TweakClass,目前参数:" & McLaunchArgumentsGameOld)
- McLaunchArgumentsGameOld = McLaunchArgumentsGameOld.Replace(" --tweakClass optifine.OptiFineForgeTweaker", "").Replace("--tweakClass optifine.OptiFineForgeTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker"
- End If
- If McLaunchArgumentsGameOld.Contains("--tweakClass optifine.OptiFineTweaker") Then
- Log("[Launch] 发现错误的 OptiFineForge TweakClass,目前参数:" & McLaunchArgumentsGameOld)
- McLaunchArgumentsGameOld = McLaunchArgumentsGameOld.Replace(" --tweakClass optifine.OptiFineTweaker", "").Replace("--tweakClass optifine.OptiFineTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker"
- Try
- WriteFile(Version.Path & Version.Name & ".json", ReadFile(Version.Path & Version.Name & ".json").Replace("optifine.OptiFineTweaker", "optifine.OptiFineForgeTweaker"))
- Catch ex As Exception
- Log(ex, "替换 OptiFineForge TweakClass 失败")
- End Try
- End If
- End If
- End Function
- Private Function McLaunchArgumentsGameNew(Version As McVersion) As String
- Dim DataList As New List(Of String)
- '获取 Json 中的 DataList
- Dim CurrentVersion As McVersion = Version
- NextVersion:
- If CurrentVersion.JsonObject("arguments") IsNot Nothing AndAlso CurrentVersion.JsonObject("arguments")("game") IsNot Nothing Then
- For Each SubJson As JToken In CurrentVersion.JsonObject("arguments")("game")
- If SubJson.Type = JTokenType.String Then
- '字符串类型
- DataList.Add(SubJson.ToString)
- Else
- '非字符串类型
- If McJsonRuleCheck(SubJson("rules")) Then
- '满足准则
- If SubJson("value").Type = JTokenType.String Then
- DataList.Add(SubJson("value").ToString)
- Else
- For Each value As JToken In SubJson("value")
- DataList.Add(value.ToString)
- Next
- End If
- End If
- End If
- Next
- End If
- If CurrentVersion.InheritVersion <> "" Then
- CurrentVersion = New McVersion(CurrentVersion.InheritVersion)
- GoTo NextVersion
- End If
- '将 "-XXX" 与后面 "XXX" 合并到一起
- '如果不进行合并 Impact 会启动无效,它有两个 --tweakclass
- Dim DeDuplicateDataList As New List(Of String)
- For i = 0 To DataList.Count - 1
- Dim CurrentEntry As String = DataList(i)
- If DataList(i).StartsWith("-") Then
- Do While i < DataList.Count - 1
- If DataList(i + 1).StartsWith("-") Then
- Exit Do
- Else
- i += 1
- CurrentEntry += " " + DataList(i)
- End If
- Loop
- End If
- DeDuplicateDataList.Add(CurrentEntry)
- Next
- '去重
- McLaunchArgumentsGameNew = Join(ArrayNoDouble(DeDuplicateDataList), " ")
- '特别改变 OptiFineTweaker
- If (Version.Version.HasForge OrElse Version.Version.HasLiteLoader) AndAlso Version.Version.HasOptiFine Then
- '把 OptiFineForgeTweaker 放在最后,不然会导致崩溃!
- If McLaunchArgumentsGameNew.Contains("--tweakClass optifine.OptiFineForgeTweaker") Then
- Log("[Launch] 发现正确的 OptiFineForge TweakClass,目前参数:" & McLaunchArgumentsGameNew)
- McLaunchArgumentsGameNew = McLaunchArgumentsGameNew.Replace(" --tweakClass optifine.OptiFineForgeTweaker", "").Replace("--tweakClass optifine.OptiFineForgeTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker"
- End If
- If McLaunchArgumentsGameNew.Contains("--tweakClass optifine.OptiFineTweaker") Then
- Log("[Launch] 发现错误的 OptiFineForge TweakClass,目前参数:" & McLaunchArgumentsGameNew)
- McLaunchArgumentsGameNew = McLaunchArgumentsGameNew.Replace(" --tweakClass optifine.OptiFineTweaker", "").Replace("--tweakClass optifine.OptiFineTweaker ", "") & " --tweakClass optifine.OptiFineForgeTweaker"
- Try
- WriteFile(Version.Path & Version.Name & ".json", ReadFile(Version.Path & Version.Name & ".json").Replace("optifine.OptiFineTweaker", "optifine.OptiFineForgeTweaker"))
- Catch ex As Exception
- Log(ex, "替换 OptiFineForge TweakClass 失败")
- End Try
- End If
- End If
- End Function
- '替换 Arguments
- Private Function McLaunchArgumentsReplace(Version As McVersion, ByRef Loader As LoaderTask(Of String, List(Of McLibToken))) As Dictionary(Of String, String)
- Dim GameArguments As New Dictionary(Of String, String)
- '基础参数
- GameArguments.Add("${classpath_separator}", ";")
- GameArguments.Add("${natives_directory}", Version.Path & Version.Name & "-natives")
- GameArguments.Add("${library_directory}", PathMcFolder & "libraries")
- GameArguments.Add("${libraries_directory}", PathMcFolder & "libraries")
- GameArguments.Add("${launcher_name}", "PCL2")
- GameArguments.Add("${launcher_version}", VersionCode)
- GameArguments.Add("${version_name}", Version.Name)
- Dim ArgumentInfo As String = Setup.Get("VersionArgumentInfo", Version:=McVersionCurrent)
- GameArguments.Add("${version_type}", If(ArgumentInfo = "", Setup.Get("LaunchArgumentInfo"), ArgumentInfo))
- GameArguments.Add("${game_directory}", Left(McVersionCurrent.PathIndie, McVersionCurrent.PathIndie.Count - 1))
- GameArguments.Add("${assets_root}", PathMcFolder & "assets")
- GameArguments.Add("${user_properties}", "{}")
- GameArguments.Add("${auth_player_name}", McLoginLoader.Output.Name)
- GameArguments.Add("${auth_uuid}", McLoginLoader.Output.Uuid)
- GameArguments.Add("${auth_access_token}", McLoginLoader.Output.AccessToken)
- GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken)
- GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken)
- GameArguments.Add("${user_type}", If(McLoginLoader.Output.Type = "Legacy", "Legacy", "Mojang"))
- Dim GameSize As Size = Setup.GetLaunchArgumentWindowSize()
- GameArguments.Add("${resolution_width}", GameSize.Width)
- GameArguments.Add("${resolution_height}", GameSize.Height)
- 'Assets 相关参数
- GameArguments.Add("${game_assets}", PathMcFolder & "assets\virtual\legacy") '1.5.2 的 pre-1.6 资源索引应与 legacy 合并
- GameArguments.Add("${assets_index_name}", McAssetsGetIndexName(Version))
- '支持库参数
- Dim LibList As List(Of McLibToken) = McLibListGet(Version, Not (Version.Version.HasForge AndAlso Version.Version.McCodeMain >= 17))
- Loader.Output = LibList
- Dim CpStrings As New List(Of String)
- Dim OptiFineCp As String = Nothing
- For Each Library As McLibToken In LibList
- If Library.IsNatives Then Continue For
- If Library.Name IsNot Nothing AndAlso Library.Name = "optifine:OptiFine" Then
- OptiFineCp = Library.LocalPath
- Else
- CpStrings.Add(Library.LocalPath)
- End If
- Next
- If OptiFineCp IsNot Nothing Then CpStrings.Insert(CpStrings.Count - 2, OptiFineCp)
- GameArguments.Add("${classpath}", Join(CpStrings, ";"))
- Return GameArguments
- End Function
- #End Region
- #Region "解压 Natives"
- Private Sub McLaunchNatives(Loader As LoaderTask(Of List(Of McLibToken), Integer))
- '创建文件夹
- Directory.CreateDirectory(McVersionCurrent.Path & McVersionCurrent.Name & "-natives")
- '解压文件
- McLaunchLog("正在解压 Natives 文件")
- Dim ExistFiles As New List(Of String)
- For Each Native As McLibToken In Loader.Input
- If Not Native.IsNatives Then Continue For
- Dim Zip As ZipArchive
- Try
- Zip = New ZipArchive(New FileStream(Native.LocalPath, FileMode.Open))
- Catch ex As InvalidDataException
- Log(ex, "打开 Natives 文件失败(" & Native.LocalPath & ")")
- File.Delete(Native.LocalPath)
- Throw New Exception("无法打开 Natives 文件(" & Native.LocalPath & "),该文件可能已损坏,请重新尝试启动游戏")
- End Try
- For Each Entry In Zip.Entries
- Dim FileName As String = Entry.FullName
- If FileName.EndsWith(".dll") Then
- '实际解压文件的步骤
- Dim FilePath As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives\" & FileName
- ExistFiles.Add(FilePath)
- Dim OriginalFile As New FileInfo(FilePath)
- If OriginalFile.Exists Then
- If OriginalFile.Length = Entry.Length Then
- If ModeDebug Then McLaunchLog("无需解压:" & FilePath)
- Continue For
- End If
- '删除原文件
- Try
- File.Delete(FilePath)
- Catch ex As UnauthorizedAccessException
- McLaunchLog("删除原 dll 访问被拒绝,这通常代表有一个 MC 正在运行,跳过解压:" & FilePath)
- McLaunchLog("实际的错误信息:" & GetString(ex))
- Exit For
- End Try
- End If
- '解压新文件
- WriteFile(FilePath, Entry.Open)
- McLaunchLog("已解压:" & FilePath)
- End If
- Next
- If Zip IsNot Nothing Then Zip.Dispose()
- Next
- '删除多余文件
- For Each FileName As String In Directory.GetFiles(McVersionCurrent.Path & McVersionCurrent.Name & "-natives")
- If ExistFiles.Contains(FileName) Then Continue For
- Try
- McLaunchLog("删除:" & FileName)
- File.Delete(FileName)
- Catch ex As UnauthorizedAccessException
- McLaunchLog("删除多余文件访问被拒绝,跳过删除步骤")
- McLaunchLog("实际的错误信息:" & GetString(ex))
- Exit Sub
- End Try
- Next
- End Sub
- #End Region
- #Region "启动与前后处理"
- Private Sub McLaunchPrerun()
- '更新 launcher_profiles.json
- Try
- '确保可用
- If Not (McLoginLoader.Output.Type = "Mojang" OrElse McLoginLoader.Output.Type = "Microsoft") Then Exit Try
- McFolderLauncherProfilesJsonCreate(PathMcFolder)
- '构建需要替换的 Json 对象
- Dim ReplaceJsonString As String = "
- {
- ""authenticationDatabase"": {
- ""00000111112222233333444445555566"": {
- ""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
- ""username"": """ & If(McLoginLoader.Output.Email, McLoginLoader.Output.Name).Replace("""", "-") & """,
- ""profiles"": {
- ""66666555554444433333222221111100"": {
- ""displayName"": """ & McLoginLoader.Output.Name & """
- }
- }
- }
- },
- ""clientToken"": """ & McLoginLoader.Output.ClientToken & """,
- ""selectedUser"": {
- ""account"": ""00000111112222233333444445555566"",
- ""profile"": ""66666555554444433333222221111100""
- }
- }"
- Dim ReplaceJson As JObject = GetJson(ReplaceJsonString)
- '更新文件
- Dim Profiles As JObject = GetJson(ReadFile(PathMcFolder & "launcher_profiles.json"))
- Profiles.Merge(ReplaceJson)
- WriteFile(PathMcFolder & "launcher_profiles.json", Profiles.ToString, Encoding:=Encoding.Default)
- McLaunchLog("已更新 launcher_profiles.json")
- Catch ex As Exception
- Log(ex, "更新 launcher_profiles.json 失败,将在删除文件后重试")
- Try
- File.Delete(PathMcFolder & "launcher_profiles.json")
- McFolderLauncherProfilesJsonCreate(PathMcFolder)
- '构建需要替换的 Json 对象
- Dim ReplaceJsonString As String = "
- {
- ""authenticationDatabase"": {
- ""00000111112222233333444445555566"": {
- ""accessToken"": """ & McLoginLoader.Output.AccessToken & """,
- ""username"": """ & If(McLoginLoader.Output.Email, McLoginLoader.Output.Name).Replace("""", "-") & """,
- ""profiles"": {
- ""66666555554444433333222221111100"": {
- ""displayName"": """ & McLoginLoader.Output.Name & """
- }
- }
- }
- },
- ""clientToken"": """ & McLoginLoader.Output.ClientToken & """,
- ""selectedUser"": {
- ""account"": ""00000111112222233333444445555566"",
- ""profile"": ""66666555554444433333222221111100""
- }
- }"
- Dim ReplaceJson As JObject = GetJson(ReplaceJsonString)
- '更新文件
- Dim Profiles As JObject = GetJson(ReadFile(PathMcFolder & "launcher_profiles.json"))
- Profiles.Merge(ReplaceJson)
- WriteFile(PathMcFolder & "launcher_profiles.json", Profiles.ToString, Encoding:=Encoding.Default)
- McLaunchLog("已在删除后更新 launcher_profiles.json")
- Catch exx As Exception
- Log(exx, "更新 launcher_profiles.json 失败", LogLevel.Feedback)
- End Try
- End Try
- '更新 options.txt
- Dim SetupFileAddress As String = McVersionCurrent.PathIndie & "options.txt"
- Try
- '语言
- If Setup.Get("ToolHelpChinese") Then
- If Not File.Exists(SetupFileAddress) OrElse Not Directory.Exists(McVersionCurrent.PathIndie & "saves") Then
- McLaunchLog("已根据设置自动修改语言为中文")
- WriteIni(SetupFileAddress, "lang", "-") '触发缓存更改,避免删除后重新下载残留缓存
- If McVersionCurrent.Version.McCodeMain >= 12 Then
- WriteIni(SetupFileAddress, "lang", "zh_cn")
- Else
- WriteIni(SetupFileAddress, "lang", "zh_CN")
- End If
- WriteIni(SetupFileAddress, "forceUnicodeFont", "true")
- Else
- McLaunchLog("并非首次启动,不修改语言")
- End If
- End If
- '窗口
- Select Case Setup.Get("LaunchArgumentWindowType")
- Case 0 '全屏
- WriteIni(SetupFileAddress, "fullscreen", "true")
- Case 5 '保持默认
- Case Else '其他
- WriteIni(SetupFileAddress, "fullscreen", "false")
- End Select
- Catch ex As Exception
- Log(ex, "更新 options.txt 失败", LogLevel.Hint)
- End Try
- '离线皮肤 Alex 警告
- Try
- If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain >= 2 AndAlso '1.7 ~ 1.2
- McLoginLoader.Input.Type = McLoginType.Legacy AndAlso '离线登录
- (Setup.Get("LaunchSkinType") = 2 OrElse '强制 Alex
- (Setup.Get("LaunchSkinType") = 4 AndAlso Setup.Get("LaunchSkinSlim"))) Then '或选用 Alex 皮肤
- Hint("此 Minecraft 版本尚不支持 Alex 皮肤,你的皮肤可能会显示为 Steve!", HintType.Critical)
- End If
- Catch ex As Exception
- Log(ex, "检查离线皮肤失效失败")
- End Try
- '离线皮肤资源包
- Try
- Directory.CreateDirectory(McVersionCurrent.PathIndie & "resourcepacks\")
- Dim ZipFileAddress As String = McVersionCurrent.PathIndie & "resourcepacks\PCL2 Skin.zip"
- Dim NewTypeSetup As Boolean = McVersionCurrent.Version.McCodeMain >= 13 OrElse McVersionCurrent.Version.McCodeMain < 6
- If McLoginLoader.Input.Type = McLoginType.Legacy AndAlso Setup.Get("LaunchSkinType") = 4 AndAlso File.Exists(PathTemp & "CustomSkin.png") Then
- Directory.CreateDirectory(PathTemp)
- Dim MetaFileAddress As String = PathTemp & "pack.mcmeta"
- Dim PackPicAddress As String = PathTemp & "pack.png"
- Dim PackFormat As Integer
- Select Case McVersionCurrent.Version.McCodeMain
- Case 0, 1, 2, 3, 4, 5
- '更早的版本没有资源包;如果判断失败该值为 -1,不会跑到这
- McLaunchLog("Minecraft 版本过老,尚不支持自定义离线皮肤")
- GoTo IgnoreCustomSkin
- Case 6, 7, 8
- PackFormat = 1
- Case 9, 10
- PackFormat = 2
- Case 11, 12
- PackFormat = 3
- Case 13, 14
- PackFormat = 4
- Case 15
- PackFormat = 5
- Case 16
- PackFormat = 6
- Case 17
- PackFormat = 7
- Case 18
- If McVersionCurrent.Version.McCodeSub <= 2 Then
- PackFormat = 8
- Else
- PackFormat = 9
- End If
- Case 19
- PackFormat = 9
- Case Else
- PackFormat = 10
- End Select
- McLaunchLog("正在构建自定义皮肤资源包,格式为:" & PackFormat)
- '准备文件
- Dim Bit As New MyBitmap(PathImage & "Heads/Logo.png")
- Bit.Save(PackPicAddress)
- WriteFile(MetaFileAddress, "{""pack"":{""pack_format"":" & PackFormat & ",""description"":""PCL2 自定义离线皮肤资源包""}}")
- Dim Skin As New MyBitmap(PathTemp & "CustomSkin.png")
- If (McVersionCurrent.Version.McCodeMain = 6 OrElse McVersionCurrent.Version.McCodeMain = 7) AndAlso Skin.Pic.Height = 64 Then
- McLaunchLog("该 Minecraft 版本不支持双层皮肤,已进行裁剪")
- Skin = Skin.Clip(New System.Drawing.Rectangle(0, 0, 64, 32))
- End If
- Skin.Save(Path & "PCL\CustomSkin_Cliped.png")
- '构建压缩文件
- Using ZipFile As New FileStream(ZipFileAddress, FileMode.Create)
- Using ZipAr As New ZipArchive(ZipFile, ZipArchiveMode.Create)
- ZipAr.CreateEntryFromFile(MetaFileAddress, "pack.mcmeta")
- ZipAr.CreateEntryFromFile(PackPicAddress, "pack.png")
- ZipAr.CreateEntryFromFile(Path & "PCL\CustomSkin_Cliped.png", "assets/minecraft/textures/entity/" & If(Setup.Get("LaunchSkinSlim"), "alex.png", "steve.png"))
- End Using
- End Using
- File.Delete(Path & "PCL\CustomSkin_Cliped.png")
- '更改设置文件
- IniClearCache(SetupFileAddress)
- Dim EnabledResourcePack As String = ReadIni(SetupFileAddress, "resourcePacks", "[]").TrimStart("[").TrimEnd("]")
- If NewTypeSetup Then
- If EnabledResourcePack = "" Then EnabledResourcePack = """vanilla"""
- Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(","))
- Dim NewResourcePacks As New List(Of String)
- For Each Res In EnabledResourcePacks
- If Res <> """file/PCL2 Skin.zip""" AndAlso Res <> "" Then NewResourcePacks.Add(Res)
- Next
- NewResourcePacks.Add("""file/PCL2 Skin.zip""")
- Dim Result As String = "[" & Join(NewResourcePacks, ",") & "]"
- WriteIni(SetupFileAddress, "resourcePacks", Result)
- Else
- Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(","))
- Dim NewResourcePacks As New List(Of String)
- For Each Res In EnabledResourcePacks
- If Res <> """PCL2 Skin.zip""" AndAlso Res <> "" Then NewResourcePacks.Add(Res)
- Next
- NewResourcePacks.Add("""PCL2 Skin.zip""")
- Dim Result As String = "[" & Join(NewResourcePacks, ",") & "]"
- WriteIni(SetupFileAddress, "resourcePacks", Result)
- End If
- IgnoreCustomSkin:
- ElseIf File.Exists(ZipFileAddress) Then
- McLaunchLog("正在清空自定义皮肤资源包")
- '删除压缩文件
- File.Delete(ZipFileAddress)
- '更改设置文件
- IniClearCache(SetupFileAddress)
- Dim EnabledResourcePack As String = ReadIni(SetupFileAddress, "resourcePacks", "[]").TrimStart("[").TrimEnd("]")
- If NewTypeSetup Then
- If EnabledResourcePack = "" Then EnabledResourcePack = """vanilla"""
- Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(","))
- EnabledResourcePacks.Remove("""file/PCL2 Skin.zip""")
- Dim Result As String = "[" & Join(EnabledResourcePacks, ",") & "]"
- WriteIni(SetupFileAddress, "resourcePacks", Result)
- Else
- Dim EnabledResourcePacks As New List(Of String)(EnabledResourcePack.Split(","))
- EnabledResourcePacks.Remove("""PCL2 Skin.zip""")
- Dim Result As String = "[" & Join(EnabledResourcePacks, ",") & "]"
- WriteIni(SetupFileAddress, "resourcePacks", Result)
- End If
- End If
- Catch ex As Exception
- Log(ex, "离线皮肤资源包设置失败", LogLevel.Hint)
- End Try
- End Sub
- Private Sub McLaunchRun(Loader As LoaderTask(Of Integer, Process))
- '启动信息
- Dim GameProcess = New Process()
- Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJavaw)
- '设置环境变量
- If StartInfo.EnvironmentVariables.ContainsKey("appdata") Then
- StartInfo.EnvironmentVariables("appdata") = PathMcFolder
- Else
- StartInfo.EnvironmentVariables.Add("appdata", PathMcFolder)
- End If
- Dim Paths As New List(Of String)(StartInfo.EnvironmentVariables("Path").Split(";"))
- Paths.Add(McLaunchJavaSelected.PathFolder)
- StartInfo.EnvironmentVariables("Path") = Join(ArrayNoDouble(Paths), ";")
- '设置其他参数
- StartInfo.WorkingDirectory = McVersionCurrent.PathIndie
- StartInfo.UseShellExecute = False
- StartInfo.RedirectStandardOutput = True
- StartInfo.RedirectStandardError = True
- StartInfo.CreateNoWindow = False
- StartInfo.Arguments = McLaunchArgument
- GameProcess.StartInfo = StartInfo
- '开始进程
- GameProcess.Start()
- McLaunchLog("已启动游戏进程:" & McLaunchJavaSelected.PathJavaw)
- Loader.Output = GameProcess
- McLaunchProcess = GameProcess
- '输出 bat
- Try
- Dim CmdString As String =
- "@echo off" & vbCrLf &
- "title 启动 - " & McVersionCurrent.Name & vbCrLf &
- "echo 游戏正在启动,请稍候。" & vbCrLf &
- "set APPDATA=""" & PathMcFolder & """" & vbCrLf &
- "cd /D """ & PathMcFolder & """" & vbCrLf &
- """" & McLaunchJavaSelected.PathJava & """ " & McLaunchArgument & vbCrLf &
- "echo 游戏已退出。" & vbCrLf &
- "pause"
- WriteFile(Path & "PCL\LatestLaunch.bat", CmdString, Encoding:=Encoding.Default)
- Catch ex As Exception
- Log(ex, "输出启动脚本失败")
- End Try
- '进程优先级处理
- Try
- If GameProcess.HasExited Then Exit Try '可能在启动游戏进程的同时刚好取消了启动
- GameProcess.PriorityBoostEnabled = True
- Select Case Setup.Get("LaunchArgumentPriority")
- Case 0 '高
- GameProcess.PriorityClass = ProcessPriorityClass.AboveNormal
- Case 2 '低
- GameProcess.PriorityClass = ProcessPriorityClass.BelowNormal
- Case Else '中
- End Select
- Catch ex As Exception
- Log(ex, "设置进程优先级失败", LogLevel.Feedback)
- End Try
- End Sub
- Private Sub McLaunchWait(Loader As LoaderTask(Of Process, Integer))
- '输出信息
- McLaunchLog("")
- McLaunchLog("~ 基础参数 ~")
- McLaunchLog("PCL2 版本:" & VersionDisplayName & " (" & VersionCode & ")")
- McLaunchLog("游戏版本:" & McVersionCurrent.Version.ToString & "(" & McVersionCurrent.Version.McCodeMain & "." & McVersionCurrent.Version.McCodeSub & ")")
- McLaunchLog("资源版本:" & McAssetsGetIndexName(McVersionCurrent))
- McLaunchLog("版本继承:" & If(McVersionCurrent.InheritVersion = "", "无", McVersionCurrent.InheritVersion))
- McLaunchLog("分配的内存:" & PageVersionSetup.GetRam(McVersionCurrent) & " GB(" & Math.Round(PageVersionSetup.GetRam(McVersionCurrent) * 1024) & " MB)")
- McLaunchLog("MC 文件夹:" & PathMcFolder)
- McLaunchLog("版本文件夹:" & McVersionCurrent.Path)
- McLaunchLog("版本隔离:" & (McVersionCurrent.PathIndie = McVersionCurrent.Path))
- McLaunchLog("HMCL 格式:" & McVersionCurrent.IsHmclFormatJson)
- McLaunchLog("Java 信息:" & If(McLaunchJavaSelected IsNot Nothing, McLaunchJavaSelected.ToString, "无可用 Java"))
- McLaunchLog("环境变量:" & If(McLaunchJavaSelected IsNot Nothing, If(McLaunchJavaSelected.HasEnvironment, "已设置", "未设置"), "未设置"))
- McLaunchLog("")
- McLaunchLog("~ 登录参数 ~")
- McLaunchLog("玩家用户名:" & McLoginLoader.Output.Name)
- McLaunchLog("AccessToken:" & McLoginLoader.Output.AccessToken.Substring(0, 22) & "[数据删除]" & McLoginLoader.Output.AccessToken.Substring(30))
- McLaunchLog("ClientToken:" & McLoginLoader.Output.ClientToken)
- McLaunchLog("UUID:" & McLoginLoader.Output.Uuid)
- McLaunchLog("登录方式:" & McLoginLoader.Output.Type)
- McLaunchLog("")
- '获取窗口标题
- Dim WindowTitle As String = Setup.Get("VersionArgumentTitle", Version:=McVersionCurrent)
- If WindowTitle = "" Then WindowTitle = Setup.Get("LaunchArgumentTitle")
- WindowTitle = ArgumentReplace(WindowTitle)
- '初始化等待
- Dim Watcher As New Watcher(Loader, McVersionCurrent, WindowTitle)
- McLaunchWatcher = Watcher
- '等待
- Do While Watcher.State = Watcher.MinecraftState.Loading
- Thread.Sleep(100)
- Loop
- If Watcher.State = Watcher.MinecraftState.Crashed Then
- Throw New Exception("$$")
- End If
- End Sub
- Private Sub McLaunchEnd()
- McLaunchLog("开始启动结束处理")
- '暂停或开始音乐播放
- If Setup.Get("UiMusicStop") Then
- RunInUi(Sub() If MusicPause() Then Log("[Music] 已根据设置,在启动后暂停音乐播放"))
- ElseIf Setup.Get("UiMusicStart") Then
- RunInUi(Sub() If MusicResume() Then Log("[Music] 已根据设置,在启动后开始音乐播放"))
- End If
- '启动器可见性
- McLaunchLog("启动器可见性:" & Setup.Get("LaunchArgumentVisible"))
- Select Case Setup.Get("LaunchArgumentVisible")
- Case 0
- '直接关闭
- McLaunchLog("已根据设置,在启动后关闭启动器")
- RunInUi(Sub() FrmMain.EndProgram(False))
- Case 2, 3
- '隐藏
- McLaunchLog("已根据设置,在启动后隐藏启动器")
- RunInUi(Sub() FrmMain.Hidden = True)
- Case 4
- '最小化
- McLaunchLog("已根据设置,在启动后最小化启动器")
- RunInUi(Sub() FrmMain.WindowState = WindowState.Minimized)
- Case 5
- '啥都不干
- End Select
- '启动计数
- Setup.Set("SystemLaunchCount", Setup.Get("SystemLaunchCount") + 1)
- End Sub
- #End Region
- End Module
|