Compare commits

..
5 Commits
Author SHA1 Message Date
龙腾猫跃 5fb5a3b963 2.4.3 2022-11-26 22:39:08 +08:00
龙腾猫跃 5ef1d60e2e 由于联机已被禁用,公开联机部分代码 2022-11-10 20:22:47 +08:00
龙腾猫跃 d091e153a9 删除联机的反馈选项 2022-11-08 19:57:28 +08:00
龙腾猫跃 97c5367108 2.4.2 2022-11-08 19:17:11 +08:00
龙腾猫跃 24cb4599d6 删除联机入口 2022-11-05 21:27:44 +08:00
33 changed files with 2658 additions and 294 deletions

No files matched your search

-3
View File
@@ -3,9 +3,6 @@ contact_links:
- name: 帮助文档反馈
url: https://github.com/LTCatt/PCL2Help/issues
about: 提交 PCL2 帮助系统(更多 → 帮助)相关的反馈
- name: 联机反馈与交流
url: https://shimowendang.com/docs/KrkEVXz1K0frowAJ#anchor-7qQG
about: 加入联机模块官方 QQ 群反馈联机异常,或询问联机功能的使用方式
- name: 提问
url: https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E6%8F%90%E9%97%AE
about: 我不想提交反馈,只是想问一些问题
-3
View File
@@ -349,9 +349,6 @@ ModSetup.vb
PageOtherAbout.*
PageOtherTest.*
PageSetupUI.*
# 公开联机代码可能导致安全风险
Plain Craft Launcher 2/Pages/PageLink/PageLinkIoi.xaml.vb
Plain Craft Launcher 2/Pages/PageLink/PageLinkHiPer.xaml.vb
# 开发者工具
ModDevelop.vb
# 不公开底层函数库,以免抄袭
View File
File renamed without changes.
@@ -15,7 +15,6 @@ Public Class Application
Log(ex, "开发者模式测试出错", LogLevel.Feedback)
End Try
End Sub
#End If
'开始
@@ -1,7 +1,7 @@
Public Class MyButton
'声明
Public Event Click(sender As Object, e As EventArgs) '自定义事件
Public Event Click(sender As Object, e As MouseButtonEventArgs) '自定义事件
'自定义属性
Public Uuid As Integer = GetUuid()
+11 -3
View File
@@ -287,9 +287,9 @@
End Class
Partial Public Module ModAnimation
Public Sub AniDispose(Control As MyCard, RemoveFromChildren As Boolean, Optional CallBack As ParameterizedThreadStart = Nothing)
If Not Control.IsHitTestVisible Then Exit Sub
Control.IsHitTestVisible = False
AniStart({
If Control.IsHitTestVisible Then
Control.IsHitTestVisible = False
AniStart({
AaScaleTransform(Control, -0.08, 200,, New AniEaseInFluent),
AaOpacity(Control, -1, 200,, New AniEaseOutFluent),
AaHeight(Control, -Control.ActualHeight, 150, 100, New AniEaseOutFluent),
@@ -302,5 +302,13 @@ Partial Public Module ModAnimation
If CallBack IsNot Nothing Then CallBack(Control)
End Sub,, True)
}, "MyCard Dispose " & Control.Uuid)
Else
If RemoveFromChildren Then
CType(Control.Parent, Object).Children.Remove(Control)
Else
Control.Visibility = Visibility.Collapsed
End If
If CallBack IsNot Nothing Then CallBack(Control)
End If
End Sub
End Module
@@ -137,12 +137,16 @@
'点击事件
Public Event PreviewClick(sender As Object, e As RouteEventArgs)
Private IsMouseDown As Boolean = False
Private Sub Radiobox_MouseUp() Handles Me.MouseLeftButtonUp
If Checked Then Exit Sub
If Not IsMouseDown Then Exit Sub
Log("[Control] 按下单选按钮:" & Text)
IsMouseDown = False
Dim e As New RouteEventArgs(True)
RaiseEvent PreviewClick(Me, e)
If e.Handled Then Exit Sub
SetChecked(True, True, True)
End Sub
Private Sub Radiobox_MouseDown() Handles Me.MouseLeftButtonDown
+30 -6
View File
@@ -10,15 +10,21 @@ Public Class FormMain
Dim FeatureList As New List(Of KeyValuePair(Of Integer, String))
'统计更新日志条目
#If BETA Then
If LastVersion < 268 Then 'Release 2.4.1
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "追加新的联机方式(HiPer 联机模块)"))
If LastVersion < 270 Then 'Release 2.4.3
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 Mod、整合包下载的版本检查与显示"))
If LastVersion <= 267 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法安装 LiteLoader 的 Bug"))
FeatureCount += 6
BugCount += 15
End If
If LastVersion < 268 Then 'Release 2.4.2
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "暂时关闭了联机功能"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "游戏崩溃的弹窗添加了直接查看日志的选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "在更多分类下添加了新功能投票选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "自动安装时支持检查 OptiFine 对 Forge 的具体版本需求"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化自动 Java 选择的准确度"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 Mod 中文名的显示"))
FeatureCount += 12
BugCount += 30
FeatureCount += 14
BugCount += 33
End If
If LastVersion < 265 Then 'Release 2.3.5
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复部分情况下无法启动路径带有中文的游戏的 Bug"))
@@ -100,8 +106,19 @@ Public Class FormMain
'3:BUG+ IMP* FEAT-
'2:BUG* IMP-
'1:BUG-
If LastVersion < 271 Then 'Snapshot 2.4.3
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 Mod、整合包下载的版本检查与显示"))
If LastVersion <= 267 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复无法安装 LiteLoader 的 Bug"))
FeatureCount += 6
BugCount += 15
End If
If LastVersion < 269 Then 'Snapshot 2.4.2
If LastVersion = 267 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复无法下载 CurseForge 整合包的 Bug"))
FeatureCount += 2
BugCount += 3
End If
If LastVersion < 267 Then 'Snapshot 2.4.1
If LastVersion = 266 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化 HiPer 联机模块的使用体验"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "暂时关闭了联机功能"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "自动安装时支持检查 OptiFine 对 Forge 的具体版本需求"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化自动 Java 选择的准确度"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化 Mod 中文名的显示"))
@@ -109,7 +126,6 @@ Public Class FormMain
BugCount += 22
End If
If LastVersion < 266 Then 'Snapshot 2.4.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "追加新的联机方式(HiPer 联机模块)"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "游戏崩溃的弹窗添加了直接查看日志的选项"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "在更多分类下添加了新功能投票选项"))
FeatureCount += 3
@@ -1128,6 +1144,14 @@ Install:
If IsChangingPage Then Exit Sub
PageChangeActual(Val(sender.Tag))
End Sub
Private Sub CancelLink(sender As Object, e As RouteEventArgs) Handles BtnTitleSelect2.PreviewClick
If MyMsgBox("由于联机提供商要求新联机强制付费,且高度商业化,PCL 将暂时关闭联机功能,不再使用该联机模块。" & vbCrLf &
"PCL、HMCL、BakaXL 将合作开发新的跨启动器联机功能,在开发结束后将同步开放,请各位多多理解。",
"联机功能已暂时关闭", "查看详情", "确定") = 1 Then
OpenWebsite("https://www.bilibili.com/read/cv19845645")
End If
e.Handled = True
End Sub
''' <summary>
''' 通过点击返回按钮或手动触发返回来改变页面。
''' </summary>
Binary file not shown.

Before

Width:  |  Height:  |  Size: 434 B

@@ -10,12 +10,12 @@ Public Module ModBase
#Region "声明"
'下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.4.1" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.4.1." & VersionBranchCode '标准格式的四段式版本号
Public Const VersionBaseName As String = "2.4.3" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.4.3." & VersionBranchCode '标准格式的四段式版本号
#If BETA Then
Public Const VersionCode As Integer = 268 'Release
Public Const VersionCode As Integer = 270 'Release
#Else
Public Const VersionCode As Integer = 267 'Snapshot
Public Const VersionCode As Integer = 271 'Snapshot
#End If
'自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -771,6 +771,8 @@ Public Module ModBase
'还原文件路径
If Not FromPath.Contains(":\") Then FromPath = Path & FromPath
If Not ToPath.Contains(":\") Then ToPath = Path & ToPath
'如果复制同一个文件则跳过
If FromPath = ToPath Then Exit Sub
'读取文件内容
Dim FileBytes As Byte()
Using ReadStream As New FileStream(FromPath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite) '支持读取使用中的文件
@@ -221,6 +221,7 @@
McDownloadClientUpdateHint(Version, Json)
IsNewClientVersionHinted = True
End If
McVersionHighest = Version.Split(".")(1)
Setup.Set("ToolUpdateReleaseLast", Version)
'解析更新提示(Snapshot)
Version = Json("latest")("snapshot")
@@ -653,11 +654,14 @@
VersionCode = VersionCode.Substring(VersionCode.IndexOf("universal.zip"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
Category = "universal"
Else
ElseIf VersionCode.Contains("client.zip") Then
'类型为 client.zip,支持范围 182~ (1.3.2 部分 ~)
VersionCode = VersionCode.Substring(VersionCode.IndexOf("client.zip"))
MD5 = RegexSeek(VersionCode, "(?<=MD5:</strong> )[^<]+")
Category = "client"
Else
'没有任何下载(1.6.4 有一部分这种情况)
Continue For
End If
'添加进列表
Versions.Add(New DlForgeVersionEntry With {.Category = Category, .Version = Name, .IsRecommended = IsRecommended, .Hash = MD5.Trim(vbCr, vbLf), .Inherit = Inherit, .ReleaseTime = ReleaseTime, .Branch = Branch})
@@ -769,7 +773,7 @@
''' </summary>
Public IsLegacy As Boolean
''' <summary>
''' 发布时间,格式为“yyyy/mm/dd HH:mm:ss”。
''' 发布时间,格式为“yyyy/mm/dd HH:mm”。
''' </summary>
Public ReleaseTime As String
''' <summary>
@@ -1087,33 +1091,27 @@
DateUpdate = Data("dateModified")
DownloadCount = Data("downloadCount")
IsModPack = Not Website.Contains("/mc-mods/")
'获取常见文件
'获取 Mod Loader 列表
ModLoaders = New List(Of String)
For Each File In If(Data("latestFiles"), {})
Dim NewFile As New DlCfFile(File, IsModPack)
If Not NewFile.IsAvailable Then Continue For
ModLoaders.AddRange(NewFile.ModLoaders)
Next
'获取游戏版本、Mod Loader
ModLoaders = ModLoaders.Distinct.ToList
'用一个偷懒的方式让 Forge 排在 Fabric 的前面
ModLoaders = ModLoaders.Select(Function(s) s.Replace("Forge", "Aorge")).ToList()
ModLoaders.Sort()
ModLoaders = ModLoaders.Select(Function(s) s.Replace("Aorge", "Forge")).ToList()
'获取游戏版本
Dim GameVersions As New List(Of Integer)
ModLoaders = New List(Of String)
For Each File In If(Data("latestFilesIndexes"), {})
Dim Version As String = File("gameVersion")
If Not Version.Contains("1.") Then Continue For
GameVersions.Add(Version.Split(".")(1).Split("-").First)
Select Case If(File("modLoader"), "0").ToString
Case 1
ModLoaders.Add("Forge")
Case 2
ModLoaders.Add("Cauldron")
Case 3
ModLoaders.Add("LiteLoader")
Case 4
ModLoaders.Add("Fabric")
End Select
FileIndexes.Add(File("fileId"))
Next
GameVersions = Sort(GameVersions.Distinct.ToList, AddressOf VersionSortBoolean)
ModLoaders = ModLoaders.Distinct.ToList
ModLoaders.Sort()
If GameVersions.Count = 0 Then
GameVersionDesc = ""
Else
@@ -1130,8 +1128,15 @@
Next
If StartVersion = EndVersion Then
SpaVersions.Add("1." & StartVersion)
ElseIf StartVersion >= McVersionHighest Then
SpaVersions.Add("1." & EndVersion & "+")
ElseIf EndVersion <= 7 Then
SpaVersions.Add("1." & StartVersion & "-")
Exit For
ElseIf StartVersion - EndVersion = 1 Then
SpaVersions.Add("1." & StartVersion & ", 1." & EndVersion)
Else
SpaVersions.Add("1." & StartVersion & "-1." & EndVersion)
SpaVersions.Add("1." & StartVersion & "~1." & EndVersion)
End If
Next
GameVersionDesc = "[" & Join(SpaVersions, ", ") & "] "
@@ -1208,12 +1213,11 @@
Dim NewItem As New MyCfItem With {.Tag = Me}
NewItem.LabTitle.Text = ChineseName
NewItem.LabInfo.Text = Description.Replace(vbCr, "").Replace(vbLf, "")
NewItem.LabLeft.Text = If(ModLoaders.Count > 0 AndAlso ShowLoaderDesc, "[" & Join(ModLoaders, " & ") & "] ", "") &
If(ShowVersionDesc, GameVersionDesc, "") &
NewItem.LabLeft.Text = (If(ModLoaders.Count > 0 AndAlso ShowLoaderDesc, "[" & Join(ModLoaders, "/") & "] ", "") &
If(ShowVersionDesc, GameVersionDesc, "")).Replace("] [", " ") &
Join(CategoryDesc, ",") & " (" &
GetTimeSpanString(DateUpdate - Date.Now) & "更新" &
If(DownloadCount > 0,
"," & If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次下载", DownloadCount & " 次下载"), "") & ")"
GetTimeSpanString(DateUpdate - Date.Now) & "更新," &
If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次下载", DownloadCount & " 次下载") & ")"
If Thumb Is Nothing Then
NewItem.Logo = "pack://application:,,,/images/Icons/NoIcon.png"
Else
@@ -1276,7 +1280,7 @@
Dim SearchResult As String = ""
For i = 0 To SearchResults.Count - 1
If Not SearchResults(i).AbsoluteRight AndAlso i >= Math.Min(2, SearchResults.Count - 1) Then Exit For '把 3 个结果拼合以提高准确度
SearchResult += SearchResults(i).Item.Replace(" (", "|").Split("|").Last.TrimEnd(")") & " "
SearchResult += SearchResults(i).Item.Replace(" - ", "§").Split("§").First.Replace(" (", "|").Split("|").Last.TrimEnd(")") & " "
Next
Log("[Download] CurseForge 工程列表中文搜索原始关键词:" & SearchResult, LogLevel.Developer)
'去除常见连接词
@@ -1429,6 +1433,7 @@
Public DisplayName As String
Public [Date] As Date
Public GameVersion As String()
Public ModLoaders As New List(Of String)
Public ReleaseType As Integer
Public FileName As String
Public DownloadCount As Integer
@@ -1478,11 +1483,13 @@
End If
Next
End If
'获取游戏版本
'获取游戏版本与 Mod 加载器列表
Dim Versions As New List(Of String)
For Each Version In Data("gameVersions")
If Version.ToString.StartsWith("1.") OrElse Version.ToString.Contains("w") Then
Versions.Add(Version.ToString.Trim.ToLower)
For Each Version In Data("gameVersions").Select(Function(t) t.ToString.Trim.ToLower)
If Version.StartsWith("1.") OrElse Version.Contains("w") Then
Versions.Add(Version)
ElseIf Version = "forge" OrElse Version = "fabric" OrElse Version = "quilt" OrElse Version = "rift" Then
ModLoaders.Add(Version.First.ToString.ToUpper & Version.Substring(1))
End If
Next
If Versions.Count > 1 Then
@@ -1490,11 +1497,13 @@
If IsModPack Then GameVersion = {GameVersion(0)}
ElseIf Versions.Count = 1 Then
GameVersion = Versions.ToArray
'ElseIf Data("gameVersion").Count = 1 AndAlso Not Data("gameVersion")(0).ToString.Contains("1.") Then
' GameVersion = {"1.16.4"}
Else
GameVersion = {"未知版本"}
End If
'用一个偷懒的方式让 Forge 排在 Fabric 的前面
ModLoaders = ModLoaders.Select(Function(s) s.Replace("Forge", "Aorge")).ToList()
ModLoaders.Sort()
ModLoaders = ModLoaders.Select(Function(s) s.Replace("Aorge", "Forge")).ToList()
End Sub
''' <summary>
@@ -1510,10 +1519,14 @@
'获取描述信息
Dim Info As String = ""
If Not IsModPack Then
Info += "适用于 " & Join(GameVersion, "、").Replace("-snapshot", " 快照") &
If(ModeDebug AndAlso Dependencies.Count > 0, "," & Dependencies.Count & " 个前置,", ",")
Info += If(ModLoaders.Count > 0, Join(ModLoaders, "/"), "") &
If(GameVersion.Count > 1, If(ModLoaders.Count > 0, " ", "") & Join(GameVersion, "、").Replace("-snapshot", " 快照"), "")
If Info <> "" Then Info = "适用于 " & Info & ","
Info += If(ModeDebug AndAlso Dependencies.Count > 0, Dependencies.Count & " 个前置 Mod,", "")
End If
Info += If(DownloadCount > 0, If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次下载,", DownloadCount & " 次下载,"), "")
'If DownloadCount > 0 Then 'DownloadCount 目前的返回内容完全不正确,经常是 0,干脆不显示了
' Info += If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次下载,", DownloadCount & " 次下载,")
'End If
Info += GetTimeSpanString([Date] - Date.Now) & "更新"
Info += If(ReleaseType <> 1, "," & ReleaseTypeString, "")
@@ -1078,19 +1078,30 @@ SystemBrowser:
MaxVer = New Version(1, 12, 999, 999)
End If
'OptiFine 检测
If McVersionCurrent.Version.HasOptiFine Then
If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain > 0 Then
'<1.7:至多 Java 8(Java 9 - 10 未测试)
MaxVer = New Version(1, 8, 999, 999)
ElseIf McVersionCurrent.Version.McCodeMain >= 8 AndAlso McVersionCurrent.Version.McCodeMain <= 11 Then
'1.8 - 1.11:必须恰好 Java 8(Java 9 - 10 未测试)
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 8, 999, 999)
End If
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 > 0 AndAlso VersionSortBoolean("14.23.5.2855", McVersionCurrent.Version.ForgeVersion) Then
'1.12,Forge 14.23.5.2855 及更低:Java 8
'<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 > 0 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 > 0 Then
'1.15 - 1.16:Java 8 - 15
ElseIf McVersionCurrent.Version.McCodeMain <= 15 AndAlso McVersionCurrent.Version.McCodeMain > 0 Then
'1.15:Java 8 - 15
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 15, 999, 999)
ElseIf McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain < 99 AndAlso McVersionCurrent.Version.HasOptiFine Then '#305
'1.18+:若安装了 OptiFine,最高 Java 18
@@ -1101,8 +1112,8 @@ SystemBrowser:
'Fabric 检测
If McVersionCurrent.Version.HasFabric Then
If McVersionCurrent.Version.McCodeMain >= 15 AndAlso McVersionCurrent.Version.McCodeMain <= 16 AndAlso McVersionCurrent.Version.McCodeMain <> -1 Then
'1.15 - 1.16:Java 8 - 15
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 15, 999, 999)
'1.15 - 1.16:Java 8 - 18
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 18, 999, 999)
ElseIf McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain < 99 Then
'1.18+:Java 17 - 18
MinVer = New Version(1, 17, 0, 0) : MaxVer = New Version(1, 18, 999, 999)
@@ -1150,24 +1161,31 @@ SystemBrowser:
Private McLaunchArgument As String
''' <summary>
''' 释放 Java Wrapper 并返回文件路径。
''' 释放 Java Wrapper 并返回完整文件路径。
''' </summary>
Public Function ExtractJavaWrapper() As String
Dim WrapperPath As String = PathAppdata & "JavaWrapper.jar"
If Encoding.UTF8.GetByteCount(WrapperPath) <> WrapperPath.Length Then
Log("[Java] AppData 路径中包含非 ASCII 字符,换用 Temp 目录")
WrapperPath = PathTemp & "JavaWrapper.jar"
If Encoding.UTF8.GetByteCount(PathTemp) <> PathTemp.Length Then
Log("[Java] Temp 路径中包含非 ASCII 字符,换用 C 盘根目录")
WrapperPath = "C:\PCL\JavaWrapper.jar"
End If
End If
If Not File.Exists(WrapperPath) OrElse New FileInfo(WrapperPath).Length > 20 * 1024 Then
Dim WrapperPath As String = GetJavaWrapperDir() & "\JavaWrapper.jar"
If Not File.Exists(WrapperPath) OrElse New FileInfo(WrapperPath).Length <> 16818 Then
WriteFile(WrapperPath, GetResources("JavaWrapper"))
Log("[Java] 已自动释放 Java Wrapper:" & WrapperPath)
End If
Return WrapperPath
End Function
''' <summary>
''' 获取 Java Wrapper 所在的文件夹,不以 \ 结尾。
''' </summary>
Public Function GetJavaWrapperDir() As String
Dim WrapperPath As String = PathAppdata.TrimEnd("\")
If Encoding.UTF8.GetByteCount(WrapperPath) <> WrapperPath.Length Then
Log("[Java] AppData 路径中包含非 ASCII 字符,换用 Temp 目录")
WrapperPath = PathTemp.TrimEnd("\")
If Encoding.UTF8.GetByteCount(PathTemp) <> PathTemp.Length Then
Log("[Java] Temp 路径中包含非 ASCII 字符,换用 C 盘根目录")
WrapperPath = "C:\PCL"
End If
End If
Return WrapperPath
End Function
'主方法,合并 Jvm、Game、Replace 三部分的参数数据
Private Sub McLaunchArgumentMain(Loader As LoaderTask(Of String, List(Of McLibToken)))
@@ -1185,7 +1203,7 @@ SystemBrowser:
McLaunchLog("旧版 JVM 参数获取成功:")
McLaunchLog(Arguments)
End If
If McVersionCurrent.JsonObject("minecraftArguments") IsNot Nothing Then
If Not String.IsNullOrEmpty(McVersionCurrent.JsonObject("minecraftArguments")) Then '有的版本是空字符串
McLaunchLog("获取旧版 Game 参数")
Arguments += " " & McLaunchArgumentsGameOld(McVersionCurrent)
McLaunchLog("旧版 Game 参数获取成功")
@@ -1270,6 +1288,7 @@ SystemBrowser:
'添加 Java Wrapper 作为主 Jar
If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED")
DataList.Insert(0, "-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """")
DataList.Add("-jar """ & ExtractJavaWrapper() & """")
'添加 MainClass
@@ -1336,6 +1355,7 @@ NextVersion:
'添加 Java Wrapper 作为主 Jar
If McLaunchJavaSelected.VersionCode >= 9 Then DataList.Add("--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED")
DataList.Insert(0, "-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """")
DataList.Add("-jar """ & ExtractJavaWrapper() & """")
'将 "-XXX" 与后面 "XXX" 合并到一起
@@ -1502,9 +1522,7 @@ NextVersion:
GameArguments.Add("${assets_index_name}", McAssetsGetIndexName(Version))
'支持库参数
'Dim LibList As List(Of McLibToken) = McLibListGet(Version,
' Not (Version.Version.HasForge AndAlso Version.Version.McCodeMain >= 17)) '包含版本 Jar 的条件是不为 1.17+ 的 Forge
Dim LibList As List(Of McLibToken) = McLibListGet(Version, True) '如果在 1.19.x Forge 不包含版本 Jar 会导致 #188
Dim LibList As List(Of McLibToken) = McLibListGet(Version, True)
Loader.Output = LibList
Dim CpStrings As New List(Of String)
Dim OptiFineCp As String = Nothing
@@ -458,9 +458,6 @@ RetryGet:
GoTo RetryGet
End If
'若依然未找到适合的 Java,直接返回
If AllowedJavaList.Count = 0 Then Return Nothing
'检查用户指定的 Java
Dim UserSetup As String = Setup.Get("LaunchArgumentJavaSelect")
If RelatedVersion IsNot Nothing Then
@@ -495,17 +492,24 @@ RetryGet:
Dim Right As String = MaxVersion.Minor & If(MaxVersion.MinorRevision < 99, "." & MaxVersion.MinorRevision & "." & MaxVersion.Revision, "")
Requirement = "需要 Java " & If(Left = Right, Left, Left & " ~ " & Right)
End If
If MyMsgBox("你在启动设置中指定了使用 Java " & UserJava.VersionCode & ",但当前版本" & Requirement & "。" & vbCrLf &
"如果强制使用该 Java,可能会导致游戏崩溃。" & vbCrLf &
vbCrLf &
" - 指定的 Java:" & UserJava.ToString,
"Java 兼容性警告", "让 PCL2 自动选择", "强制使用该 Java") = 2 Then
If Setup.Get("LaunchAdvanceJava") Then
'直接跳过弹窗
Hint("设置中指定了使用 Java " & UserJava.VersionCode & ",但当前版本" & Requirement & ",这可能会导致游戏崩溃!", HintType.Critical)
AllowedJavaList = New List(Of JavaEntry) From {UserJava}
ElseIf MyMsgBox("你在启动设置中指定了使用 Java " & UserJava.VersionCode & ",但当前版本" & Requirement & "。" & vbCrLf &
"如果强制使用该 Java,可能会导致游戏崩溃。" & vbCrLf &
vbCrLf &
" - 指定的 Java:" & UserJava.ToString,
"Java 兼容性警告", "让 PCL2 自动选择", "强制使用该 Java") = 2 Then
'强制使用指定的 Java
Log("[Java] 已强制使用用户指定的不兼容 Java")
AllowedJavaList = New List(Of JavaEntry) From {UserJava}
End If
End If
'若依然未找到适合的 Java,直接返回
If AllowedJavaList.Count = 0 Then Return Nothing
'检查特定的 Java
For Each Java In AllowedJavaList
If TargetJavaList.Contains(Java) Then
@@ -2323,13 +2327,16 @@ NextVersion:
Dim RealVersion As McVersion
Dim RequiredJar As String = Version.JsonObject("jar")?.ToString
If Version.IsHmclFormatJson OrElse RequiredJar Is Nothing Then
'HMCL 项直接使用自身的 Jar
'根据 Inherit 获取最深层版本
'此外,HMCL 项直接使用自身的 Jar
Dim OriginalVersion As McVersion = Version
Do Until OriginalVersion.InheritVersion = ""
If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do
OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\")
Loop
'1.17+ 的 Forge 不寻找 Inherit
If Not (Version.Version.HasForge AndAlso Version.Version.McCodeMain >= 17) Then
Do Until OriginalVersion.InheritVersion = ""
If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do
OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\")
Loop
End If
'需要新建对象,否则后面的 Check 会导致 McVersionCurrent 的 State 变回 Original
'复现:启动一个 Snapshot 版本
RealVersion = New McVersion(OriginalVersion.Path)
@@ -2376,6 +2383,11 @@ NextVersion:
'转换为 LibToken
For Each Library As JObject In AllLibs.Children
'清理 null 项(BakaXL 会把没有的项序列化为 null,但会被 Newtonsoft 转换为 JValue,导致 Is Nothing = false;这导致了 #409)
For i = Library.Properties.Count - 1 To 0 Step -1
If Library.Properties(i).Value.Type = JTokenType.Null Then Library.Remove(Library.Properties(i).Name)
Next
'检查是否需要(Rules)
If Not McJsonRuleCheck(Library("rules")) Then Continue For
@@ -2508,24 +2520,26 @@ NextVersion:
If Setup.Get("VersionServerLogin", Version:=Version) = 4 OrElse
(PageLinkHiper.HiperState = LoadState.Finished AndAlso Setup.Get("LoginType") = McLoginType.Legacy) Then 'HiPer 登录转接
Dim TargetFile = PathAppdata & "authlib-injector.jar"
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByDownload({"https://download.mcbbs.net/mirrors/authlib-injector/artifact/latest.json", "https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"}, IsJson:=True))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
Dim Checker As New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)
If (IsSetupSkip AndAlso File.Exists(TargetFile)) OrElse Checker.Check(TargetFile) IsNot Nothing Then
'开始下载
Dim DownloadAddress As String = DownloadInfo("download_url")
Log("[Minecraft] Authlib-Injector 需要更新:" & DownloadAddress)
Result.Add(New NetFile({
DownloadAddress.Replace("bmclapi2.bangbang93.com", "download.mcbbs.net"), DownloadAddress
}, TargetFile, New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)))
If Not (IsSetupSkip AndAlso File.Exists(TargetFile)) Then
Dim DownloadInfo As JObject = Nothing
'获取下载信息
Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByDownload({"https://download.mcbbs.net/mirrors/authlib-injector/artifact/latest.json", "https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"}, IsJson:=True))
Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try
'校验文件
If DownloadInfo IsNot Nothing Then
Dim Checker As New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)
If (IsSetupSkip AndAlso File.Exists(TargetFile)) OrElse Checker.Check(TargetFile) IsNot Nothing Then
'开始下载
Dim DownloadAddress As String = DownloadInfo("download_url")
Log("[Minecraft] Authlib-Injector 需要更新:" & DownloadAddress)
Result.Add(New NetFile({
DownloadAddress.Replace("bmclapi2.bangbang93.com", "download.mcbbs.net"), DownloadAddress
}, TargetFile, New FileChecker(Hash:=DownloadInfo("checksums")("sha256").ToString)))
End If
End If
End If
End If
@@ -241,8 +241,12 @@ Retry:
For Each ModJson In Task.Input
'跳过重复的 Mod(疑似 CurseForge Bug)
If FileList.ContainsKey(ModJson("id").ToObject(Of Integer)) Then Continue For
'根据 modules 判断是资源包还是 Mod
Dim ModuleNames = CType(ModJson("modules"), JArray).Select(Function(l) l("name").ToString).ToList
Dim IsResourcePack As Boolean = Not ModuleNames.Contains("META-INF") AndAlso ModuleNames.Contains("pack.mcmeta")
'实际的添加
FileList.Add(ModJson("id"), New DlCfFile(ModJson, False).GetDownloadFile(PathMcFolder & "versions\" & VersionName & "\mods\", False))
FileList.Add(ModJson("id"), New DlCfFile(ModJson, False).GetDownloadFile(
PathMcFolder & "versions\" & VersionName & "\" & If(IsResourcePack, "resourcepacks", "mods") & "\", False))
Task.Progress += 1 / (1 + ModFileList.Count)
Next
Task.Output = FileList.Values.ToList
@@ -276,6 +280,14 @@ Retry:
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallExpectTime})
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeExpectTime})
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
Loaders.Add(New LoaderTask(Of String, String)("清理安装文件",
Sub(Task As LoaderTask(Of String, String))
Dim Target As String = PathMcFolder & "versions\" & VersionName & "\原始整合包.zip"
If Not Setup.Get("ToolDownloadKeepModpack") AndAlso File.Exists(Target) Then
Log("[Download] 根据设置要求删除原始整合包文件:" & Target)
File.Delete(Target)
End If
End Sub) With {.ProgressWeight = 0.1, .Show = False})
'重复任务检查
Dim LoaderName As String = "CurseForge 整合包安装:" & VersionName & " "
@@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices
' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号
' 方法是按如下所示使用“*”
<Assembly: AssemblyVersion("2.4.1.0")>
<Assembly: AssemblyFileVersion("2.4.1.0")>
<Assembly: AssemblyVersion("2.4.3.0")>
<Assembly: AssemblyFileVersion("2.4.3.0")>
<Assembly: NeutralResourcesLanguage("")>
@@ -1,8 +1,15 @@
Imports System.IO.Compression
Public Module ModDownloadLib
'如果 OptiFine 与 Forge 同时开始安装,就会导致 Forge 安装失败
''' <summary>
''' 如果 OptiFine 与 Forge 同时开始安装,就会导致 Forge 安装失败,所以在这里添加一个锁。
''' </summary>
Private InstallSyncLock As New Object
''' <summary>
''' 最高的 Minecraft 大版本号,-1 代表尚未获取。
''' </summary>
Public McVersionHighest As Integer = -1
#Region "Minecraft 下载"
@@ -114,7 +121,7 @@ Public Module ModDownloadLib
Task.Output = New List(Of NetFile) From {New NetFile(DlSourceLauncherOrMetaGet(JsonAddress), VersionFolder & VersionName & ".json")}
End Sub) With {.ProgressWeight = 2, .Show = False})
End If
Loaders.Add(New LoaderDownload("下载原版 Json 文件", New List(Of NetFile) From {
Loaders.Add(New LoaderDownload(McDownloadClientJsonName, New List(Of NetFile) From {
New NetFile(DlSourceLauncherOrMetaGet(If(JsonUrl, "")), VersionFolder & VersionName & ".json", New FileChecker(CanUseExistsFile:=False, IsJson:=True))
}) With {.ProgressWeight = 3})
@@ -159,6 +166,7 @@ Public Module ModDownloadLib
End Function
Private Const McDownloadClientLibName As String = "下载原版支持库文件"
Private Const McDownloadClientJsonName As String = "下载原版 Json 文件"
#End Region
@@ -378,7 +386,7 @@ Public Module ModDownloadLib
Throw New Exception("未找到用于安装 OptiFine 的 Java")
End If
'添加 Java Wrapper 作为主 Jar
Dim Arguments = "-Duser.home=""" & BaseMcFolderHome & """ -cp """ & Target & """ -jar """ & ExtractJavaWrapper() & """ optifine.Installer"
Dim Arguments = "-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """ -Duser.home=""" & BaseMcFolderHome & """ -cp """ & Target & """ -jar """ & ExtractJavaWrapper() & """ optifine.Installer"
If Java.VersionCode >= 9 Then Arguments = "--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED " & Arguments
'开始启动
SyncLock InstallSyncLock
@@ -518,27 +526,28 @@ Public Module ModDownloadLib
Loaders.Add(New LoaderDownload("下载 OptiFine 主文件", New List(Of NetFile)) With {.ProgressWeight = 8})
Loaders.Add(New LoaderTask(Of List(Of NetFile), Boolean)("等待原版下载",
Sub(Task As LoaderTask(Of List(Of NetFile), Boolean))
'是否已经存在原版文件
If ClientDownloadLoader Is Nothing Then Exit Sub
'等待原版文件下载完成
For Each Loader In ClientDownloadLoader.GetLoaderList
If Loader.Name <> McDownloadClientLibName Then Continue For
If Loader.State = LoadState.Loading Then
Log("[Download] OptiFine 安装正在等待原版文件下载完成")
Loader.WaitForExit()
End If
Exit For
Next
If ClientDownloadLoader Is Nothing Then Exit Sub
Dim TargetLoaders As List(Of LoaderBase) =
ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName).
Where(Function(l) l.State <> LoadState.Finished).ToList
If TargetLoaders.Count > 0 Then Log("[Download] OptiFine 安装正在等待原版文件下载完成")
Do While TargetLoaders.Count > 0 AndAlso Not Task.IsAborted
TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList
Thread.Sleep(50)
Loop
If Task.IsAborted Then Exit Sub
'拷贝原版文件
If IsCustomFolder Then
Dim ClientName As String = New DirectoryInfo(ClientDownloadLoader.Input).Name
Directory.CreateDirectory(McFolder & "versions\" & DownloadInfo.Inherit)
If Not File.Exists(McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".json") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".json", McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".json")
End If
If Not File.Exists(McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".jar") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".jar", McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".jar")
End If
If Not IsCustomFolder Then Exit Sub
Dim ClientName As String = New DirectoryInfo(ClientDownloadLoader.Input).Name
Directory.CreateDirectory(McFolder & "versions\" & DownloadInfo.Inherit)
If Not File.Exists(McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".json") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".json",
McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".json")
End If
If Not File.Exists(McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".jar") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".jar",
McFolder & "versions\" & DownloadInfo.Inherit & "\" & DownloadInfo.Inherit & ".jar")
End If
End Sub) With {.ProgressWeight = 0.1, .Show = False})
@@ -876,8 +885,8 @@ Public Module ModDownloadLib
'构造版本 Json
Dim VersionJson As New JObject
VersionJson.Add("id", VersionName)
VersionJson.Add("time", DateTime.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm:ss", Globalization.CultureInfo.CurrentCulture))
VersionJson.Add("releaseTime", DateTime.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm:ss", Globalization.CultureInfo.CurrentCulture))
VersionJson.Add("time", Date.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm", Globalization.CultureInfo.CurrentCulture))
VersionJson.Add("releaseTime", Date.ParseExact(DownloadInfo.ReleaseTime, "yyyy/MM/dd HH:mm", Globalization.CultureInfo.CurrentCulture))
VersionJson.Add("type", "release")
VersionJson.Add("arguments", GetJson("{""game"":[""--tweakClass"",""" & DownloadInfo.JsonToken("tweakClass").ToString & """]}"))
VersionJson.Add("libraries", DownloadInfo.JsonToken("libraries"))
@@ -1094,7 +1103,7 @@ Public Module ModDownloadLib
Throw New Exception("未找到用于安装 Forge 的 Java")
End If
'添加 Java Wrapper 作为主 Jar
Dim Arguments = "-cp """ & PathTemp & "Cache\forge_installer.jar;" & Target & """ -jar """ & ExtractJavaWrapper() & """ com.bangbang93.ForgeInstaller """ & McFolder
Dim Arguments = "-Doolloo.jlw.tmpdir=""" & GetJavaWrapperDir() & """ -cp """ & PathTemp & "Cache\forge_installer.jar;" & Target & """ -jar """ & ExtractJavaWrapper() & """ com.bangbang93.ForgeInstaller """ & McFolder
If Java.VersionCode >= 9 Then Arguments = "--add-exports cpw.mods.bootstraplauncher/cpw.mods.bootstraplauncher=ALL-UNNAMED " & Arguments
'开始启动
SyncLock InstallSyncLock
@@ -1329,27 +1338,26 @@ Public Module ModDownloadLib
End If
#End Region
#Region "原版文件"
'是否已经存在原版文件
If ClientDownloadLoader Is Nothing Then Exit Sub
'等待原版文件下载完成
For Each Loader In ClientDownloadLoader.GetLoaderList
If Loader.Name <> McDownloadClientLibName Then Continue For
If Loader.State = LoadState.Loading Then
Log("[Download] Forge 安装正在等待原版文件下载完成")
Loader.WaitForExit()
End If
Exit For
Next
If ClientDownloadLoader Is Nothing Then Exit Sub
Dim TargetLoaders As List(Of LoaderBase) =
ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName).
Where(Function(l) l.State <> LoadState.Finished).ToList
If TargetLoaders.Count > 0 Then Log("[Download] Forge 安装正在等待原版文件下载完成")
Do While TargetLoaders.Count > 0 AndAlso Not Task.IsAborted
TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList
Thread.Sleep(50)
Loop
If Task.IsAborted Then Exit Sub
'拷贝原版文件
If IsCustomFolder Then
Dim ClientName As String = New DirectoryInfo(ClientDownloadLoader.Input).Name
Directory.CreateDirectory(McFolder & "versions\" & Inherit)
If Not File.Exists(McFolder & "versions\" & Inherit & "\" & Inherit & ".json") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".json", McFolder & "versions\" & Inherit & "\" & Inherit & ".json")
End If
If Not File.Exists(McFolder & "versions\" & Inherit & "\" & Inherit & ".jar") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".jar", McFolder & "versions\" & Inherit & "\" & Inherit & ".jar")
End If
If Not IsCustomFolder Then Exit Sub
Dim ClientName As String = New DirectoryInfo(ClientDownloadLoader.Input).Name
Directory.CreateDirectory(McFolder & "versions\" & Inherit)
If Not File.Exists(McFolder & "versions\" & Inherit & "\" & Inherit & ".json") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".json", McFolder & "versions\" & Inherit & "\" & Inherit & ".json")
End If
If Not File.Exists(McFolder & "versions\" & Inherit & "\" & Inherit & ".jar") Then
CopyFile(ClientDownloadLoader.Input & ClientName & ".jar", McFolder & "versions\" & Inherit & "\" & Inherit & ".jar")
End If
#End Region
End Sub) With {.ProgressWeight = 0.1, .Show = False})
@@ -2074,20 +2082,23 @@ Public Module ModDownloadLib
#Region "处理 Json 文件"
'获取 minecraftArguments
Dim AllArguments As String =
If(MinecraftJson("minecraftArguments"), " ").ToString &
If(OptiFineJson IsNot Nothing, If(OptiFineJson("minecraftArguments"), " ").ToString, " ") &
If(ForgeJson IsNot Nothing, If(ForgeJson("minecraftArguments"), " ").ToString, " ") &
If(MinecraftJson("minecraftArguments"), " ").ToString & " " &
If(OptiFineJson IsNot Nothing, If(OptiFineJson("minecraftArguments"), " ").ToString, " ") & " " &
If(ForgeJson IsNot Nothing, If(ForgeJson("minecraftArguments"), " ").ToString, " ") & " " &
If(LiteLoaderJson IsNot Nothing, If(LiteLoaderJson("minecraftArguments"), " ").ToString, " ")
'分割参数字符串
Dim RawArguments As List(Of String) = AllArguments.Split(" ").Where(Function(l) l <> "").Select(Function(l) l.Trim).ToList
Dim SplitArguments As New List(Of String)
For Each Argument In AllArguments.Split("--")
Argument = Argument.Trim
If Argument <> "" Then SplitArguments.Add(Argument)
For i = 0 To RawArguments.Count - 1
If RawArguments(i).StartsWith("-") Then
SplitArguments.Add(RawArguments(i))
ElseIf SplitArguments.Count > 0 AndAlso SplitArguments.Last.StartsWith("-") AndAlso Not SplitArguments.Last.Contains(" ") Then
SplitArguments(SplitArguments.Count - 1) = SplitArguments.Last & " " & RawArguments(i)
Else
SplitArguments.Add(RawArguments(i))
End If
Next
SplitArguments = ArrayNoDouble(SplitArguments)
Dim RealArguments As String = Nothing
If SplitArguments.Count > 0 Then
RealArguments = If(AllArguments.StartsWith("--"), "--", "") & Join(SplitArguments, " --")
End If
Dim RealArguments As String = Join(ArrayNoDouble(SplitArguments), " ")
'合并
OutputJson = MinecraftJson
If HasOptiFine Then
@@ -167,11 +167,7 @@
Loaders.Add(New LoaderDownload("下载整合包文件", New List(Of NetFile) From {File.GetDownloadFile(Target, True)}) With {.ProgressWeight = 10, .Block = True})
Loaders.Add(New LoaderTask(Of Integer, Integer)("准备安装整合包",
Sub()
If Not ModpackInstall(Target, VersionName) Then Throw New Exception("整合包安装过程中出现异常!")
If Not Setup.Get("ToolDownloadKeepModpack") Then
Log("[Download] 根据设置要求删除原始整合包文件:" & Target)
IO.File.Delete(Target)
End If
If Not ModpackInstall(Target, VersionName) Then Throw New Exception("整合包安装出现异常!")
End Sub) With {.ProgressWeight = 0.1})
'启动
@@ -196,63 +192,124 @@
End Try
End Sub
'Mod 下载;整合包另存为
Public Shared DownloadFolder = Nothing '仅在本次缓存的下载文件夹
Public Shared CachedFolder As String = Nothing '仅在本次缓存的下载文件夹
Public Sub Save_Click(sender As Object, e As EventArgs)
Try
Dim Desc As String = If(Project.IsModPack, "整合包", "Mod ")
'确认默认保存位置
Dim DefaultFolder As String = Nothing
If Not Project.IsModPack Then
DefaultFolder = DownloadFolder
If McVersionCurrent IsNot Nothing Then
If Not McVersionCurrent.IsLoaded Then McVersionCurrent.Load()
If McVersionCurrent.Modable Then
Dim File As DlCfFile = If(TypeOf sender Is MyListItem, sender, sender.Parent).Tag
RunInNewThread(
Sub()
Try
Dim Desc As String = If(Project.IsModPack, "整合包", "Mod ")
'确认默认保存位置
Dim DefaultFolder As String = Nothing
If Not Project.IsModPack Then
'获取 Mod 所需的加载器种类
Dim AllowForge As Boolean? = Nothing, AllowFabric As Boolean? = Nothing 'FUTURE: Quilt 支持
If File.ModLoaders.Count > 0 Then '从文件中获取
AllowForge = False : AllowFabric = False
For Each LoaderType In File.ModLoaders
If LoaderType = "Forge" Then AllowForge = True
If LoaderType = "Fabric" Then AllowFabric = True
Next
ElseIf Project.ModLoaders.Count > 0 Then '从工程中获取
AllowForge = False : AllowFabric = False
For Each LoaderType In Project.ModLoaders
If LoaderType = "Forge" Then AllowForge = True
If LoaderType = "Fabric" Then AllowFabric = True
Next
End If
If AllowForge IsNot Nothing AndAlso Not AllowForge AndAlso
AllowFabric IsNot Nothing AndAlso Not AllowFabric Then
AllowForge = Nothing : AllowFabric = Nothing
End If
Log("[Download] 允许 Forge:" & If(AllowForge, "未知") & ",允许 Fabric:" & If(AllowFabric, "未知"))
'判断某个版本是否符合要求
Dim IsVersionSuitable As Func(Of McVersion, Boolean) =
Function(Version)
If Not Version.IsLoaded Then Version.Load()
If Not Version.Modable Then Return False
If File.GameVersion.Any(Function(v) v.Contains(".")) AndAlso
Not File.GameVersion.Any(Function(v) v.Contains(".") AndAlso v.Split(".")(1) = Version.Version.McCodeMain) Then Return False
If AllowForge Is Nothing OrElse AllowFabric Is Nothing Then Return True
If AllowForge AndAlso Version.Version.HasForge Then Return True
If AllowFabric AndAlso Version.Version.HasFabric Then Return True
Return False
End Function
'获取 Mod 默认下载位置
If CachedFolder IsNot Nothing Then
DefaultFolder = CachedFolder
Log("[Download] 使用上次下载时的文件夹作为默认下载位置")
ElseIf McVersionCurrent IsNot Nothing AndAlso IsVersionSuitable(McVersionCurrent) Then
DefaultFolder = McVersionCurrent.PathIndie & "mods\"
Directory.CreateDirectory(DefaultFolder)
Log("[Download] 使用当前版本的 mods 文件夹作为默认下载位置(" & McVersionCurrent.Name & ")")
Else
Dim NeedLoad As Boolean = McVersionListLoader.State <> LoadState.Finished
If NeedLoad Then
Hint("正在查找适合的游戏版本……")
LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True)
End If
Dim SuitableVersions As New List(Of McVersion)
For Each Version As McVersion In McVersionList.Values.SelectMany(Function(l) l)
If IsVersionSuitable(Version) Then SuitableVersions.Add(Version)
Next
If SuitableVersions.Count = 0 Then
DefaultFolder = PathMcFolder
If NeedLoad Then
Hint("当前 MC 文件夹中未找到适合这个 Mod 的游戏版本")
Else
Log("[Download] 由于当前版本不兼容,使用当前的 MC 文件夹作为默认下载位置")
End If
Else '选择 Mod 数量最多的版本
Dim SelectedVersion = SuitableVersions.OrderBy(Function(v)
Dim Info As New DirectoryInfo(v.PathIndie & "mods\")
Return If(Info.Exists, Info.GetFiles().Length, -1)
End Function).LastOrDefault()
DefaultFolder = SelectedVersion.PathIndie & "mods\"
Directory.CreateDirectory(DefaultFolder)
Log("[Download] 使用适合的游戏版本作为默认下载位置(" & SelectedVersion.Name & ")")
End If
End If
End If
If String.IsNullOrEmpty(DefaultFolder) Then DefaultFolder = Nothing
End If
'获取基本信息
Dim File As DlCfFile = If(TypeOf sender Is MyListItem, sender, sender.Parent).Tag
Dim ChineseName As String = If(Project.ChineseName = Project.Name, "",
Project.ChineseName.Replace(" (", "Å").Split("Å").First.Replace("\", "\").Replace("/", "/").Replace("|", "|").Replace(":", ":").Replace("<", "<").Replace(">", ">").Replace("*", "*").Replace("?", "?").Replace("""", "").Replace(": ", ":"))
Dim FileName As String
Select Case Setup.Get("ToolDownloadTranslate")
Case 0
FileName = If(ChineseName = "", "", "[" & ChineseName & "] ") & File.FileName
Case 1
FileName = If(ChineseName = "", "", ChineseName & "-") & File.FileName
Case 2
FileName = File.FileName & If(ChineseName = "", "", "-" & ChineseName)
Case Else
FileName = File.FileName
End Select
Dim Target As String
If File.FileName.EndsWith(".litemod") Then
Target = SelectAs("选择保存位置", FileName, Desc & "文件|" & If(Project.IsModPack, "*.zip", "*.litemod"), DefaultFolder)
Else
Target = SelectAs("选择保存位置", FileName, Desc & "文件|" & If(Project.IsModPack, "*.zip", "*.jar"), DefaultFolder)
End If
If Not Target.Contains("\") Then Exit Sub
Dim LoaderName As String = Desc & "下载:" & File.DisplayName & " "
If Target <> DefaultFolder AndAlso Not Project.IsModPack Then DownloadFolder = GetPathFromFullPath(Target)
'构造步骤加载器
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.GetDownloadFile(Target, True)}) With {.ProgressWeight = 6, .Block = True})
'启动
Dim Loader As New LoaderCombo(Of Integer)(LoaderName, Loaders) With {.OnStateChanged = AddressOf DownloadStateSave}
Loader.Start(1)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
Catch ex As Exception
Log(ex, "保存 CurseForge 文件失败", LogLevel.Feedback)
End Try
'获取基本信息
Dim ChineseName As String = If(Project.ChineseName = Project.Name, "",
Project.ChineseName.Replace(" (", "Å").Split("Å").First.Replace("\", "\").Replace("/", "/").Replace("|", "|").Replace(":", ":").Replace("<", "<").Replace(">", ">").Replace("*", "*").Replace("?", "?").Replace("""", "").Replace(": ", ":"))
Dim FileName As String
Select Case Setup.Get("ToolDownloadTranslate")
Case 0
FileName = If(ChineseName = "", "", "[" & ChineseName & "] ") & File.FileName
Case 1
FileName = If(ChineseName = "", "", ChineseName & "-") & File.FileName
Case 2
FileName = File.FileName & If(ChineseName = "", "", "-" & ChineseName)
Case Else
FileName = File.FileName
End Select
RunInUi(
Sub()
'弹窗要求选择保存位置
Dim Target As String
If File.FileName.EndsWith(".litemod") Then
Target = SelectAs("选择保存位置", FileName, Desc & "文件|" & If(Project.IsModPack, "*.zip", "*.litemod"), DefaultFolder)
Else
Target = SelectAs("选择保存位置", FileName, Desc & "文件|" & If(Project.IsModPack, "*.zip", "*.jar"), DefaultFolder)
End If
If Not Target.Contains("\") Then Exit Sub
'构造步骤加载器
Dim LoaderName As String = Desc & "下载:" & File.DisplayName & " "
If Target <> DefaultFolder AndAlso Not Project.IsModPack Then CachedFolder = GetPathFromFullPath(Target)
Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.GetDownloadFile(Target, True)}) With {.ProgressWeight = 6, .Block = True})
'启动
Dim Loader As New LoaderCombo(Of Integer)(LoaderName, Loaders) With {.OnStateChanged = AddressOf DownloadStateSave}
Loader.Start(1)
LoaderTaskbarAdd(Loader)
FrmMain.BtnExtraDownload.ShowRefresh()
FrmMain.BtnExtraDownload.Ribble()
End Sub)
Catch ex As Exception
Log(ex, "保存 CurseForge 文件失败", LogLevel.Feedback)
End Try
End Sub, "Download CFDetail Save")
End Sub
Private Sub BtnIntroCf_Click(sender As Object, e As EventArgs) Handles BtnIntroCf.Click
@@ -15,7 +15,7 @@
</local:MyListItem>
<local:MyListItem x:Name="ItemHand" IsScaleAnimationEnabled="False" Type="RadioBox" PaddingRight="35" Height="36" VerticalAlignment="Top" Title="手动安装包"
LogoScale="1.02" Logo="M292.693 787.627c0 30.72-24.746 55.466-55.466 55.466s-55.467-24.746-55.467-55.466 24.747-55.467 55.467-55.467c30.72-0.853 55.466 24.747 55.466 55.467z M1000.96 241.493c-2.56-5.973-4.267-11.946-6.827-17.92-0.853-6.826-4.266-12.8-8.533-17.92-7.68-9.386-18.773-15.36-31.573-15.36-6.827 0-13.654 1.707-19.627 5.12l-15.36 15.36-17.067 17.067-21.333 21.333L749.227 381.44c-14.507 14.507-38.4 14.507-52.907 0l-54.613-54.613c-14.507-14.507-14.507-38.4 0-52.907l132.266-132.267 14.507-14.506 20.48-20.48 16.213-16.214c3.414-5.973 5.12-11.946 5.12-19.626 0-12.8-5.973-24.747-16.213-32.427-5.973-4.267-11.947-6.827-18.773-7.68-5.12-2.56-10.24-4.267-16.214-5.973-36.693-12.8-76.8-19.627-117.76-19.627-7.68 0-14.506 0-22.186 0.853-188.587 11.947-337.92 168.107-337.92 360.96 0 16.214 0.853 32.427 3.413 48.64L56.32 663.04c-73.387 74.24-73.387 193.707 0 267.093l33.28 33.28c73.387 73.387 193.707 73.387 267.093 0l240.64-241.493c21.334 4.267 42.667 5.973 64 5.973 190.294 0 346.454-146.773 360.107-333.653 0.853-8.533 0.853-17.92 0.853-27.307 0.854-44.373-6.826-86.186-21.333-125.44zM658.773 639.147c-28.16 0-54.613-4.267-79.36-11.094-4.266 7.68-10.24 14.507-16.213 21.334l-258.56 258.56c-43.52 43.52-115.2 43.52-158.72 0l-29.013-29.014c-43.52-44.373-43.52-115.2 0-158.72l212.48-212.48 46.08-46.08c5.973-5.973 12.8-11.093 19.626-15.36-8.533-26.453-12.8-54.613-12.8-83.626v-1.707c0-152.747 123.734-275.627 276.48-275.627 18.774 0 37.547 1.707 55.467 5.974L597.333 207.36c-52.053 52.053-52.053 137.387 0 189.44l29.867 29.867c52.053 52.053 137.387 52.053 189.44 0L930.987 312.32c2.56 16.213 4.266 33.28 4.266 50.347 0 152.746-123.733 276.48-276.48 276.48z" />
<TextBlock x:Name="LabHand" Visibility="Collapsed" Text="手动安装包" Margin="13,18,5,4" Opacity="0.6" FontSize="12" />
<TextBlock x:Name="LabHand" Visibility="Collapsed" Text="▼ 手动安装包" Padding="11,18,5,4" Opacity="0.6" FontSize="12" />
<local:MyListItem x:Name="ItemClient" Visibility="Collapsed" IsScaleAnimationEnabled="False" Type="RadioBox" Tag="4" PaddingRight="35" Height="36" VerticalAlignment="Top" Title="Minecraft"
LogoScale="0.98" Logo="M989.7 510.8l-202.3-101c-10.8-5.4-17.7-16.5-17.7-28.6V172.7c0-26.7-16.6-50.6-41.6-59.9L550.5 46.3c-24.2-9-50.8-9-74.9 0.1l-176.9 66.8c-24.9 9.4-41.4 33.2-41.4 59.9v207.1c0 12.1-6.9 23.2-17.7 28.6l-204 101.9C13.9 521.6 0.1 543.8 0.2 568.1l0.5 226c0 23.2 12.6 44.5 32.9 55.8l223.8 124.6 1.2 0.7c18.9 10.5 41.9 10.4 60.8-0.2l2-1.1L497 873.2c9.9-5.7 22.1-5.6 32 0.1l176.7 102.5c18.9 10.7 42 10.8 61 0.3l3-1.7L992.4 851c20.4-11.3 33-32.8 33-56l-0.3-226.9c0-24.3-13.7-46.5-35.4-57.3zM321 192l115.3 46.1c27 10.8 44.7 36.9 44.7 66v163c0 5.9-6.2 9.8-11.6 7.2L339 409.5c-10.9-5.4-17.7-16.5-17.8-28.6L321 192z m-63.7 703.4L82.5 809.6c-10.9-5.4-17.9-16.5-17.9-28.7l-0.4-189.5L217.9 668c24.1 12 39.4 36.7 39.4 63.6v163.8z m64-274.3c-20.1 10.1-43.7 10-63.8 0l-0.2-0.1-149.1-75 149.1-74.4 16.8-8.4c9.2-4.6 20-4.5 29.1 0.3l18.1 9.4 129.8 64.3c5.8 2.9 6 11.1 0.2 14.2l-130 69.7z m141.9 203.8l-141.8 70.6-0.8-163.6c-0.1-27 15.1-51.8 39.2-63.9l108.8-54.5c5.3-2.7 11.6 1.2 11.6 7.1l0.8 175.6c0 12.1-6.9 23.2-17.8 28.7zM385 144l128-48 128 48-103 38.6c-16.1 6-33.8 6-49.9 0L385 144z m320 48l0.6 187.8c0 12.2-6.8 23.3-17.7 28.7l-131.4 65.7c-5.3 2.7-11.6-1.2-11.6-7.2V304.1c0-29.1 17.7-55.2 44.7-66L705 192z m0.7 710.3l-143.8-77.2c-10.4-5.6-16.9-16.4-16.9-28.2v-176c0-5.9 6.3-9.8 11.6-7.2l109.3 54.6c24 12 39.2 36.5 39.3 63.4l0.5 170.6z m-2-280.5l-129.2-70.5c-5.7-3.1-5.5-11.3 0.3-14.2l131-65.3 16.1-8.5c9.1-4.8 19.9-4.9 29.1-0.3l18.7 9.3L916.9 546l-146.2 76.4c-21.1 11-46.2 10.8-67-0.6z m66 279.4l-0.6-169.1c-0.1-27 15.1-51.7 39.3-63.8L961 592v188.7c0 11.9-6.6 22.7-17 28.3l-174.3 92.2z">
<!--Logo="M469.333333 213.333333V128a42.666667 42.666667 0 1 1 85.333334 0v85.333333h127.829333C847.722667 213.333333 981.333333 347.029333 981.333333 512.149333v319.936A106.496 106.496 0 0 1 874.730667 938.666667h-85.461334c-48.661333 0-107.221333-29.290667-136.469333-68.266667l-64-85.333333c-6.144-8.170667-23.957333-17.066667-34.24-17.066667h-85.12c-10.282667 0-28.096 8.896-34.24 17.066667l-64 85.333333c-29.226667 38.976-87.808 68.266667-136.469333 68.266667H149.269333A106.496 106.496 0 0 1 42.666667 832.085333V512.149333C42.666667 347.029333 176.277333 213.333333 341.504 213.333333H469.333333z m213.162667 85.333334H341.504A213.333333 213.333333 0 0 0 128 512.149333v319.936c0 11.818667 9.450667 21.248 21.269333 21.248h85.461334c21.802667 0 55.082667-16.64 68.202666-34.133333l64-85.333333c22.272-29.696 65.408-51.2 102.506667-51.2h85.12c37.098667 0 80.213333 21.504 102.506667 51.2l64 85.333333c13.12 17.493333 46.4 34.133333 68.202666 34.133333h85.461334a21.162667 21.162667 0 0 0 21.269333-21.248V512.149333A213.333333 213.333333 0 0 0 682.496 298.666667zM362.666667 469.333333h42.666666a42.666667 42.666667 0 1 1 0 85.333334h-42.666666v42.666666a42.666667 42.666667 0 1 1-85.333334 0v-42.666666h-42.666666a42.666667 42.666667 0 1 1 0-85.333334h42.666666v-42.666666a42.666667 42.666667 0 1 1 85.333334 0v42.666666z m341.333333-21.333333a42.666667 42.666667 0 1 1 0-85.333333 42.666667 42.666667 0 0 1 0 85.333333z m0 213.333333a42.666667 42.666667 0 1 1 0-85.333333 42.666667 42.666667 0 0 1 0 85.333333z m-106.666667-106.666666a42.666667 42.666667 0 1 1 0-85.333334 42.666667 42.666667 0 0 1 0 85.333334z m213.333334 0a42.666667 42.666667 0 1 1 0-85.333334 42.666667 42.666667 0 0 1 0 85.333334z">-->
@@ -51,28 +51,17 @@
<TextBlock VerticalAlignment="Center" Grid.Row="2" Grid.Column="3" HorizontalAlignment="Left" Text="版本" Margin="0,0,25,0" />
<local:MyComboBox x:Name="TextSearchVersion" Grid.Row="2" Grid.Column="4" Grid.ColumnSpan="2" IsEditable="True" MaxDropDownHeight="320" HintText="全部 (也可自行输入)">
<local:MyComboBoxItem Content="" IsSelected="True" />
<local:MyComboBoxItem Content="1.19.3" />
<local:MyComboBoxItem Content="1.19.2" />
<local:MyComboBoxItem Content="1.19.1" />
<local:MyComboBoxItem Content="1.19" />
<local:MyComboBoxItem Content="1.18.2" />
<local:MyComboBoxItem Content="1.18.1" />
<local:MyComboBoxItem Content="1.18" />
<local:MyComboBoxItem Content="1.17.1" />
<local:MyComboBoxItem Content="1.17" />
<local:MyComboBoxItem Content="1.16.5" />
<local:MyComboBoxItem Content="1.16.4" />
<local:MyComboBoxItem Content="1.16.3" />
<local:MyComboBoxItem Content="1.16.2" />
<local:MyComboBoxItem Content="1.16.1" />
<local:MyComboBoxItem Content="1.16" />
<local:MyComboBoxItem Content="1.15.2" />
<local:MyComboBoxItem Content="1.15" />
<local:MyComboBoxItem Content="1.14.4" />
<local:MyComboBoxItem Content="1.14" />
<local:MyComboBoxItem Content="1.13.2" />
<local:MyComboBoxItem Content="1.13" />
<local:MyComboBoxItem Content="1.12.2" />
<local:MyComboBoxItem Content="1.12" />
<local:MyComboBoxItem Content="1.11.2" />
<local:MyComboBoxItem Content="1.10.2" />
<local:MyComboBoxItem Content="1.9.4" />
@@ -83,9 +72,10 @@
<local:MyComboBoxItem Content="1.5.2" />
</local:MyComboBox>
<local:MyComboBox x:Name="ComboSearchLoader" Visibility="Collapsed" Grid.Row="2" Grid.Column="5" MaxDropDownHeight="320" Margin="10,0,0,0">
<local:MyComboBoxItem Content="Forge 或 Fabric" IsSelected="True" Tag="0" />
<local:MyComboBoxItem Content="任意 Mod 加载器" IsSelected="True" Tag="0" />
<local:MyComboBoxItem Content="Forge" Tag="1" />
<local:MyComboBoxItem Content="Fabric" Tag="4" />
<local:MyComboBoxItem Content="Quilt" Tag="5" />
</local:MyComboBox>
</Grid>
<Grid Margin="0,4,0,6" Height="35">
@@ -3,6 +3,7 @@
'初始化加载器信息
Private Sub PageDownloadMod_Inited(sender As Object, e As EventArgs) Handles Me.Initialized
PageLoaderInit(Load, PanLoad, CardProjects, PanAlways, Loader, AddressOf Load_OnFinish, AddressOf LoaderInput)
McVersionHighest = Math.Max(McVersionHighest, Integer.Parse(CType(TextSearchVersion.Items(1), MyComboBoxItem).Content.ToString.Split(".")(1)))
End Sub
Public Shared Loader As New LoaderTask(Of DlCfProjectRequest, DlCfProjectResult)("DlCfProject Mod", AddressOf DlCfProjectSub, AddressOf LoaderInput) With {.ReloadTimeout = 60 * 1000}
Private Shared Function LoaderInput() As DlCfProjectRequest
@@ -47,42 +47,21 @@
<TextBlock VerticalAlignment="Center" Grid.Row="2" Grid.Column="3" HorizontalAlignment="Left" Text="版本" Margin="0,0,25,0" />
<local:MyComboBox x:Name="TextSearchVersion" Grid.Row="2" Grid.Column="4" IsEditable="True" MaxDropDownHeight="320" HintText="全部 (也可自行输入)">
<local:MyComboBoxItem Content="" IsSelected="True" />
<local:MyComboBoxItem Content="1.19.3" />
<local:MyComboBoxItem Content="1.19.2" />
<local:MyComboBoxItem Content="1.19.1" />
<local:MyComboBoxItem Content="1.19" />
<local:MyComboBoxItem Content="1.18.2" />
<local:MyComboBoxItem Content="1.18.1" />
<local:MyComboBoxItem Content="1.18" />
<local:MyComboBoxItem Content="1.17.1" />
<local:MyComboBoxItem Content="1.17" />
<local:MyComboBoxItem Content="1.16.5" />
<local:MyComboBoxItem Content="1.16.4" />
<local:MyComboBoxItem Content="1.16.3" />
<local:MyComboBoxItem Content="1.16.2" />
<local:MyComboBoxItem Content="1.16.1" />
<local:MyComboBoxItem Content="1.16" />
<local:MyComboBoxItem Content="1.15.2" />
<local:MyComboBoxItem Content="1.15.1" />
<local:MyComboBoxItem Content="1.15" />
<local:MyComboBoxItem Content="1.14.4" />
<local:MyComboBoxItem Content="1.14.3" />
<local:MyComboBoxItem Content="1.14.2" />
<local:MyComboBoxItem Content="1.14.1" />
<local:MyComboBoxItem Content="1.14" />
<local:MyComboBoxItem Content="1.13.2" />
<local:MyComboBoxItem Content="1.13.1" />
<local:MyComboBoxItem Content="1.13" />
<local:MyComboBoxItem Content="1.12.2" />
<local:MyComboBoxItem Content="1.12.1" />
<local:MyComboBoxItem Content="1.12" />
<local:MyComboBoxItem Content="1.11.2" />
<local:MyComboBoxItem Content="1.11" />
<local:MyComboBoxItem Content="1.10.2" />
<local:MyComboBoxItem Content="1.10" />
<local:MyComboBoxItem Content="1.9.4" />
<local:MyComboBoxItem Content="1.9" />
<local:MyComboBoxItem Content="1.8.9" />
<local:MyComboBoxItem Content="1.8" />
<local:MyComboBoxItem Content="1.7.10" />
<local:MyComboBoxItem Content="1.7.2" />
<local:MyComboBoxItem Content="1.6.4" />
@@ -3,6 +3,7 @@
'初始化加载器信息
Private Sub PageDownloadMod_Inited(sender As Object, e As EventArgs) Handles Me.Initialized
PageLoaderInit(Load, PanLoad, CardProjects, PanAlways, Loader, AddressOf Load_OnFinish, AddressOf LoaderInput)
McVersionHighest = Math.Max(McVersionHighest, Integer.Parse(CType(TextSearchVersion.Items(1), MyComboBoxItem).Content.ToString.Split(".")(1)))
End Sub
Public Shared Loader As New LoaderTask(Of DlCfProjectRequest, DlCfProjectResult)("DlCfProject ModPack", AddressOf DlCfProjectSub, AddressOf LoaderInput) With {.ReloadTimeout = 60 * 1000}
Private Shared Function LoaderInput() As DlCfProjectRequest
@@ -83,12 +83,21 @@
'加载
Dim Image As New MyBitmap(Address)
ImgBack.Tag = Address
'大小检查
Dim Scale As Integer = Image.Pic.Width / 64
If Image.Pic.Width < 32 OrElse Image.Pic.Height < 32 Then
ImgFore.Source = Nothing : ImgBack.Source = Nothing
Throw New Exception("图片大小不足,长为 " & Image.Pic.Height & ",宽为 " & Image.Pic.Width)
End If
'头发层(附加层)
If Image.Pic.Width >= 64 AndAlso Image.Pic.Height >= 32 Then
'如果图片中有透明像素,或是头部颜色和透明区均不一样,则加载附加层
If (Image.Pic.GetPixel(1, 1).A = 0 OrElse Image.Pic.GetPixel(Image.Pic.Width - 1, Image.Pic.Height - 1).A = 0 OrElse Image.Pic.GetPixel(Image.Pic.Width - 2, 2).A = 0) OrElse
(Image.Pic.GetPixel(1, 1) <> Image.Pic.GetPixel(41, 9) AndAlso Image.Pic.GetPixel(Image.Pic.Width - 1, Image.Pic.Height - 1) <> Image.Pic.GetPixel(41, 9) AndAlso Image.Pic.GetPixel(Image.Pic.Width - 2, 2) <> Image.Pic.GetPixel(41, 9)) Then
ImgFore.Source = New CroppedBitmap(Image, New Int32Rect(40, 8, 8, 8))
If (Image.Pic.GetPixel(1, 1).A = 0 OrElse '如果图片中有任何透明像素(避免纯色白底)
Image.Pic.GetPixel(Image.Pic.Width - 1, Image.Pic.Height - 1).A = 0 OrElse
Image.Pic.GetPixel(Image.Pic.Width - 2, Image.Pic.Height / 2 - 2).A = 0) OrElse
(Image.Pic.GetPixel(1, 1) <> Image.Pic.GetPixel(Scale * 41, Scale * 9) AndAlso '或是头部颜色和透明区均不一样
Image.Pic.GetPixel(Image.Pic.Width - 1, Image.Pic.Height - 1) <> Image.Pic.GetPixel(Scale * 41, Scale * 9) AndAlso
Image.Pic.GetPixel(Image.Pic.Width - 2, Image.Pic.Height / 2 - 2) <> Image.Pic.GetPixel(Scale * 41, Scale * 9)) Then
ImgFore.Source = New CroppedBitmap(Image, New Int32Rect(Scale * 40, Scale * 8, Scale * 8, Scale * 8))
Else
ImgFore.Source = Nothing
End If
@@ -96,13 +105,8 @@
ImgFore.Source = Nothing
End If
'脸层
If Image.Pic.Width >= 32 AndAlso Image.Pic.Height >= 32 Then
ImgBack.Source = New CroppedBitmap(Image, New Int32Rect(8, 8, 8, 8))
Log("[Skin] 载入头像成功:" & Loader.Name)
Else
ImgBack.Source = Nothing
Throw New Exception("图片大小不足,长为 " & Image.Pic.Height & ",宽为 " & Image.Pic.Width)
End If
ImgBack.Source = New CroppedBitmap(Image, New Int32Rect(Scale * 8, Scale * 8, Scale * 8, Scale * 8))
Log("[Skin] 载入头像成功:" & Loader.Name)
Catch ex As Exception
Log(ex, "载入头像失败(" & If(Address, "null") & "," & Loader.Name & ")", LogLevel.Hint)
End Try
@@ -0,0 +1,952 @@
Public Class PageLinkHiper
Public Const RequestVersion As Char = "2"
'记录的启动情况
Public Shared IsServerSide As Boolean
Private Shared HostIp As String
Private Shared HostPort As Integer
#Region "初始化"
'加载器初始化
Private Sub LoaderInit() Handles Me.Initialized
PageLoaderInit(Load, PanLoad, PanContent, PanAlways, InitLoader, AutoRun:=False)
'注册自定义的 OnStateChanged
AddHandler InitLoader.OnStateChangedUi, AddressOf OnLoadStateChanged
End Sub
Private IsLoad As Boolean = False
Private Sub OnLoaded() Handles Me.Loaded
If IsLoad Then Exit Sub
IsLoad = True
'启动监视线程
If Not IsWatcherStarted Then RunInNewThread(AddressOf WatcherThread, "Hiper Watcher")
'读取索引码
Try
Dim Time As String = Setup.Get("LinkHiperCertTime")
If Time = "" Then
Log("[HiPer] 没有缓存凭证")
ElseIf Date.Parse(Time) > Date.Now Then
TextCert.Text = Setup.Get("LinkHiperCertLast")
Log("[HiPer] 缓存凭证尚未过期:" & Time)
CurrentSubpage = Subpages.PanSelect
Else
Log("[HiPer] 缓存凭证已过期:" & Time)
LabCertTitle.Text = "输入索引码"
LabCertDesc.Text = "你的 HiPer 索引码已经过期,请输入新的索引码。" & vbCrLf & "如果实在没有索引码,可以在左侧选择 IOI 方式联机。"
End If
Catch ex As Exception
Log(ex, "读取缓存凭证失败")
Setup.Set("LinkHiperCertTime", "")
End Try
End Sub
#End Region
#Region "加载步骤"
Public Shared PathHiper As String = PathAppdata & "联机模块\"
Public Shared WithEvents InitLoader As New LoaderCombo(Of Integer)("HiPer 初始化", {
New LoaderTask(Of Integer, Integer)("网络环境:连通检测", AddressOf InitPingCheck) With {.Block = False, .ProgressWeight = 0.5},
New LoaderTask(Of Integer, Integer)("网络环境:IP 检测", AddressOf InitIpCheck) With {.Block = False, .ProgressWeight = 1},
New LoaderTask(Of Integer, Integer)("检查网络环境", AddressOf InitCheck) With {.ProgressWeight = 0.5},
New LoaderTask(Of Integer, List(Of NetFile))("获取所需文件", AddressOf InitGetFile) With {.ProgressWeight = 4},
New LoaderDownload("下载所需文件", New List(Of NetFile)) With {.ProgressWeight = 4},
New LoaderTask(Of Integer, Integer)("启动联机模块", AddressOf InitLaunch) With {.ProgressWeight = 7}
})
'检查网络状态
Private Shared Sub InitPingCheck(Task As LoaderTask(Of Integer, Integer))
PingTime = 0
Try
Log("[HiPer] 网络检测:连通检测开始")
Dim StartTime = Date.Now.Ticks
Dim Result As String = NetGetCodeByClient("https://www.baidu.com/duty/", Encoding.UTF8, 20000, "")
Dim DuringTime As Integer = (Date.Now.Ticks - StartTime) / 10000
If Result.Contains("百度") Then
Log("[HiPer] 网络检测:连通检测成功(" & DuringTime & "ms)")
PingTime = DuringTime
Else
Log("[HiPer] 网络检测:连通检测失败(获取的内容有误)")
PingTime = -1
End If
Catch ex As ThreadInterruptedException
Catch ex As Exception
Log(ex, "连通检测失败")
PingTime = -1
End Try
End Sub
Private Shared Sub InitIpCheck()
IpCheckStatus = LoadState.Loading
Try
Log("[HiPer] 网络检测:IP 地址检测开始")
Dim IpCheckResult As String = NetRequestOnce("https://ipinfo.io/json", "GET", "", "application/json", 10000)
Dim Country As String = GetJson(IpCheckResult)("country")
IpIsInChina = Country = "CN"
IpCheckStatus = LoadState.Finished
Log("[HiPer] 网络检测:IP 地址检测结果:" & Country)
Catch ex As ThreadInterruptedException
IpCheckStatus = LoadState.Aborted
Catch ex As Exception
Log(ex, "IP 地址检测失败")
IpCheckStatus = LoadState.Failed
IpIsInChina = True
End Try
End Sub
Private Shared PingTime As Integer, IpCheckStatus As LoadState = LoadState.Loading, IpIsInChina As Boolean
Private Shared Sub InitCheck(Task As LoaderTask(Of Integer, Integer))
'检查协议
If Not Setup.Get("LinkEula") Then
Reopen:
Select Case MyMsgBox("PCL2 的联机服务由速聚授权提供。" & vbCrLf & "在使用前,你需要同意速聚的用户服务协议和隐私政策。", "协议授权", "同意", "拒绝", "查看用户服务协议和隐私政策")
Case 1
Setup.Set("LinkEula", True)
Case 2
Throw New Exception("$你拒绝了用户服务协议……")
Case 3
OpenWebsite("https://mp.weixin.qq.com/mp/appmsgalbum?__biz=MzkxMTMyODk3Mg==&action=getalbum&album_id=2585385685407514625&scene=173&from_msgid=2247483720&from_itemidx=1&count=3&nolastread=1#wechat_redirect")
GoTo Reopen
End Select
End If
'等待网络环境检查加载器结束
SetLoadDesc("正在检查网络环境……", "检查网络环境")
Do While Task.State = LoadState.Loading AndAlso Not (PingTime <> 0 AndAlso IpCheckStatus <> LoadState.Loading)
Thread.Sleep(50)
Loop
'获取网络环境检查结果
If IpCheckStatus = LoadState.Finished AndAlso Not IpIsInChina Then
If MyMsgBox("检测到你的 IP 不在中国,这会导致联机变得非常不稳定。" & vbCrLf &
"如果你正开着加速器或者 VPN,请先关闭它们,然后再继续……", "警告", "继续", "取消", IsWarn:=True, ForceWait:=True) = 2 Then
Throw New Exception("$请在关闭加速器或者 VPN 后点击重试。")
End If
Task.Progress = 0.5
InitIpCheck() '重新进行检查
End If
'没有联网
If IpCheckStatus = LoadState.Failed AndAlso PingTime = -1 Then
Throw New Exception("$PCL2 没法连上网……" & vbCrLf & "如果你改变了网络环境,请重启 PCL2。")
End If
End Sub
'获取所需文件
Private Shared Sub InitGetFile(Task As LoaderTask(Of Integer, List(Of NetFile)))
'初始化
SetLoadDesc("正在初始化……", "初始化")
Directory.CreateDirectory(PathHiper)
WriteFile(PathHiper & "HiPer 联机模块.vbs", "createobject(""wscript.shell"").run """"""" & PathHiper & "HiPer 联机模块.exe"""" v"", 0", Encoding:=Encoding.GetEncoding("GB18030")) '准备启动脚本
'获取索引码文件
SetLoadDesc("正在获取索引码文件……", "获取索引码文件")
Dim Cert As String = RunInUiWait(Function() FrmLinkHiper.TextCert.Text)
Log("[Hiper] 联机索引码:" & Cert)
If Cert = Setup.Get("LinkHiperCertLast") AndAlso File.Exists(PathHiper & "cert.yml") Then
Log("[Hiper] 索引码与上次输入的一致,跳过获取步骤")
Else
Dim CertRaw As String
Try
CertRaw = NetRequestOnce("https://cert.mcer.cn/" & Cert & ".yml", "GET", "", "")
Catch ex As Exception
If GetString(ex).Contains("(404)") Then
Throw New CertOutdatedException '索引码无效或已过期
ElseIf GetString(ex).Contains("too many requests") Then
Throw New Exception("你的尝试太频繁了,请暂时啥都别点,等两分钟后再试……")
Else
Throw
End If
End Try
If Not CertRaw.Contains("WARNING <<< AUTO SYNC AREA") Then Throw New Exception("获取到的索引码文件内容有误!")
WriteFile(PathHiper & "cert.yml", CertRaw)
Setup.Set("LinkHiperCertLast", Cert)
Setup.Set("LinkHiperCertTime", "")
End If
Task.Progress = 0.25
'获取 CPU 架构
SetLoadDesc("正在获取 CPU 架构……", "获取 CPU 架构")
Dim Architecture As String
Select Case GetType(String).Assembly.GetName().ProcessorArchitecture
Case Reflection.ProcessorArchitecture.X86
Architecture = "386"
Case Reflection.ProcessorArchitecture.Amd64
Architecture = "amd64"
Case Reflection.ProcessorArchitecture.Arm
Architecture = "arm64"
Case Else
Architecture = "arm64"
Log("[Hiper] 当前 CPU 架构为 " & GetStringFromEnum(GetType(String).Assembly.GetName().ProcessorArchitecture) & ",没有最适合的项,这可能会导致联机模块无法启动!", LogLevel.Debug)
End Select
Log("[Hiper] CPU 架构:" & Architecture)
'检查更新:hiper.exe
SetLoadDesc("正在检查联机模块本体更新……", "检查联机模块本体更新")
Dim RequiredFiles As New List(Of NetFile)
Dim Checksums As String = Nothing, ChecksumHiper As String = Nothing
If File.Exists(PathHiper & "HiPer 联机模块.exe") Then
Try
Checksums = NetGetCodeByDownload({
"http://mirror.hiper.cn.s2.the.bb/packages.sha1",
"http://mirror.hiper.cn.s3.the.bb:175/packages.sha1",
"https://gitcode.net/to/hiper/-/raw/master/packages.sha1",
"https://cert.mcer.cn/mirror/packages.sha1"
})
Catch ex As Exception
Log(ex, "获取联机模块更新信息失败,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishHiperFileCheck
End Try
ChecksumHiper = RegexSeek(Checksums, "[0-9a-f]{40}(?= windows-" & Architecture & "/hiper.exe)")
If ChecksumHiper Is Nothing Then
Log("[Hiper] 未找到联机模块更新信息,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishHiperFileCheck
End If
Log("[Hiper] hiper.exe 的所需 SHA1:" & ChecksumHiper)
If ChecksumHiper = GetAuthSHA1(PathHiper & "HiPer 联机模块.exe") Then
Log("[Hiper] hiper.exe 文件校验通过,无需重新下载")
GoTo FinishHiperFileCheck
End If
End If
Log("[Hiper] 需要重新下载 hiper.exe")
RequiredFiles.Add(New NetFile({"http://mirror.hiper.cn.s2.the.bb/windows-" & Architecture & "/hiper.exe",
"http://mirror.hiper.cn.s3.the.bb:175/windows-" & Architecture & "/hiper.exe",
"https://gitcode.net/to/hiper/-/raw/master/windows-" & Architecture & "/hiper.exe?inline=false",
"https://cert.mcer.cn/mirror/windows-" & Architecture & "/hiper.exe"},
PathHiper & "HiPer 联机模块.exe",
New FileChecker(Hash:=ChecksumHiper, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing,所以 Checksum 可以为 Nothing
FinishHiperFileCheck:
Task.Progress = 0.5
'检查更新:wintun.dll
Dim ChecksumWintun As String = Nothing
If File.Exists(PathHiper & "wintun.dll") Then
Try
If Checksums Is Nothing Then
Checksums = NetGetCodeByDownload({
"http://mirror.hiper.cn.s2.the.bb/packages.sha1",
"http://mirror.hiper.cn.s3.the.bb:175/packages.sha1",
"https://gitcode.net/to/hiper/-/raw/master/packages.sha1",
"https://cert.mcer.cn/mirror/packages.sha1"
})
End If
Catch ex As Exception
Log(ex, "获取联机模块更新信息失败,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishWintunFileCheck
End Try
ChecksumWintun = RegexSeek(Checksums, "[0-9a-f]{40}(?= windows-" & Architecture & "/wintun.dll)")
If ChecksumWintun Is Nothing Then
Log("[Hiper] 未找到联机模块更新信息,将会强制启动联机模块", LogLevel.Hint)
GoTo FinishWintunFileCheck
End If
Log("[Hiper] wintun.dll 的所需 SHA1:" & ChecksumWintun)
If ChecksumWintun = GetAuthSHA1(PathHiper & "wintun.dll") Then
Log("[Hiper] wintun.dll 文件校验通过,无需重新下载")
GoTo FinishWintunFileCheck
End If
End If
Log("[Hiper] 需要重新下载 wintun.dll")
RequiredFiles.Add(New NetFile({"http://mirror.hiper.cn.s2.the.bb/windows-" & Architecture & "/wintun.dll",
"http://mirror.hiper.cn.s3.the.bb:175/windows-" & Architecture & "/wintun.dll",
"https://gitcode.net/to/hiper/-/raw/master/windows-" & Architecture & "/wintun.dll?inline=false",
"https://cert.mcer.cn/mirror/windows-" & Architecture & "/wintun.dll"},
PathHiper & "wintun.dll",
New FileChecker(Hash:=ChecksumWintun, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing,所以 Checksum 可以为 Nothing
FinishWintunFileCheck:
Task.Progress = 0.75
'检查更新:MCB
If Not IsServerSide Then
SetLoadDesc("正在检查联机模块组件更新……", "检查联机模块组件更新")
Dim ChecksumMcb As String = Nothing
If File.Exists(PathHiper & "MCB 联机模块.exe") Then
Try
Checksums = NetGetCodeByDownload({
"http://mirror.hiper.cn.s2.the.bb/utils/minecraft-broadcast/packages.sha1",
"http://mirror.hiper.cn.s3.the.bb:175/utils/minecraft-broadcast/packages.sha1",
"https://gitcode.net/to/hiper/-/raw/master/utils/minecraft-broadcast/packages.sha1",
"https://cert.mcer.cn/mirror/utils/minecraft-broadcast/packages.sha1"
})
Catch ex As Exception
Log(ex, "获取联机模块组件更新信息失败,将会强制启动联机模块组件", LogLevel.Hint)
GoTo FinishMcbFileCheck
End Try
ChecksumMcb = RegexSeek(Checksums, "[0-9a-f]{40}(?= mcb-windows-" & Architecture & ".exe)")
If ChecksumMcb Is Nothing Then
Log("[Hiper] 未找到联机模块组件更新信息,将会强制启动联机模块组件", LogLevel.Hint)
GoTo FinishMcbFileCheck
End If
Log("[Hiper] mcb.exe 的所需 SHA1:" & ChecksumMcb)
If ChecksumMcb = GetAuthSHA1(PathHiper & "MCB 联机模块.exe") Then
Log("[Hiper] mcb.exe 文件校验通过,无需重新下载")
GoTo FinishMcbFileCheck
End If
End If
Log("[Hiper] 需要重新下载 mcb.exe")
RequiredFiles.Add(New NetFile({
"http://mirror.hiper.cn.s2.the.bb/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe",
"http://mirror.hiper.cn.s3.the.bb:175/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe",
"https://gitcode.net/to/hiper/-/raw/master/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe?inline=false",
"https://cert.mcer.cn/mirror/utils/minecraft-broadcast/mcb-windows-" & Architecture & ".exe"},
PathHiper & "MCB 联机模块.exe",
New FileChecker(Hash:=ChecksumMcb, MinSize:=1024 * 200))) 'Hash 的默认值即为 Nothing,所以 Checksum 可以为 Nothing
FinishMcbFileCheck:
End If
'添加 point.yml
RequiredFiles.Add(New NetFile({"https://cert.mcer.cn/point.yml"}, PathHiper & "point.yml", New FileChecker(MinSize:=200)))
'开始下载
SetLoadDesc("正在下载联机模块……", "下载联机模块")
Task.Output = RequiredFiles
End Sub
Public Class CertOutdatedException
Inherits Exception
End Class
'启动联机模块
Private Shared Sub InitLaunch(Task As LoaderTask(Of Integer, Integer))
'关闭运行中的 HiPer,然后再刷新凭证文件
SetLoadDesc("正在关闭运行中的联机模块……", "关闭运行中的联机模块")
HiperStop(True)
'准备凭证文件
SetLoadDesc("正在准备索引码文件……", "准备索引码文件")
Dim CertFile As String = ReadFile(PathHiper & "cert.yml")
'添加防火墙配置
If IsServerSide Then
CertFile += ("\n\ninbound:\n port: " & HostPort & "\n proto: tcp\n host: any").Replace("\n", vbCrLf)
Else
CertFile += ("\n\noutbound:\n port: " & HostPort & "\n proto: tcp\n host: " & HostIp).Replace("\n", vbCrLf)
End If
CertFile += "\nlogging:\n format: json".Replace("\n", vbCrLf)
'更新 point.yml 段
Const SyncAreaRegex As String = "(?<=#[ ]*WARNING >>> AUTO SYNC AREA)[\s\S]+?(?=#[ ]*WARNING <<< AUTO SYNC AREA)"
CertFile = CertFile.Replace(RegexSeek(CertFile, SyncAreaRegex), RegexSeek(ReadFile(PathHiper & "point.yml"), SyncAreaRegex))
WriteFile(PathHiper & "config.yml", CertFile)
AllNodes = RegexSearch(CertFile.Replace(vbLf, "cr"), "(?<="")[0-9]+.[0-9]+.[0-9]+.[0-9]+(?=""( )?:( )?cr - "")").Distinct.
Where(Function(l) Not (l = "6.6.1.1" OrElse l = "6.6.2.2" OrElse l = "6.6.3.3")).ToList
If AllNodes.Count < 2 Then Throw New Exception("$索引码文件格式有误,未找到节点 IP!")
Task.Progress = 0.05
'尝试启动
HiperStart(Task) '启动失败会直接抛出异常
Task.Progress = 0.2
'检查连接情况
SetLoadDesc("正在连接到联机节点 (1/2)……" & If(IpIsInChina, "", vbCrLf & "由于网络不在中国,可能要花费很长时间。"), "检查联机节点")
If Not IsServerSide AndAlso HostIp = HiperIp Then Throw New Exception("$还搁这自己连自己?!不是吧?!")
Dim PingNodeResults As New List(Of Integer)
Dim UnpingedNodes As New List(Of String)(AllNodes)
Do Until PingNodeResults.Count >= 2 OrElse Task.IsAborted
Dim SelectedNode = RandomOne(UnpingedNodes)
Dim PingNode = Ping(SelectedNode, 4000)
If PingNode = -1 Then
Task.Progress += (If(PingNodeResults.Count = 0, 0.58, 0.88) - Task.Progress) * 0.3
Else
SetLoadDesc("正在连接到联机节点 (2/2)……" & If(IpIsInChina, "", vbCrLf & "由于网络不在中国,可能要花费很长时间。"), "检查联机节点")
Task.Progress = 0.6
PingNodeResults.Add(PingNode)
UnpingedNodes.Remove(SelectedNode)
End If
Loop
PingNodes = PingNodeResults.Min
Task.Progress = 0.9
'与房主 Ping 一下看看
If Not IsServerSide Then
SetLoadDesc("正在连接到房主……", "检查房主")
HostPing = -1 '实际上不使用本次 Ping 的结果,因为它真的偏大……
Do
Dim PingHost = Ping(HostIp, 4000, False)
If PingHost = -1 Then
Thread.Sleep(500)
Else
Exit Do
End If
Loop Until Task.IsAborted
'在等待 2 秒后再次触发 Ping,以刷新显示的 Ping
RunInNewThread(Sub()
Thread.Sleep(2000)
TaskPingHost.Start(True, IsForceRestart:=True)
End Sub, "HiPer Delayed Ping")
End If
'刷新完成页面
SetLoadDesc("正在加载完成页面……", "加载完成页面")
RunInUiWait(AddressOf FrmLinkHiper.WatcherTimer1)
End Sub
Private Shared PingNodes As Integer, AllNodes As List(Of String)
#End Region
#Region "进程管理"
Private Shared _HiperState As LoadState = LoadState.Waiting
Public Shared Property HiperState As LoadState
Get
Return _HiperState
End Get
Set(value As LoadState)
_HiperState = value
RunInUi(Sub() If FrmLinkLeft IsNot Nothing Then CType(FrmLinkLeft.ItemHiper.Buttons(0), MyIconButton).Visibility = If(HiperState = LoadState.Finished OrElse HiperState = LoadState.Loading, Visibility.Visible, Visibility.Collapsed))
End Set
End Property
Public Shared Sub ModuleStopManually() '关闭联机模块按钮
HiperExit(False)
End Sub
Private Shared HiperIp As String = Nothing
Private Shared HiperProcessId As Integer = -1, McbProcessId As Integer = -1
Private Shared HiperCertTime As Date = Date.Now
''' <summary>
''' 若程序正在运行,则结束程序进程,同时初始化状态数据。返回是否关闭了相关进程。
''' </summary>
Public Shared Function HiperStop(SleepWhenKilled As Boolean) As Boolean
HiperStop = False
'修改凭证
Dim ConfigContent As String = ReadFile(PathHiper & "config.yml")
If Not ConfigContent.Contains("enable: false") Then
WriteFile(PathHiper & "config.yml", ConfigContent & vbCrLf & "enable: false")
End If
'关闭所有进程
For Each ProcessObject In Process.GetProcesses
Dim IsHiper As Boolean = ProcessObject.ProcessName = "HiPer 联机模块"
Dim IsMcb As Boolean = ProcessObject.ProcessName = "MCB 联机模块"
If Not IsHiper AndAlso Not IsMcb Then Continue For
HiperStop = True
Try
If IsMcb Then
ProcessObject.Kill()
Log("[HiPer] 已结束进程 PID " & ProcessObject.Id & ":" & ProcessObject.ProcessName)
If HiperStop AndAlso SleepWhenKilled Then Thread.Sleep(1000) '等待 1 秒确认进程已退出
Else 'IsHiper
If SleepWhenKilled Then
Thread.Sleep(4000) '等待 4 秒确认进程已退出
If Not ProcessObject.HasExited Then
ProcessObject.Kill()
Log("[HiPer] 已结束进程 PID " & ProcessObject.Id & ":" & ProcessObject.ProcessName)
End If
End If
End If
Catch ex As Exception
Log(ex, "结束进程失败(" & ProcessObject.Id & "," & ProcessObject.ProcessName & ")")
End Try
Next
'初始化
HiperState = LoadState.Waiting
HiperProcessId = -1 : McbProcessId = -1
HiperCertTime = Nothing
End Function
''' <summary>
''' 启动程序,并等待初始化完成后退出运行,同时更新 HiperIp。
''' 若启动失败,则会直接抛出异常。
''' 若程序正在运行,则会先停止其运行。
''' </summary>
Public Shared Sub HiperStart(Task As LoaderTask(Of Integer, Integer))
Try
SetLoadDesc("正在启动联机模块……", "启动联机模块")
PossibleFailReason = Nothing
'启动 Hiper
Log("[Hiper] 启动 Hiper 进程")
DeleteDirectory(PathHiper & "logs") '清理日志
Dim HiperInfo = New ProcessStartInfo With {
.FileName = "wscript",
.Arguments = """" & PathHiper & "HiPer 联机模块.vbs""",
.Verb = "runas" '需要管理员权限
}
Dim HiperVbsProcess As New Process() With {.StartInfo = HiperInfo}
HiperVbsProcess.Start()
'查找真正的 Hiper 进程
SetLoadDesc("联机模块正在启动……", "联机模块加载")
Do
Dim GotProcesses = Process.GetProcesses.
Where(Function(l) l.ProcessName = "HiPer 联机模块" AndAlso Math.Abs((l.StartTime - Date.Now).TotalMinutes) < 1)
If GotProcesses.Count > 0 Then
HiperProcessId = GotProcesses.First.Id
Log("[Hiper] 已发现 Hiper 进程,PID:" & HiperProcessId)
Exit Do
End If
Thread.Sleep(50)
Loop While Task.State = LoadState.Loading AndAlso Not Task.IsAborted
If HiperProcessId = -1 Then Throw New Exception("联机模块未能成功启动!")
HiperState = LoadState.Loading
Task.Progress = 0.15
'抓取日志
Dim LogLine As Integer = 0
Do
Thread.Sleep(100)
If Not File.Exists(PathHiper & "logs\hiper.log") Then Continue Do
Dim LogLines As String() = ReadFile(PathHiper & "logs\hiper.log").TrimEnd(vbLf).Split(vbLf)
For i = LogLine To LogLines.Count - 1
HiperLogLine(LogLines(i), Task)
Next
LogLine = LogLines.Count
Loop While HiperState = LoadState.Loading AndAlso Not Task.IsAborted AndAlso Process.GetProcesses.Any(Function(l) l.Id = HiperProcessId)
'输出
If HiperState = LoadState.Finished Then
Log("[Hiper] Hiper 启动完成")
ElseIf PossibleFailReason IsNot Nothing AndAlso PossibleFailReason.Contains("索引码已过期") Then
Throw New CertOutdatedException()
Else
Throw New Exception(If(PossibleFailReason, "联机模块因未知原因启动失败!"))
End If
'启动 MCB
Task.Progress = 0.25
If Not IsServerSide Then
Try
Log("[Hiper] 启动 MCB 进程")
Dim McbInfo = New ProcessStartInfo With {
.FileName = PathHiper & "MCB 联机模块.exe", .WorkingDirectory = PathHiper,
.UseShellExecute = False, .CreateNoWindow = True,
.RedirectStandardError = True, .RedirectStandardOutput = True,
.Arguments = "-addr " & HostIp & ":" & HostPort & " -motd ""PCL2 联机房间"""
}
Dim McbProcess As New Process() With {.StartInfo = McbInfo}
McbProcess.Start()
McbProcessId = McbProcess.Id
Catch ex As Exception
Throw New Exception("联机模块组件启动失败", ex)
End Try
End If
Catch ex As Exception
Try
HiperStop(True) '由于启动失败停止进程
Catch
End Try
HiperState = LoadState.Failed
Throw
End Try
End Sub
'Hiper 日志
Private Shared Sub HiperLogLine(Content As String, Task As LoaderTask(Of Integer, Integer))
'检查报错
Dim ContentTest As String = Content.ToLower
Dim ErrorMessage As String = Nothing
Dim ContentJson As JObject = Nothing
If Content.StartsWith("{""") AndAlso Content.EndsWith("}") Then
ContentJson = GetJson(Content)
ContentTest = If(ContentJson("error"), ContentJson("msg")).ToString.ToLower
ErrorMessage = ContentJson("error")
End If
If ContentTest.Contains("hiper certificate for this host is expired") Then
PossibleFailReason = "$你的索引码已过期,请更换新的索引码!"
ElseIf ContentTest.Contains("error creating interface: access is denied") Then
PossibleFailReason = "$没有获得管理员权限,无法创建网络通道!"
ElseIf ContentTest.Contains("cannot create a file when that file already exists") Then
PossibleFailReason = "$请不要重复开启多个联机模块!"
ElseIf Content.Contains("failed to load config") Then
PossibleFailReason = "$索引码文件内容存在错误!"
ElseIf Content.Contains("system cannot find the file specified") Then
PossibleFailReason = "$创建网络通道失败!" & vbCrLf & "如果你曾启动过 VPN 软件,请先打开那个软件,然后关掉它,最后再重试。虽然不知道为啥,但这样大概管用……"
End If
If PossibleFailReason Is Nothing AndAlso ErrorMessage IsNot Nothing Then PossibleFailReason = ErrorMessage
'检查结束
If ContentJson IsNot Nothing Then
Dim Message As String = ContentJson("msg")
If Message = "HiPer interface is active" Then
HiperIp = ContentJson("network").ToString.Split("/").First
If IsServerSide Then HostIp = HiperIp
Log("[Hiper] Hiper 启动完成,IP:" & HiperIp)
HiperState = LoadState.Finished
ElseIf Message = "Validity of client certificate" Then
Dim VaildTime As String = ContentJson("valid")
Date.TryParseExact(VaildTime, "yyyy-MM-dd HH:mm:ss", Globalization.CultureInfo.InvariantCulture, Globalization.DateTimeStyles.None, HiperCertTime)
Log("[Hiper] 索引码到期时间:" & HiperCertTime.ToString)
Setup.Set("LinkHiperCertTime", HiperCertTime.ToString)
End If
End If
'写入日志
If ModeDebug OrElse Content.Contains("""error""") Then Log("[Hiper] " & Content)
End Sub
Private Shared PossibleFailReason As String = Nothing
#End Region
#Region "监视线程"
'主 Timer 线程
Private IsWatcherStarted As Boolean = False
Private Sub WatcherThread()
Dim Sec15 As Integer = 0
Do While True
Try
For i = 1 To 5
Thread.Sleep(200)
If InitLoader.State = LoadState.Loading Then
RunInUi(AddressOf UpdateProgress)
End If
Next
Thread.Sleep(1000)
Sec15 += 1
WatcherTimer1()
If Sec15 = 15 Then
Sec15 = 0
WatcherTimer15()
End If
Catch ex As Exception
Log(ex, "联机模块主时钟出错", LogLevel.Feedback)
Thread.Sleep(20000)
End Try
Loop
End Sub
'每 1 秒执行的 Timer
Private Sub WatcherTimer1()
If HiperState <> LoadState.Finished Then Exit Sub
RunInUi(Sub()
'索引码剩余时间
Dim Span As TimeSpan = HiperCertTime - Date.Now
If Span.TotalDays >= 30 Then
LabFinishTime.Text = "> 30 天"
ElseIf Span.TotalDays >= 4 Then
LabFinishTime.Text = Span.Days & " 天"
ElseIf Span.TotalDays >= 1 Then
LabFinishTime.Text = Span.Days & " 天" & If(Span.Hours > 0, " " & Span.Hours & " 小时", "")
ElseIf Span.TotalMinutes >= 10 Then
LabFinishTime.Text = Span.Hours & ":" & Span.Minutes.ToString.PadLeft(2, "0") & "'"
Else
LabFinishTime.Text = Span.Minutes & "'" & Span.Seconds.ToString.PadLeft(2, "0") & """"
End If
'提示索引码即将到期
If Span.TotalSeconds <= 5 * 60 AndAlso Span.TotalSeconds > 5 * 60 - 1 AndAlso Setup.Get("LinkHiperCertWarn") Then
MyMsgBox("你的索引码还有不到 5 分钟就要过期了!" & vbCrLf & "你可以在设置中关闭这个提示……", "索引码即将过期", "我知道了……")
ShowWindowToTop(Handle)
Beep()
End If
'检查索引码到期
If Span.TotalSeconds < 2 Then
LabCertTitle.Text = "索引码已过期"
LabCertDesc.Text = "你的 HiPer 索引码已经过期,请输入新的索引码。" & vbCrLf & "如果实在没有索引码,可以在左侧选择 IOI 方式联机。"
TextCert.Text = ""
HiperExit(True)
ShowWindowToTop(Handle)
Beep()
Exit Sub
End If
'网络质量
Dim QualityScore As Integer = If(IpIsInChina, 0, -2)
QualityScore -= Math.Ceiling((Math.Min(PingTime, 600) + Math.Min(PingNodes, 600)) / 80)
Select Case QualityScore
Case Is >= -1
LabFinishQuality.Text = "优秀"
Case Is >= -2
LabFinishQuality.Text = "优良"
Case Is >= -3
LabFinishQuality.Text = "良好"
Case Is >= -5
LabFinishQuality.Text = "一般"
Case Is >= -7
LabFinishQuality.Text = "较差"
Case Else
LabFinishQuality.Text = "很差"
End Select
'Ping
If HostPing <> -1 Then
If FrmLinkHiper IsNot Nothing AndAlso FrmLinkHiper.LabFinishPing.IsLoaded Then
FrmLinkHiper.LabFinishPing.Text = HostPing & "ms"
End If
End If
End Sub)
End Sub
'每 15 秒执行的 Timer
Private Shared HostPing As Integer = -1
Private Sub WatcherTimer15()
If Not (HiperState = LoadState.Finished OrElse HiperState = LoadState.Loading) Then Exit Sub
'检查 HiPer 崩溃
Try
Process.GetProcessById(HiperProcessId)
Catch
Dim LogLines = ReadFile(PathHiper & "logs\hiper.log").TrimEnd(vbLf).Split(vbLf)
HiperExit(False)
MyMsgBox("由于联机模块异常退出,已退出联机房间。" & vbCrLf & vbCrLf &
"联机模块最后的日志:" & vbCrLf & Join(LogLines.Skip(LogLines.Count - 3).ToList, vbCrLf), "联机断开")
End Try
'下面的部分需要完全完成加载
If HiperState <> LoadState.Finished Then Exit Sub
'检查 MCB 崩溃
Try
If Not IsServerSide Then Process.GetProcessById(McbProcessId)
Catch
HiperExit(False)
MyMsgBox("由于 MCB 联机模块异常退出,已退出联机房间。", "联机断开")
End Try
'重新检查 Ping
If Not IsServerSide Then
Dim PingHostFailedCount As Integer = 0
Do
TaskPingHost.WaitForExit(True, IsForceRestart:=True)
If TaskPingHost.Output = -1 Then
PingHostFailedCount += 1
Log("[HiPer] Ping 房主失败(第 " & PingHostFailedCount & " 次)")
If PingHostFailedCount >= 3 Then
HiperExit(False) : MyMsgBox("与房主断开连接,已退出联机房间。", "联机断开") : Exit Sub
End If
Else
If PingHostFailedCount > 0 Then Log("[HiPer] Ping 房主已恢复成功(" & HostPing & "ms)")
Exit Do
End If
Loop While True
End If
End Sub
#End Region
#Region "PanCert | 索引码输入页面"
'检测输入
Private Sub TextCert_ValidateChanged(sender As Object, e As EventArgs) Handles TextCert.ValidateChanged
BtnCertDone.IsEnabled = TextCert.ValidateResult = ""
End Sub
Private Sub TextCert_KeyUp(sender As Object, e As KeyEventArgs) Handles TextCert.KeyUp
If e.Key = Key.Enter AndAlso BtnCertDone.IsEnabled Then BtnCertDone_Click() '允许回车确认
End Sub
'确认
Private Sub BtnCertDone_Click() Handles BtnCertDone.Click
CurrentSubpage = Subpages.PanSelect
End Sub
#End Region
#Region "PanSelect | 种类选择页面"
'返回
Private Sub BtnSelectReturn_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectReturn.MouseLeftButtonUp
LabCertTitle.Text = "输入索引码"
LabCertDesc.Text = "你需要获取索引码才能使用 HiPer。" & vbCrLf & "如果实在没有索引码,可以在左侧选择 IOI 方式联机。"
CurrentSubpage = Subpages.PanCert
End Sub
'创建房间
Private Sub BtnSelectCreate_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectCreate.MouseLeftButtonUp
'获取端口号
Dim PortInput As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {
New ValidateInteger(2, 65535),
New ValidateExceptSame({"55555", "55557"}, "端口不能为 %!")
}, "在 MC 的暂停画面选择【对局域网开放】", "输入端口号", "确定", "取消")
If PortInput Is Nothing Then Exit Sub
'开始
RoomCreate(Val(PortInput))
End Sub
Private Sub RoomCreate(Port As Integer)
'记录信息
HostIp = Nothing : HostPort = Port
IsServerSide = True
'启动
InitLoader.Start(IsForceRestart:=True)
End Sub
'加入房间
Private Sub BtnSelectJoin_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnSelectJoin.MouseLeftButtonUp
'获取信息
Dim Code As String = MyMsgBoxInput("", New ObjectModel.Collection(Of Validate) From {New ValidateLength(8, 99)}, "",
"输入联机码", "确定", "取消")
If Code Is Nothing Then Exit Sub
'记录信息
If Not Code.EndsWith(RequestVersion) OrElse Not Code.StartsWith("P") Then GoTo WrongCode
Dim Ip As String, Port As Integer
Try
Dim IpAndPort As Long = RadixConvert(Code.Substring(1, Code.Length - 2).ToUpper, 36, 10)
'IpAndPort = HostPort + IpParts(0) * 65536 + IpParts(1) * 65536 * 256 + IpParts(2) * 65536 * 256 * 256 + IpParts(3) * 65536 * 256 * 256 * 256
Ip = Math.Floor(IpAndPort / (65536L * 256 * 256 * 256))
IpAndPort = IpAndPort Mod (65536L * 256 * 256 * 256)
Ip = Math.Floor(IpAndPort / (65536L * 256 * 256)) & "." & Ip
IpAndPort = IpAndPort Mod (65536L * 256 * 256)
Ip = Math.Floor(IpAndPort / (65536L * 256)) & "." & Ip
IpAndPort = IpAndPort Mod (65536L * 256)
Ip = Math.Floor(IpAndPort / (65536L)) & "." & Ip
Port = IpAndPort Mod 65536
Catch
GoTo WrongCode
End Try
'启动
RoomJoin(Ip, Port)
Exit Sub
WrongCode:
If Not Code.StartsWith("P") AndAlso Code.Length >= 49 Then Hint("你输入的可能是 IOI 的联机码,请在左侧的联机方式中选择 IOI!", HintType.Critical) : Exit Sub
If Code.StartsWith("P") AndAlso Not Code.EndsWith(RequestVersion) Then Hint("你的 PCL2 版本与房主的 PCL2 版本不一致!", HintType.Critical) : Exit Sub
Hint("你输入的联机码无效!", HintType.Critical)
End Sub
Private Sub RoomJoin(Ip As String, Port As Integer)
'记录信息
HostIp = Ip : HostPort = Port
IsServerSide = False
'启动
InitLoader.Start(IsForceRestart:=True)
End Sub
#End Region
#Region "PanLoad | 加载中页面"
'承接状态切换的 UI 改变
Private Sub OnLoadStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState)
Select Case NewState
Case LoadState.Loading
UpdateProgress(0)
If IsServerSide Then
LabLoadTitle.Text = "正在创建联机房间"
Log("[Hiper] 正在创建联机房间,端口 " & HostPort)
Else
LabLoadTitle.Text = "正在加入联机房间"
Log("[Hiper] 正在加入联机房间,目标 IP " & HostIp & ":" & HostPort)
End If
LabLoadDesc.Text = "正在初始化……"
LoadStep = "准备初始化"
Case LoadState.Failed
UpdateProgress(1)
If IsServerSide Then
LabLoadTitle.Text = "创建联机房间失败"
Else
LabLoadTitle.Text = "加入联机房间失败"
End If
Dim RealException As Exception = If(Loader.Error.InnerException, Loader.Error)
If TypeOf RealException Is CertOutdatedException Then
LabCertTitle.Text = "索引码无效"
LabCertDesc.Text = "你的 HiPer 索引码无效或者已经过期!" & vbCrLf & "请重新输入索引码。"
HiperExit(True)
ElseIf RealException.Message.StartsWith("$") Then
LabLoadDesc.Text = RealException.Message.TrimStart("$") & vbCrLf &
"点击镐子重试,或者点击灰色的 × 取消。"
Else
LabLoadDesc.Text = LoadStep & "失败:" & GetString(RealException) & vbCrLf &
"点击镐子重试,或者点击灰色的 × 取消。"
End If
Log(Loader.Error, "HiPer 联机尝试失败")
Case LoadState.Finished
UpdateProgress(1)
CurrentSubpage = Subpages.PanFinish
BtnFinishPing.Visibility = If(IsServerSide, Visibility.Collapsed, Visibility.Visible)
LineFinishPing.Visibility = If(IsServerSide, Visibility.Collapsed, Visibility.Visible)
BtnFinishCopy.Visibility = If(IsServerSide, Visibility.Visible, Visibility.Collapsed)
If IsServerSide Then
LabFinishTitle.Text = "已创建联机房间"
LabFinishDesc.Text = "已在端口 " & HostPort & " 创建了联机房间。" & vbCrLf & "点击下方的复制联机码按钮,然后把联机码发给朋友吧!"
Else
LabFinishTitle.Text = "已加入联机房间"
LabFinishDesc.Text = "启动游戏,进入多人游戏页面后稍等片刻,房间就会出现在服务器列表的最下方。" & vbCrLf & "如果提示无效会话,不要退出联机房间,重新启动游戏即可!"
End If
LabFinishIp.Text = HostIp & ":" & HostPort
Log("[Hiper] 已完成连接")
End Select
End Sub
Private Shared LoadStep As String = "准备初始化"
Private Shared Sub SetLoadDesc(Intro As String, [Step] As String)
Log("[Hiper] 连接步骤:" & Intro)
LoadStep = [Step]
RunInUiWait(Sub()
If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.LabLoadDesc.IsLoaded Then Exit Sub
FrmLinkHiper.LabLoadDesc.Text = Intro
FrmLinkHiper.UpdateProgress()
End Sub)
End Sub
'承接重试
Private Sub CardLoad_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles CardLoad.MouseLeftButtonUp
If Not InitLoader.State = LoadState.Failed Then Exit Sub
InitLoader.Start(IsForceRestart:=True)
End Sub
'取消加载
Private Sub CancelLoad() Handles BtnLoadCancel.Click
If InitLoader.State = LoadState.Loading Then
CurrentSubpage = Subpages.PanSelect
InitLoader.Abort()
Else
InitLoader.State = LoadState.Waiting
End If
HiperStop(False)
End Sub
'进度改变
Private Sub UpdateProgress(Optional Value As Double = -1)
If Value = -1 Then Value = InitLoader.Progress
Dim DisplayingProgress As Double = ColumnProgressA.Width.Value
If Math.Round(Value - DisplayingProgress, 3) = 0 Then Exit Sub
If DisplayingProgress > Value Then
ColumnProgressA.Width = New GridLength(Value, GridUnitType.Star)
ColumnProgressB.Width = New GridLength(1 - Value, GridUnitType.Star)
AniStop("Hiper Progress")
Else
Dim NewProgress As Double = If(Value = 1, 1, (Value - DisplayingProgress) * 0.2 + DisplayingProgress)
AniStart({
AaGridLengthWidth(ColumnProgressA, NewProgress - ColumnProgressA.Width.Value, 300, Ease:=New AniEaseOutFluent),
AaGridLengthWidth(ColumnProgressB, (1 - NewProgress) - ColumnProgressB.Width.Value, 300, Ease:=New AniEaseOutFluent)
}, "Hiper Progress")
End If
End Sub
Private Sub CardResized() Handles CardLoad.SizeChanged
RectProgressClip.Rect = New Rect(0, 0, CardLoad.ActualWidth, 12)
End Sub
#End Region
#Region "PanFinish | 加载完成页面"
'复制 IP
Private Sub BtnFinishIp_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishIp.MouseLeftButtonUp
ClipboardSet(LabFinishIp.Text)
End Sub
'退出
Private Sub BtnFinishExit_Click(sender As Object, e As EventArgs) Handles BtnFinishExit.Click
If IsServerSide AndAlso MyMsgBox("你确定要关闭联机房间吗?", "确认退出", "确定", "取消", IsWarn:=True) = 2 Then Exit Sub
HiperExit(False)
End Sub
'复制联机码
Private Sub BtnFinishCopy_Click(sender As Object, e As EventArgs) Handles BtnFinishCopy.Click
Dim IpParts = HostIp.Split(".").Select(Function(l) Val(l)).ToList
Dim IpAndPort As Long = HostPort + IpParts(0) * 65536 + IpParts(1) * 65536 * 256 + IpParts(2) * 65536 * 256 * 256 + IpParts(3) * 65536 * 256 * 256 * 256
ClipboardSet("P" & RadixConvert(IpAndPort, 10, 36) & RequestVersion, False)
Hint("已复制联机码!", HintType.Finish)
End Sub
'Ping 房主
Private Sub BtnFinishPing_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishPing.MouseLeftButtonUp
LabFinishPing.Text = "检测中"
If TaskPingHost.State = LoadState.Loading Then Exit Sub
TaskPingHost.Start(True, IsForceRestart:=True)
End Sub
Private Shared TaskPingHost As New LoaderTask(Of Boolean, Integer)("HiPer Ping Host",
Sub(Task As LoaderTask(Of Boolean, Integer))
HostPing = -1
HostPing = Ping(HostIp, 5000, Task.Input)
End Sub)
#End Region
#Region "子页面管理"
Public Enum Subpages
PanCert
PanSelect
PanFinish
End Enum
Private _CurrentSubpage As Subpages = Subpages.PanCert
Public Property CurrentSubpage As Subpages
Get
Return _CurrentSubpage
End Get
Set(value As Subpages)
If _CurrentSubpage = value Then Exit Property
_CurrentSubpage = value
Log("[Hiper] 子页面更改为 " & GetStringFromEnum(value))
PageOnContentExit()
If value = Subpages.PanSelect Then
LabSelectCode.Text = "(" & TextCert.Text.Substring(0, Math.Min(TextCert.Text.Length, 3)) & "…)"
End If
End Set
End Property
Private Sub PageLinkHiper_OnPageEnter() Handles Me.PageEnter
FrmLinkHiper.PanCert.Visibility = If(CurrentSubpage = Subpages.PanCert, Visibility.Visible, Visibility.Collapsed)
FrmLinkHiper.PanSelect.Visibility = If(CurrentSubpage = Subpages.PanSelect, Visibility.Visible, Visibility.Collapsed)
FrmLinkHiper.PanFinish.Visibility = If(CurrentSubpage = Subpages.PanFinish, Visibility.Visible, Visibility.Collapsed)
End Sub
Private Shared Sub HiperExit(ExitToCertPage As Boolean)
Log("[Hiper] 要求退出 Hiper(当前加载器状态为 " & GetStringFromEnum(InitLoader.State) & ")")
HiperStop(False)
If InitLoader.State = LoadState.Loading Then InitLoader.Abort()
If InitLoader.State = LoadState.Failed Then InitLoader.State = LoadState.Waiting
RunInUi(Sub()
If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.IsLoaded Then Exit Sub
FrmLinkHiper.CurrentSubpage = If(ExitToCertPage, Subpages.PanCert, Subpages.PanSelect)
FrmLinkHiper.PageOnContentExit()
End Sub)
End Sub
#End Region
End Class
File diff suppressed because it is too large. Load diff
@@ -18,7 +18,6 @@
<local:MyListItem x:Name="ItemFeedback" IsScaleAnimationEnabled="False" Type="Clickable" Tag="3" PaddingRight="35" Height="36" VerticalAlignment="Top" Title="反馈"
LogoScale="0.9" Logo="M613.717333 64.426667l3.413334 3.242666 331.861333 331.861334a85.333333 85.333333 0 0 1 3.2 117.269333l-3.2 3.413333L573.162667 896H960a21.333333 21.333333 0 0 1 21.333333 21.333333v42.666667a21.333333 21.333333 0 0 1-21.333333 21.333333H64a21.333333 21.333333 0 0 1-21.333333-21.333333v-42.666667a21.333333 21.333333 0 0 1 21.333333-21.333333h295.338667L74.069333 610.709333a85.333333 85.333333 0 0 1-3.221333-117.269333l3.2-3.413333 422.4-422.357334a85.333333 85.333333 0 0 1 117.269333-3.221333z m-20.629333 99.882666l-21.418667 321.493334a85.333333 85.333333 0 0 1-74.944 79.04l-4.522666 0.426666-321.493334 21.44 295.552 295.530667 422.4-422.378667L593.066667 164.309333z m-86.442667 13.824L184.533333 500.266667l301.994667-20.117334 20.117333-301.994666z" />
<local:MyListItem x:Name="ItemVote" IsScaleAnimationEnabled="False" Type="Clickable" Tag="4" PaddingRight="35" Height="36" VerticalAlignment="Top" Title="新功能投票"
EventType="打开网页" EventData="https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8"
LogoScale="0.92" Logo="M979 1024H45c-24.9 0-45-20.1-45-45s20.1-45 45-45h934c24.9 0 45 20.1 45 45s-20.1 45-45 45zM135 887C60.6 887 0 826.4 0 752V334c0-74.4 60.6-135 135-135s135 60.6 135 135v418c0 74.4-60.6 135-135 135z m0-598c-24.8 0-45 20.2-45 45v418c0 24.8 20.2 45 45 45s45-20.2 45-45V334c0-24.8-20.2-45-45-45zM512 887c-74.4 0-135-60.6-135-135V532c0-74.4 60.6-135 135-135s135 60.6 135 135v220c0 74.4-60.6 135-135 135z m0-400c-24.8 0-45 20.2-45 45v220c0 24.8 20.2 45 45 45s45-20.2 45-45V532c0-24.8-20.2-45-45-45zM889 887c-74.4 0-135-60.6-135-135V135C754 60.6 814.6 0 889 0s135 60.6 135 135v617c0 74.4-60.6 135-135 135z m0-797c-24.8 0-45 20.2-45 45v617c0 24.8 20.2 45 45 45s45-20.2 45-45V135c0-24.8-20.2-45-45-45z" />
</StackPanel>
</local:MyPageLeft>
@@ -122,9 +122,17 @@
FrmOtherHelp.SearchBox.Text = ""
End Sub
'打开反馈
'打开网页
Public Shared Sub TryFeedback() Handles ItemFeedback.Click
If CanFeedback(True) Then Feedback(True, False)
If Not CanFeedback(True) Then Exit Sub
If MyMsgBox("是否要打开反馈列表网页?" & vbCrLf & "如果无法打开该网页,请尝试使用加速器或 VPN。",
"提醒", "打开", "取消") = 2 Then Exit Sub
Feedback(True, False)
End Sub
Public Shared Sub TryVote() Handles ItemVote.Click
If MyMsgBox("是否要打开新功能投票网页?" & vbCrLf & "如果无法打开该网页,请尝试使用加速器或 VPN。",
"提醒", "打开", "取消") = 2 Then Exit Sub
OpenWebsite("https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8?discussions_q=category%3A%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8+sort%3Adate_created")
End Sub
End Class
@@ -211,24 +211,28 @@
</StackPanel>
</local:MyCard>
<local:MyCard Margin="0,0,0,15" Title="高级设置" IsSwaped="True" CanSwap="True">
<StackPanel Margin="25,40,25,15">
<Grid>
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" SharedSizeGroup="Name" />
<ColumnDefinition Width="1*" />
</Grid.ColumnDefinitions>
<Grid.RowDefinitions>
<RowDefinition Height="28" />
<RowDefinition Height="9" />
<RowDefinition Height="28" />
</Grid.RowDefinitions>
<TextBlock Grid.Row="0" VerticalAlignment="Center" HorizontalAlignment="Left" Text="JVM 参数" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="0" Grid.ColumnSpan="2" Tag="LaunchAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,在没有确定把握的情况下请不要尝试修改。&#xA;你可以通过点击左侧选项卡的初始化按钮来恢复到默认设置。" ToolTipService.ShowDuration="2333333" Text="-XX:+UseG1GC -XX:-UseAdaptiveSizePolicy -XX:-OmitStackTraceInFastThrow -Dfml.ignoreInvalidMinecraftCertificates=True -Dfml.ignorePatchDiscrepancies=True -Dlog4j2.formatMsgNoLookups=true" />
<TextBlock Grid.Row="2" VerticalAlignment="Center" HorizontalAlignment="Left" Text="额外参数" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceGame" Grid.Row="2" Grid.ColumnSpan="2" Tag="LaunchAdvanceGame" Grid.Column="1" ToolTip="文本框中的内容将会被直接拼合在启动参数的末尾。&#xA;例如输入 --demo 则会以试玩模式启动游戏。" ToolTipService.ShowDuration="2333333" />
</Grid>
<local:MyCheckBox Margin="0,10,0,4" Text="关闭文件校验" x:Name="CheckAdvanceAssets" Tag="LaunchAdvanceAssets" Grid.Column="1" ToolTip="在启动 Minecraft 时,不校验 libraries 文件夹、第三方登录库与版本主 jar 文件,不更改 assets 文件夹。&#xA;如果你没有修改相关文件,请勿勾选此项。&#xA;更推荐在版本设置中关闭特定版本的校验,而不是在这里关闭所有版本的校验。" ToolTipService.ShowDuration="2333333" />
</StackPanel>
<Grid Margin="25,40,25,15">
<Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" SharedSizeGroup="Name" />
<ColumnDefinition Width="1*" />
</Grid.ColumnDefinitions>
<Grid.RowDefinitions>
<RowDefinition Height="28" />
<RowDefinition Height="9" />
<RowDefinition Height="28" />
<RowDefinition Height="Auto" />
</Grid.RowDefinitions>
<TextBlock Grid.Row="0" VerticalAlignment="Center" HorizontalAlignment="Left" Text="JVM 参数" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="0" Grid.ColumnSpan="2" Tag="LaunchAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,在没有确定把握的情况下请不要尝试修改。&#xA;你可以通过点击左侧选项卡的初始化按钮来恢复到默认设置。" ToolTipService.ShowDuration="2333333" Text="-XX:+UseG1GC -XX:-UseAdaptiveSizePolicy -XX:-OmitStackTraceInFastThrow -Dfml.ignoreInvalidMinecraftCertificates=True -Dfml.ignorePatchDiscrepancies=True -Dlog4j2.formatMsgNoLookups=true" />
<TextBlock Grid.Row="2" VerticalAlignment="Center" HorizontalAlignment="Left" Text="额外参数" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceGame" Grid.Row="2" Grid.ColumnSpan="2" Tag="LaunchAdvanceGame" Grid.Column="1" ToolTip="文本框中的内容将会被直接拼合在启动参数的末尾。&#xA;例如输入 --demo 则会以试玩模式启动游戏。" ToolTipService.ShowDuration="2333333" />
<StackPanel Margin="0,10,0,4" Orientation="Horizontal" Grid.Row="3" Grid.ColumnSpan="2">
<local:MyCheckBox Text="忽略 Java 兼容性警告" x:Name="CheckAdvanceJava" Tag="LaunchAdvanceJava" Margin="0,0,60,0"
ToolTip="如果在设置中手动选择了与当前版本不兼容的 Java,则自动跳过兼容性警告弹窗,强制使用手动选择的 Java。" ToolTipService.ShowDuration="2333333" />
<local:MyCheckBox Text="关闭文件校验" x:Name="CheckAdvanceAssets" Tag="LaunchAdvanceAssets"
ToolTip="在启动时不校验 libraries 文件夹、第三方登录库与版本主 jar 文件,不更改 assets 文件夹。&#xA;如果你没有修改相关文件,请勿勾选此项。&#xA;更推荐在版本设置中关闭特定版本的校验,而不是在这里关闭所有版本的校验。" ToolTipService.ShowDuration="2333333" />
</StackPanel>
</Grid>
</local:MyCard>
</StackPanel>
</local:MyScrollViewer>
@@ -48,6 +48,7 @@
TextAdvanceJvm.Text = Setup.Get("LaunchAdvanceJvm")
TextAdvanceGame.Text = Setup.Get("LaunchAdvanceGame")
CheckAdvanceAssets.Checked = Setup.Get("LaunchAdvanceAssets")
CheckAdvanceJava.Checked = Setup.Get("LaunchAdvanceJava")
Catch ex As NullReferenceException
Log(ex, "启动设置项存在异常,已被自动重置", LogLevel.Msgbox)
@@ -74,6 +75,7 @@
Setup.Reset("LaunchSkinID")
Setup.Reset("LaunchAdvanceJvm")
Setup.Reset("LaunchAdvanceGame")
Setup.Reset("LaunchAdvanceJava")
Setup.Reset("LaunchAdvanceAssets")
Setup.Reset("LaunchArgumentJavaAll")
@@ -102,7 +104,7 @@
Private Shared Sub ComboChange(sender As MyComboBox, e As Object) Handles ComboArgumentIndie.SelectionChanged, ComboArgumentVisibie.SelectionChanged, ComboArgumentWindowType.SelectionChanged, ComboArgumentPriority.SelectionChanged
If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.SelectedIndex)
End Sub
Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckAdvanceAssets.Change
Private Shared Sub CheckBoxChange(sender As MyCheckBox, e As Object) Handles CheckAdvanceAssets.Change, CheckAdvanceJava.Change
If AniControlEnabled = 0 Then Setup.Set(sender.Tag, sender.Checked)
End Sub
@@ -208,7 +208,7 @@
If MyMsgBox("若选择此项,即使在将来出现严重问题时,你也无法获取相关通知。" & vbCrLf &
"例如,如果发现某个版本游戏存在严重 Bug,你可能就会因为无法得到通知而导致无法预知的后果。" & vbCrLf & vbCrLf &
"一般选择 仅在有重要通知时显示公告 就可以让你尽量不受打扰了。" & vbCrLf &
"除非你在制作服务器整合包,或时常手动更新启动器,否则极度不推荐选择此项!", "警告", "继续", "取消") = 2 Then
"除非你在制作服务器整合包,或时常手动更新启动器,否则极度不推荐选择此项!", "警告", "我知道我在做什么", "取消", IsWarn:=True) = 2 Then
ComboSystemActivity.SelectedItem = e.RemovedItems(0)
End If
End If
@@ -219,7 +219,7 @@
If MyMsgBox("若选择此项,即使在启动器将来出现严重问题时,你也无法获取更新并获得修复。" & vbCrLf &
"例如,如果官方修改了登录方式,从而导致现有启动器无法登录,你可能就会因为无法更新而无法开始游戏。" & vbCrLf & vbCrLf &
"一般选择 仅在有重大漏洞更新时显示提示 就可以让你尽量不受打扰了。" & vbCrLf &
"除非你在制作服务器整合包,或时常手动更新启动器,否则极度不推荐选择此项!", "警告", "继续", "取消") = 2 Then
"除非你在制作服务器整合包,或时常手动更新启动器,否则极度不推荐选择此项!", "警告", "我知道我在做什么", "取消", IsWarn:=True) = 2 Then
ComboSystemUpdate.SelectedItem = e.RemovedItems(0)
End If
End If
@@ -867,9 +867,6 @@
<Resource Include="Images\Heads\DoodleHuang.png" />
<Resource Include="Images\Heads\wiki.png" />
</ItemGroup>
<ItemGroup>
<Resource Include="Images\Heads\noin.png" />
</ItemGroup>
<ItemGroup>
<WCFMetadata Include="Connected Services\" />
</ItemGroup>
@@ -902,5 +899,14 @@
<ItemGroup>
<Resource Include="Resources\ModData.txt" />
</ItemGroup>
<ItemGroup>
<Resource Include="Images\Skins\Ari.png" />
<Resource Include="Images\Skins\Efe.png" />
<Resource Include="Images\Skins\Kai.png" />
<Resource Include="Images\Skins\Makena.png" />
<Resource Include="Images\Skins\Noor.png" />
<Resource Include="Images\Skins\Sunny.png" />
<Resource Include="Images\Skins\Zuri.png" />
</ItemGroup>
<Import Project="$(MSBuildToolsPath)\Microsoft.VisualBasic.targets" />
</Project>
Binary file not shown.
Binary file not shown.