Merge branch 'main' into feat5684
This commit is contained in:
龙腾猫跃
@@ -624,6 +624,26 @@ Public Module ModAnimation
|
||||
Return Ease.GetValue(t)
|
||||
End Function
|
||||
End Class
|
||||
''' <summary>
|
||||
''' 以特定速度开始的平滑结束。
|
||||
''' </summary>
|
||||
Public Class AniEaseOutFluentWithInitial
|
||||
Inherits AniEase
|
||||
Private ReadOnly alpha As Double '(初速度 / 平均速度) – 1
|
||||
''' <param name="InitialPixelPerSecond">初速度，px/s</param>
|
||||
''' <param name="TotalSecond">总时长，s</param>
|
||||
''' <param name="TotalDistance">总路程，px</param>
|
||||
Public Sub New(InitialPixelPerSecond As Double, TotalSecond As Double, TotalDistance As Double)
|
||||
Dim v0_norm As Double = InitialPixelPerSecond * TotalSecond / TotalDistance '归一化初速度
|
||||
alpha = v0_norm - 1.0
|
||||
If alpha < 0 Then alpha = 0 '初速度小于平均速度时，退化为线性
|
||||
End Sub
|
||||
Public Overrides Function GetValue(percent As Double) As Double
|
||||
Dim p As Double = MathClamp(percent, 0, 1)
|
||||
If alpha = 0 Then Return p '退化到线性
|
||||
Return (alpha + 1) * p / (1 + alpha * p)
|
||||
End Function
|
||||
End Class
|
||||
|
||||
'Back / 回弹
|
||||
''' <summary>
|
||||
@@ -807,7 +827,7 @@ Sleeper:
|
||||
Thread.Sleep(1)
|
||||
Loop
|
||||
Catch ex As Exception
|
||||
Log(ex, "动画帧执行失败", LogLevel.Assert)
|
||||
Log(ex, "动画帧执行失败", LogLevel.Critical)
|
||||
End Try
|
||||
End Sub, "Animation", ThreadPriority.AboveNormal)
|
||||
End Sub
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
Imports System.Globalization
|
||||
Imports System.IO.Compression
|
||||
Imports System.Reflection
|
||||
Imports System.Net.Sockets
|
||||
Imports System.Runtime.CompilerServices
|
||||
Imports System.Security.Cryptography
|
||||
Imports System.Security.Principal
|
||||
@@ -13,13 +13,13 @@ Public Module ModBase
|
||||
#Region "声明"
|
||||
|
||||
'下列版本信息由更新器自动修改
|
||||
Public Const VersionBaseName As String = "2.9.3" '不含分支前缀的显示用版本名
|
||||
Public Const VersionStandardCode As String = "2.9.3." & VersionBranchCode '标准格式的四段式版本号
|
||||
Public Const VersionBaseName As String = "2.10.8" '不含分支前缀的显示用版本名
|
||||
Public Const VersionStandardCode As String = "2.10.8." & VersionBranchCode '标准格式的四段式版本号
|
||||
Public Const CommitHash As String = "" 'Commit Hash，由 GitHub Workflow 自动替换
|
||||
#If BETA Then
|
||||
Public Const VersionCode As Integer = 355 'Release
|
||||
Public Const VersionCode As Integer = 367 'Release
|
||||
#Else
|
||||
Public Const VersionCode As Integer = 354 'Snapshot
|
||||
Public Const VersionCode As Integer = 370 'Snapshot
|
||||
#End If
|
||||
'自动生成的版本信息
|
||||
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
|
||||
@@ -745,7 +745,6 @@ Public Module ModBase
|
||||
Dim IsRight As Boolean = FilePath.EndsWithF("\")
|
||||
FilePath = Left(FilePath, Len(FilePath) - 1)
|
||||
GetPathFromFullPath = Left(FilePath, FilePath.LastIndexOfAny({"\", "/"})) & If(IsRight, "\", "/")
|
||||
If GetPathFromFullPath = "" Then Throw New Exception("不包含路径：" & FilePath)
|
||||
Else
|
||||
'是文件路径
|
||||
GetPathFromFullPath = Left(FilePath, FilePath.LastIndexOfAny({"\", "/"}) + 1)
|
||||
@@ -766,17 +765,6 @@ Public Module ModBase
|
||||
Return FilePath
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 从文件路径或者 Url 获取不包含路径与扩展名的文件名。不包含文件名将会抛出异常。
|
||||
''' </summary>
|
||||
Public Function GetFileNameWithoutExtentionFromPath(FilePath As String) As String
|
||||
Dim Name As String = GetFileNameFromPath(FilePath)
|
||||
If Name.Contains(".") Then
|
||||
Return Name.Substring(0, Name.LastIndexOfF("."))
|
||||
Else
|
||||
Return Name
|
||||
End If
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 从文件夹路径获取文件夹名。
|
||||
''' </summary>
|
||||
Public Function GetFolderNameFromPath(FolderPath As String) As String
|
||||
@@ -786,13 +774,16 @@ Public Module ModBase
|
||||
End Function
|
||||
|
||||
'读取、写入、复制文件
|
||||
''' <summary>
|
||||
''' 复制文件。会自动创建文件夹、会覆盖已有的文件。
|
||||
''' </summary>
|
||||
Public Sub CopyFile(FromPath As String, ToPath As String)
|
||||
Try
|
||||
'还原文件路径
|
||||
If Not FromPath.Contains(":\") Then FromPath = Path & FromPath
|
||||
If Not ToPath.Contains(":\") Then ToPath = Path & ToPath
|
||||
FromPath = If(FromPath.Contains(":\"), FromPath, Path & FromPath)
|
||||
ToPath = If(ToPath.Contains(":\"), ToPath, Path & ToPath)
|
||||
'如果复制同一个文件则跳过
|
||||
If FromPath = ToPath Then Exit Sub
|
||||
If FromPath = ToPath Then Return
|
||||
'确保目录存在
|
||||
Directory.CreateDirectory(GetPathFromFullPath(ToPath))
|
||||
'复制文件
|
||||
@@ -804,7 +795,6 @@ Public Module ModBase
|
||||
''' <summary>
|
||||
''' 读取文件，如果失败则返回空数组。
|
||||
''' </summary>
|
||||
''' <param name="FilePath">文件完整或相对路径。</param>
|
||||
Public Function ReadFileBytes(FilePath As String, Optional Encoding As Encoding = Nothing) As Byte()
|
||||
Try
|
||||
'还原文件路径
|
||||
@@ -860,7 +850,7 @@ Public Module ModBase
|
||||
''' <param name="Append">是否将文件内容追加到当前文件，而不是覆盖它。</param>
|
||||
Public Sub WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing)
|
||||
'处理相对路径
|
||||
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
|
||||
FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath)
|
||||
'确保目录存在
|
||||
Directory.CreateDirectory(GetPathFromFullPath(FilePath))
|
||||
'写入文件
|
||||
@@ -885,7 +875,7 @@ Public Module ModBase
|
||||
''' <param name="Append">是否将文件内容追加到当前文件，而不是覆盖它。</param>
|
||||
Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False)
|
||||
'处理相对路径
|
||||
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
|
||||
FilePath = If(FilePath.Contains(":\"), FilePath, Path & FilePath)
|
||||
'确保目录存在
|
||||
Directory.CreateDirectory(GetPathFromFullPath(FilePath))
|
||||
'写入文件
|
||||
@@ -1282,7 +1272,7 @@ Re:
|
||||
Return Nothing
|
||||
Catch ex As Exception
|
||||
Log(ex, "检查文件出错")
|
||||
Return GetExceptionSummary(ex)
|
||||
Return ex.GetBrief()
|
||||
End Try
|
||||
End Function
|
||||
End Class
|
||||
@@ -1308,16 +1298,13 @@ Re:
|
||||
Else
|
||||
'以 zip 方式解压
|
||||
Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030")))
|
||||
Dim TotalCount As Integer = Archive.Entries.Count
|
||||
Dim TotalCount As Long = Archive.Entries.Count
|
||||
For Each Entry As ZipArchiveEntry In Archive.Entries
|
||||
If ProgressIncrementHandler IsNot Nothing Then ProgressIncrementHandler(1 / TotalCount)
|
||||
If ProgressIncrementHandler IsNot Nothing AndAlso TotalCount > 0 Then ProgressIncrementHandler(1 / TotalCount)
|
||||
Dim DestinationPath As String = IO.Path.Combine(DestDirectory, Entry.FullName)
|
||||
If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then
|
||||
Continue For '不创建空文件夹
|
||||
Else
|
||||
Directory.CreateDirectory(GetPathFromFullPath(DestinationPath))
|
||||
Entry.ExtractToFile(DestinationPath, True)
|
||||
End If
|
||||
If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then Continue For '不创建空文件夹
|
||||
Directory.CreateDirectory(GetPathFromFullPath(DestinationPath))
|
||||
Entry.ExtractToFile(DestinationPath, True)
|
||||
Next
|
||||
End Using
|
||||
End If
|
||||
@@ -1328,11 +1315,20 @@ Re:
|
||||
''' </summary>
|
||||
Public Function DeleteDirectory(Path As String, Optional IgnoreIssue As Boolean = False) As Integer
|
||||
If Not Directory.Exists(Path) Then Return 0
|
||||
If Not Path.EndsWithF("\") Then Path &= "\"
|
||||
If Path.EndsWith(":\") OrElse
|
||||
Path = Environment.GetFolderPath(Environment.SpecialFolder.Desktop) & "\" OrElse
|
||||
Path = Environment.GetFolderPath(Environment.SpecialFolder.DesktopDirectory) & "\" OrElse
|
||||
Path = Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments) & "\" Then '#7030
|
||||
Throw New UnauthorizedAccessException("这是重要的系统文件夹，无法删除：" & Path)
|
||||
End If
|
||||
'实际删除
|
||||
Dim DeletedCount As Integer = 0
|
||||
Dim Files As String()
|
||||
Try
|
||||
Files = Directory.GetFiles(Path)
|
||||
Catch ex As DirectoryNotFoundException '#4549
|
||||
If Not Directory.Exists(Path) Then Return 0 '可能已被其他线程删除
|
||||
Log(ex, $"疑似为孤立符号链接，尝试直接删除（{Path}）", LogLevel.Developer)
|
||||
Directory.Delete(Path)
|
||||
Return 0
|
||||
@@ -1363,8 +1359,9 @@ RetryFile:
|
||||
RetryDir:
|
||||
Try
|
||||
Directory.Delete(Path, True)
|
||||
Catch ex As DirectoryNotFoundException
|
||||
Catch ex As Exception
|
||||
If Not RetriedDir Then
|
||||
If Not RetriedDir AndAlso Not RunInUi() Then
|
||||
RetriedDir = True
|
||||
Log(ex, $"删除文件夹失败，将在 0.3s 后重试（{Path}）")
|
||||
Thread.Sleep(300)
|
||||
@@ -1386,17 +1383,17 @@ RetryDir:
|
||||
ToPath = ToPath.Replace("/", "\")
|
||||
If Not ToPath.EndsWithF("\") Then ToPath &= "\"
|
||||
Dim AllFiles = EnumerateFiles(FromPath).ToList
|
||||
Dim FileCount As Integer = AllFiles.Count
|
||||
Dim FileCount As Long = AllFiles.Count
|
||||
For Each File In AllFiles
|
||||
CopyFile(File.FullName, File.FullName.Replace(FromPath, ToPath))
|
||||
If ProgressIncrementHandler IsNot Nothing Then ProgressIncrementHandler(1 / FileCount)
|
||||
If ProgressIncrementHandler IsNot Nothing AndAlso FileCount > 0 Then ProgressIncrementHandler(1 / FileCount)
|
||||
Next
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 遍历文件夹中的所有文件。
|
||||
''' </summary>
|
||||
Public Function EnumerateFiles(Directory As String) As IEnumerable(Of FileInfo)
|
||||
Dim Info As New DirectoryInfo(ShortenPath(Directory))
|
||||
Dim Info As New DirectoryInfo(Directory)
|
||||
If Not Info.Exists Then Return New List(Of FileInfo)
|
||||
Return Info.EnumerateFiles("*", SearchOption.AllDirectories)
|
||||
End Function
|
||||
@@ -1404,13 +1401,15 @@ RetryDir:
|
||||
''' <summary>
|
||||
''' 若路径长度大于指定值，则将长路径转换为短路径。
|
||||
''' </summary>
|
||||
Public Function ShortenPath(LongPath As String, Optional ShortenThreshold As Integer = 247) As String
|
||||
If LongPath.Length <= ShortenThreshold Then Return LongPath
|
||||
Public Function ShortenPath(LongPath As String) As String
|
||||
If LongPath.Length <= 200 OrElse LongPath.StartsWithF("http", True) Then Return LongPath
|
||||
If Not Directory.Exists(LongPath) AndAlso Not File.Exists(LongPath) Then Return LongPath
|
||||
Dim ShortPath As New StringBuilder(260)
|
||||
GetShortPathName(LongPath, ShortPath, 260)
|
||||
Return ShortPath.ToString
|
||||
ShortenPath = ShortPath.ToString
|
||||
If String.IsNullOrEmpty(ShortenPath) Then Return LongPath
|
||||
End Function
|
||||
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As StringBuilder, ByVal cchBuffer As Integer) As Integer
|
||||
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (lpszLongPath As String, lpszShortPath As StringBuilder, cchBuffer As Integer) As Integer
|
||||
|
||||
#End Region
|
||||
|
||||
@@ -1419,10 +1418,10 @@ RetryDir:
|
||||
Public vbRQ As Char = Convert.ToChar(8221)
|
||||
|
||||
''' <summary>
|
||||
''' 提取 Exception 的具体描述与堆栈。
|
||||
''' 提取 Exception 与 Inner Exception 的详细描述与堆栈信息。返回内容总是多于一行。
|
||||
''' </summary>
|
||||
''' <param name="ShowAllStacks">是否必须显示所有堆栈。通常用于判定堆栈信息。</param>
|
||||
Public Function GetExceptionDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String
|
||||
<Extension> Public Function GetDetail(Ex As Exception, Optional ShowAllStacks As Boolean = False) As String
|
||||
If Ex Is Nothing Then Return "无可用错误信息！"
|
||||
|
||||
'获取最底层的异常
|
||||
@@ -1448,32 +1447,18 @@ RetryDir:
|
||||
IsInner = True
|
||||
Loop
|
||||
|
||||
'常见错误（记得同时修改下面的）
|
||||
Dim CommonReason As String = Nothing
|
||||
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
|
||||
CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。"
|
||||
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
|
||||
CommonReason = "PCL 的权限不足。请尝试右键 PCL，选择以管理员身份运行。"
|
||||
ElseIf TypeOf InnerEx Is OutOfMemoryException Then
|
||||
CommonReason = "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。"
|
||||
ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then
|
||||
CommonReason = "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。"
|
||||
ElseIf {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝",
|
||||
"操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) DescList.Any(Function(l) l.Contains(s))) Then
|
||||
CommonReason = "你的网络环境不佳，导致难以连接到服务器。请检查网络，多重试几次，或尝试使用 VPN。"
|
||||
End If
|
||||
|
||||
'构造输出信息
|
||||
If CommonReason Is Nothing Then
|
||||
Dim UsualReason As String = AnalyzeUsualReason(InnerEx, Ex, DescList)
|
||||
If UsualReason Is Nothing Then
|
||||
Return DescList.Join(vbCrLf)
|
||||
Else
|
||||
Return CommonReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息：" & vbCrLf & DescList.Join(vbCrLf)
|
||||
Return UsualReason & vbCrLf & vbCrLf & "————————————" & vbCrLf & "详细错误信息：" & vbCrLf & DescList.Join(vbCrLf)
|
||||
End If
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 提取 Exception 描述，汇总到一行。
|
||||
''' 提取 Exception 与 Inner Exception 的描述，汇总到一行。
|
||||
''' </summary>
|
||||
Public Function GetExceptionSummary(Ex As Exception) As String
|
||||
<Extension> Public Function GetBrief(Ex As Exception) As String
|
||||
If Ex Is Nothing Then Return "无可用错误信息！"
|
||||
|
||||
'获取最底层的异常
|
||||
@@ -1491,29 +1476,32 @@ RetryDir:
|
||||
DescList = DescList.Distinct.ToList
|
||||
Dim Desc As String = Join(DescList, vbCrLf & "→ ")
|
||||
|
||||
'常见错误（记得同时修改上面的）
|
||||
Dim CommonReason As String = Nothing
|
||||
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
|
||||
CommonReason = "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。"
|
||||
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
|
||||
CommonReason = "PCL 的权限不足。请尝试右键 PCL，选择以管理员身份运行。"
|
||||
ElseIf TypeOf InnerEx Is OutOfMemoryException Then
|
||||
CommonReason = "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。"
|
||||
ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then
|
||||
CommonReason = "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。"
|
||||
ElseIf {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝",
|
||||
"操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) Desc.Contains(s)) Then
|
||||
CommonReason = "你的网络环境不佳，导致难以连接到服务器。请检查网络，多重试几次，或尝试使用 VPN。"
|
||||
End If
|
||||
|
||||
'构造输出信息
|
||||
If CommonReason IsNot Nothing Then
|
||||
Return CommonReason & "详细错误：" & DescList.First
|
||||
Dim UsualReason As String = AnalyzeUsualReason(InnerEx, Ex, DescList)
|
||||
If UsualReason IsNot Nothing Then
|
||||
Return UsualReason & "详细错误：" & DescList.First
|
||||
Else
|
||||
DescList.Reverse() '让最深层错误在最左边
|
||||
Return Join(DescList, " ← ")
|
||||
End If
|
||||
End Function
|
||||
Private Function AnalyzeUsualReason(InnerEx As Exception, OuterEx As Exception, DescList As List(Of String)) As String
|
||||
If TypeOf InnerEx Is TypeLoadException OrElse TypeOf InnerEx Is BadImageFormatException OrElse TypeOf InnerEx Is MissingMethodException OrElse TypeOf InnerEx Is NotImplementedException OrElse TypeOf InnerEx Is TypeInitializationException Then
|
||||
Return "PCL 的运行环境存在问题。请尝试重新安装 .NET Framework 4.6.2 然后再试。若无法安装，请先卸载较新版本的 .NET Framework，然后再尝试安装。"
|
||||
ElseIf TypeOf InnerEx Is UnauthorizedAccessException Then
|
||||
Return "PCL 的权限不足。请尝试右键 PCL 选择以管理员身份运行。"
|
||||
ElseIf TypeOf InnerEx Is OutOfMemoryException Then
|
||||
Return "你的电脑运行内存不足，导致 PCL 无法继续运行。请在关闭一部分不需要的程序后再试。"
|
||||
ElseIf TypeOf InnerEx Is Runtime.InteropServices.COMException Then
|
||||
Return "由于操作系统或显卡存在问题，导致出现错误。请尝试重启 PCL。"
|
||||
ElseIf TypeOf InnerEx Is SocketException AndAlso DescList.Any(Function(l) l.Contains("WSAStartup")) Then
|
||||
Return "请尝试卸载中国移动云盘，然后再试。"
|
||||
ElseIf OuterEx.IsNetworkRelated() Then
|
||||
Return "你的网络环境不佳，请稍后再试，或使用 VPN 改善网络环境。"
|
||||
Else
|
||||
Return Nothing
|
||||
End If
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 返回一个枚举对应的字符串。
|
||||
@@ -1550,12 +1538,12 @@ RetryDir:
|
||||
''' <summary>
|
||||
''' 获取 JSON 对象。
|
||||
''' </summary>
|
||||
Public Function GetJson(Data As String)
|
||||
Public Function GetJson(Data As String) As JToken
|
||||
Try
|
||||
Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local})
|
||||
Catch ex As Exception
|
||||
Dim Length As Integer = If(Data, "").Length
|
||||
Throw New Exception("格式化 JSON 失败：" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data))
|
||||
Throw New Exception("格式化 JSON 失败：" & If(Length > 2000, Data.Substring(0, 500) & $"...(全长 {Length} 个字符)..." & Right(Data, 500), Data), ex)
|
||||
End Try
|
||||
End Function
|
||||
|
||||
@@ -1982,8 +1970,8 @@ RetryDir:
|
||||
#Region "系统"
|
||||
|
||||
''' <summary>
|
||||
''' 线程安全的，可以直接使用 For Each 的 List。
|
||||
''' 在使用 For Each 循环时，列表的结果可能并非最新，但不会抛出异常。
|
||||
''' 线程安全的 List。
|
||||
''' 通过在 For Each 循环中使用一个浅表副本规避多线程操作或移除自身导致的异常。
|
||||
''' </summary>
|
||||
Public Class SafeList(Of T)
|
||||
Inherits SynchronizedCollection(Of T)
|
||||
@@ -2015,8 +2003,8 @@ RetryDir:
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 线程安全的，可以直接使用 For Each 的字典。
|
||||
''' 在使用 For Each 循环时，字典的结果可能并非最新，但不会抛出异常。
|
||||
''' 线程安全的字典。
|
||||
''' 通过在 For Each 循环中使用一个浅表副本规避多线程操作或移除自身导致的异常。
|
||||
''' </summary>
|
||||
Public Class SafeDictionary(Of TKey, TValue)
|
||||
Implements IDictionary(Of TKey, TValue)
|
||||
@@ -2028,8 +2016,8 @@ RetryDir:
|
||||
'构造函数
|
||||
Public Sub New()
|
||||
End Sub
|
||||
Public Sub New(data As IEnumerable(Of KeyValuePair(Of TKey, TValue)))
|
||||
For Each DataItem In data
|
||||
Public Sub New(Data As IEnumerable(Of KeyValuePair(Of TKey, TValue)))
|
||||
For Each DataItem In Data
|
||||
_Dictionary.Add(DataItem.Key, DataItem.Value)
|
||||
Next
|
||||
End Sub
|
||||
@@ -2130,6 +2118,19 @@ RetryDir:
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 将二维数组转换为字典。
|
||||
''' </summary>
|
||||
<Extension> Public Function ToDictionary(Of T)(arr As T(,)) As Dictionary(Of T, T)
|
||||
Dim result As New Dictionary(Of T, T)
|
||||
If arr.Length = 0 Then Return result
|
||||
If arr.GetLength(1) <> 2 Then Throw New ArgumentException("数组必须为两列，第一列为 Key，第二列为 Value。")
|
||||
For i As Integer = 0 To arr.GetLength(0) - 1
|
||||
result(arr(i, 0)) = arr(i, 1)
|
||||
Next
|
||||
Return result
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 可用于临时存放文件的，不含任何特殊字符的文件夹路径，以“\”结尾。
|
||||
''' </summary>
|
||||
@@ -2172,16 +2173,16 @@ RetryDir:
|
||||
''' 返回程序的返回代码，如果运行失败将抛出异常。
|
||||
''' </summary>
|
||||
Public Function RunAsAdmin(Argument As String) As Integer
|
||||
Dim NewProcess = Process.Start(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument})
|
||||
Dim NewProcess = StartProcess(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument})
|
||||
NewProcess.WaitForExit()
|
||||
Return NewProcess.ExitCode
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 判断当前系统语言是否为 zh-CN。
|
||||
''' 判断当前系统语言是否为中文。
|
||||
''' </summary>
|
||||
Public Function IsSystemLanguageChinese() As Boolean
|
||||
Return CultureInfo.CurrentCulture.Name = "zh-CN" OrElse CultureInfo.CurrentUICulture.Name = "zh-CN"
|
||||
Return CultureInfo.CurrentCulture.Name.StartsWithF("zh-") OrElse CultureInfo.CurrentUICulture.Name.StartsWithF("zh-")
|
||||
End Function
|
||||
|
||||
Private Uuid As Integer = 1
|
||||
@@ -2224,6 +2225,9 @@ NextElement:
|
||||
Next i
|
||||
Return ResultArray
|
||||
End Function
|
||||
<Extension> Public Function Any(Arr As UIElementCollection) As Boolean
|
||||
Return Arr?.Count > 0
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 获取格式类似于“11:08:52.037”的当前时间的字符串。
|
||||
@@ -2328,42 +2332,21 @@ NextElement:
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 前台运行文件。
|
||||
''' 启动进程并返回进程实例，若失败则抛出异常。
|
||||
''' 会自动进行长路径处理。
|
||||
''' </summary>
|
||||
''' <param name="FileName">文件名。可以为“notepad”等缩写。</param>
|
||||
''' <param name="Arguments">运行参数。</param>
|
||||
Public Sub ShellOnly(FileName As String, Optional Arguments As String = "")
|
||||
FileName = ShortenPath(FileName)
|
||||
Using Program As New Process
|
||||
Program.StartInfo.Arguments = Arguments
|
||||
Program.StartInfo.FileName = FileName
|
||||
Log("[System] 执行外部命令：" & FileName & " " & Arguments)
|
||||
Program.Start()
|
||||
End Using
|
||||
End Sub
|
||||
Public Function StartProcess(FileName As String, Optional Arguments As String = "") As Process
|
||||
Return StartProcess(New ProcessStartInfo With {.FileName = FileName, .Arguments = Arguments})
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 前台运行文件并返回返回值。
|
||||
''' 启动进程并返回进程实例，若失败则抛出异常。
|
||||
''' 会自动进行长路径处理。
|
||||
''' </summary>
|
||||
''' <param name="FileName">文件名。可以为“notepad”等缩写。</param>
|
||||
''' <param name="Arguments">运行参数。</param>
|
||||
''' <param name="Timeout">等待该程序结束的最长时间（毫秒）。超时会返回 Result.Timeout。</param>
|
||||
Public Function ShellAndGetExitCode(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000) As ProcessReturnValues
|
||||
Try
|
||||
Using Program As New Process
|
||||
Program.StartInfo.Arguments = Arguments
|
||||
Program.StartInfo.FileName = FileName
|
||||
Log("[System] 执行外部命令并等待返回码：" & FileName & " " & Arguments)
|
||||
Program.Start()
|
||||
If Program.WaitForExit(Timeout) Then
|
||||
Return Program.ExitCode
|
||||
Else
|
||||
Return ProcessReturnValues.Timeout
|
||||
End If
|
||||
End Using
|
||||
Catch ex As Exception
|
||||
Log(ex, "执行命令失败：" & FileName, LogLevel.Msgbox)
|
||||
Return ProcessReturnValues.Fail
|
||||
End Try
|
||||
Public Function StartProcess(StartInfo As ProcessStartInfo) As Process
|
||||
StartInfo.FileName = ShortenPath(StartInfo.FileName)
|
||||
If Not String.IsNullOrEmpty(StartInfo.WorkingDirectory) Then StartInfo.WorkingDirectory = ShortenPath(StartInfo.WorkingDirectory)
|
||||
Log("[System] 启动进程：" & StartInfo.FileName & " " & StartInfo.Arguments)
|
||||
Return Process.Start(StartInfo)
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 静默运行文件并返回输出流字符串。执行失败会抛出异常。
|
||||
@@ -2371,10 +2354,11 @@ NextElement:
|
||||
''' <param name="FileName">文件名。可以为“notepad”等缩写。</param>
|
||||
''' <param name="Arguments">运行参数。</param>
|
||||
''' <param name="Timeout">等待该程序结束的最长时间（毫秒）。超时会抛出错误。</param>
|
||||
Public Function ShellAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, Optional WorkingDirectory As String = Nothing) As String
|
||||
Public Function StartProcessAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000,
|
||||
Optional WorkingDirectory As String = Nothing) As String
|
||||
Dim Info = New ProcessStartInfo With {
|
||||
.Arguments = Arguments,
|
||||
.FileName = FileName,
|
||||
.FileName = ShortenPath(FileName),
|
||||
.UseShellExecute = False,
|
||||
.CreateNoWindow = True,
|
||||
.RedirectStandardError = True,
|
||||
@@ -2389,7 +2373,7 @@ NextElement:
|
||||
End If
|
||||
End If
|
||||
Log("[System] 执行外部命令并等待返回结果：" & FileName & " " & Arguments)
|
||||
Using Program As New Process() With {.StartInfo = Info}
|
||||
Using Program As New Process With {.StartInfo = Info}
|
||||
Program.Start()
|
||||
Dim Result As String = Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd
|
||||
Program.WaitForExit(Timeout)
|
||||
@@ -2457,7 +2441,7 @@ NextElement:
|
||||
''' </summary>
|
||||
Public Sub RunInThread(Action As Action)
|
||||
If RunInUi() Then
|
||||
RunInNewThread(Action, "Runtime Invoke " & GetUuid() & "#")
|
||||
RunInNewThread(Action, "Invoke " & GetUuid())
|
||||
Else
|
||||
Action()
|
||||
End If
|
||||
@@ -2491,17 +2475,14 @@ NextElement:
|
||||
''' <summary>
|
||||
''' 尝试从字典中获取某项，如果该项不存在，则返回默认值。
|
||||
''' </summary>
|
||||
<Extension> Public Function GetOrDefault(Of TKey, TValue)(Dict As Dictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue
|
||||
If Dict.ContainsKey(Key) Then
|
||||
Return Dict(Key)
|
||||
Else
|
||||
Return DefaultValue
|
||||
End If
|
||||
<Extension> Public Function GetOrDefault(Of TKey, TValue)(Dict As IDictionary(Of TKey, TValue), Key As TKey, Optional DefaultValue As TValue = Nothing) As TValue
|
||||
Dim Result As TValue
|
||||
Return If(Dict.TryGetValue(Key, Result), Result, DefaultValue)
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 将某项添加到以列表作为值的字典中。
|
||||
''' </summary>
|
||||
<Extension> Public Sub AddToList(Of TKey, TValue)(Dict As Dictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue)
|
||||
<Extension> Public Sub AddToList(Of TKey, TValue)(Dict As IDictionary(Of TKey, List(Of TValue)), Key As TKey, Value As TValue)
|
||||
If Dict.ContainsKey(Key) Then
|
||||
Dict(Key).Add(Value)
|
||||
Else
|
||||
@@ -2549,7 +2530,7 @@ NextElement:
|
||||
Throw New Exception(Url & " 不是一个有效的网址，它必须以 http 开头！")
|
||||
End If
|
||||
Log("[System] 正在打开网页：" & Url)
|
||||
Process.Start(Url)
|
||||
StartProcess(Url)
|
||||
Catch ex As Exception
|
||||
Log(ex, "无法打开网页（" & Url & "）")
|
||||
ClipboardSet(Url, False)
|
||||
@@ -2563,12 +2544,12 @@ NextElement:
|
||||
''' </summary>
|
||||
Public Sub OpenExplorer(Location As String)
|
||||
Try
|
||||
Location = ShortenPath(Location.Replace("/", "\").Trim(" "c, """"c))
|
||||
Location = Location.Replace("/", "\").Trim(" "c, """"c)
|
||||
Log("[System] 正在打开资源管理器：" & Location)
|
||||
If Location.EndsWith("\") Then
|
||||
ShellOnly(Location)
|
||||
StartProcess(Location)
|
||||
Else
|
||||
ShellOnly("explorer", $"/select,""{Location}""")
|
||||
StartProcess("explorer", $"/select,""{Location}""")
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "打开资源管理器失败，请尝试关闭安全软件（如 360 安全卫士）", LogLevel.Msgbox)
|
||||
@@ -2620,10 +2601,6 @@ Retry:
|
||||
''' 相对增减控件的左边距。
|
||||
''' </summary>
|
||||
Public Sub DeltaLeft(control As FrameworkElement, newValue As Double)
|
||||
'安全性检查
|
||||
DebugAssert(Not Double.IsNaN(newValue))
|
||||
DebugAssert(Not Double.IsInfinity(newValue))
|
||||
|
||||
If TypeOf control Is Window Then
|
||||
'窗口改变
|
||||
CType(control, Window).Left += newValue
|
||||
@@ -2635,8 +2612,6 @@ Retry:
|
||||
Case HorizontalAlignment.Right
|
||||
control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right - newValue, control.Margin.Bottom)
|
||||
'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom)
|
||||
Case Else
|
||||
DebugAssert(False)
|
||||
End Select
|
||||
End If
|
||||
End Sub
|
||||
@@ -2644,17 +2619,12 @@ Retry:
|
||||
''' 设置控件的左边距。（仅针对置左控件）
|
||||
''' </summary>
|
||||
Public Sub SetLeft(control As FrameworkElement, newValue As Double)
|
||||
DebugAssert(control.HorizontalAlignment = HorizontalAlignment.Left)
|
||||
control.Margin = New Thickness(newValue, control.Margin.Top, control.Margin.Right, control.Margin.Bottom)
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 相对增减控件的上边距。
|
||||
''' </summary>
|
||||
Public Sub DeltaTop(control As FrameworkElement, newValue As Double)
|
||||
'安全性检查
|
||||
DebugAssert(Not Double.IsNaN(newValue))
|
||||
DebugAssert(Not Double.IsInfinity(newValue))
|
||||
|
||||
If TypeOf control Is Window Then
|
||||
'窗口改变
|
||||
CType(control, Window).Top += newValue
|
||||
@@ -2666,12 +2636,9 @@ Retry:
|
||||
Case VerticalAlignment.Bottom
|
||||
control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, control.Margin.Bottom - newValue)
|
||||
'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom)
|
||||
Case Else
|
||||
DebugAssert(False)
|
||||
End Select
|
||||
End If
|
||||
|
||||
'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Exit Sub '安全性检查
|
||||
'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Return '安全性检查
|
||||
'Select Case control.VerticalAlignment
|
||||
' Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center
|
||||
' control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
|
||||
@@ -2684,7 +2651,6 @@ Retry:
|
||||
''' 设置控件的顶边距。（仅针对置上控件）
|
||||
''' </summary>
|
||||
Public Sub SetTop(control As FrameworkElement, newValue As Double)
|
||||
DebugAssert(control.VerticalAlignment = VerticalAlignment.Top)
|
||||
control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
|
||||
End Sub
|
||||
|
||||
@@ -2755,11 +2721,11 @@ Retry:
|
||||
Using Reader As New XamlXmlReader(Stream)
|
||||
While Reader.Read()
|
||||
For Each BlackListType In {GetType(WebBrowser), GetType(Frame), GetType(MediaElement), GetType(ObjectDataProvider), GetType(XamlReader), GetType(Window), GetType(XmlDataProvider)}
|
||||
If Reader.Type IsNot Nothing AndAlso BlackListType.IsAssignableFrom(Reader.Type.UnderlyingType) Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListType.Name} 类型。")
|
||||
If Reader.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListType.Name} 值。")
|
||||
If Reader.Type IsNot Nothing AndAlso BlackListType.IsAssignableFrom(Reader.Type.UnderlyingType) Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListType.Name} 类型。")
|
||||
If Reader.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListType.Name} 值。")
|
||||
Next
|
||||
For Each BlackListMember In {"Code", "FactoryMethod", "Static"}
|
||||
If Reader.Member IsNot Nothing AndAlso Reader.Member.Name = BlackListMember Then Throw New UnauthorizedAccessException($"不允许使用 {BlackListMember} 成员。")
|
||||
If Reader.Member IsNot Nothing AndAlso Reader.Member.Name = BlackListMember Then Throw New UnauthorizedAccessException($"基于安全考虑，不允许使用 {BlackListMember} 成员。")
|
||||
Next
|
||||
End While
|
||||
End Using
|
||||
@@ -2844,9 +2810,10 @@ Retry:
|
||||
''' </summary>
|
||||
Feedback = 5
|
||||
''' <summary>
|
||||
''' 弹窗，结束程序。
|
||||
''' 弹出 Windows 原生弹窗，要求反馈。在无法保证 WPF 窗口能正常运行时使用此级别。
|
||||
''' 在第二次触发后会直接结束程序。
|
||||
''' </summary>
|
||||
Assert = 6
|
||||
Critical = 6
|
||||
End Enum
|
||||
Private LogList As New StringBuilder
|
||||
Private LogWritter As StreamWriter
|
||||
@@ -2889,7 +2856,7 @@ Retry:
|
||||
Private ReadOnly LogFlushLock As New Object '防止外部调用 LogFlush 时同时输出多次日志
|
||||
Public Sub LogFlush()
|
||||
On Error Resume Next
|
||||
If LogWritter Is Nothing Then Exit Sub
|
||||
If LogWritter Is Nothing Then Return
|
||||
Dim Log As String = Nothing
|
||||
SyncLock LogFlushLock
|
||||
If LogList.Length > 0 Then
|
||||
@@ -2905,6 +2872,7 @@ Retry:
|
||||
End Sub
|
||||
|
||||
Private ReadOnly LogListLock As New Object '防止日志乱码，只在调试模式下启用
|
||||
Private IsCriticalErrorTriggered As Boolean = False
|
||||
''' <summary>
|
||||
''' 输出 Log。
|
||||
''' </summary>
|
||||
@@ -2915,7 +2883,7 @@ Retry:
|
||||
'处理错误会导致再次调用 Log() 导致无限循环
|
||||
|
||||
'输出日志
|
||||
Dim AppendText As String = "[" & GetTimeNow() & "] " & Text & vbCrLf '减轻同步锁占用
|
||||
Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Text}{vbCrLf}" '减轻同步锁占用
|
||||
If ModeDebug Then
|
||||
SyncLock LogListLock
|
||||
LogList.Append(AppendText)
|
||||
@@ -2926,7 +2894,7 @@ Retry:
|
||||
#If DEBUG Then
|
||||
Console.Write(AppendText)
|
||||
#End If
|
||||
If IsProgramEnded OrElse Level = LogLevel.Normal Then Exit Sub
|
||||
If IsProgramEnded OrElse Level = LogLevel.Normal Then Return
|
||||
|
||||
'去除前缀
|
||||
Text = Text.RegexReplace("\[[^\]]+?\] ", "")
|
||||
@@ -2953,22 +2921,26 @@ Retry:
|
||||
Else
|
||||
MyMsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True)
|
||||
End If
|
||||
Case LogLevel.Assert
|
||||
Dim Time As Long = GetTimeTick()
|
||||
Case LogLevel.Critical
|
||||
If IsCriticalErrorTriggered Then
|
||||
FormMain.EndProgramForce(ProcessReturnValues.Exception)
|
||||
Return
|
||||
End If
|
||||
IsCriticalErrorTriggered = True
|
||||
If CanFeedback(False) Then
|
||||
If MsgBox(Text & vbCrLf & vbCrLf & "是否反馈此问题？如果不反馈，这个问题可能永远无法得到解决！", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True)
|
||||
Else
|
||||
MsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title)
|
||||
End If
|
||||
If GetTimeTick() - Time < 1500 Then
|
||||
'弹窗无法保留
|
||||
Log("[System] PCL 已崩溃：" & vbCrLf & Text)
|
||||
FormMain.EndProgramForce(ProcessReturnValues.Exception)
|
||||
Else
|
||||
FormMain.EndProgramForce(ProcessReturnValues.Fail)
|
||||
End If
|
||||
End Select
|
||||
|
||||
'上报
|
||||
If Level >= LogLevel.Hint Then
|
||||
Telemetry("PCL 错误",
|
||||
"Level", GetStringFromEnum(Level),
|
||||
"Title", FilterUserName(FilterAccessToken(Title, "*"), "*"),
|
||||
"Exception", FilterUserName(FilterAccessToken(Text, "*"), "*"))
|
||||
End If
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 输出错误信息。
|
||||
@@ -2976,13 +2948,13 @@ Retry:
|
||||
''' <param name="Desc">错误描述。会在处理时在末尾加入冒号。</param>
|
||||
Public Sub Log(Ex As Exception, Desc As String, Optional Level As LogLevel = LogLevel.Debug, Optional Title As String = "出现错误")
|
||||
On Error Resume Next
|
||||
If TypeOf Ex Is ThreadInterruptedException Then Exit Sub
|
||||
If TypeOf Ex Is ThreadInterruptedException Then Return
|
||||
|
||||
'获取错误信息
|
||||
Dim ExFull As String = Desc & "：" & GetExceptionDetail(Ex)
|
||||
Dim ExFull As String = $"{Desc}：{Ex.GetDetail()}"
|
||||
|
||||
'输出日志
|
||||
Dim AppendText As String = "[" & GetTimeNow() & "] " & Desc & "：" & GetExceptionDetail(Ex, True) & vbCrLf '减轻同步锁占用
|
||||
Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}：{Ex.GetDetail(True)}{vbCrLf}" '减轻同步锁占用
|
||||
If ModeDebug Then
|
||||
SyncLock LogListLock
|
||||
LogList.Append(AppendText)
|
||||
@@ -2993,26 +2965,26 @@ Retry:
|
||||
#If DEBUG Then
|
||||
Console.Write(AppendText)
|
||||
#End If
|
||||
If IsProgramEnded Then Exit Sub
|
||||
If IsProgramEnded Then Return
|
||||
|
||||
'输出提示
|
||||
Select Case Level
|
||||
Case LogLevel.Normal
|
||||
#If DEBUG Then
|
||||
Case LogLevel.Developer
|
||||
Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex)
|
||||
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
|
||||
Hint("[开发者模式] " & ExLine, HintType.Info, False)
|
||||
Case LogLevel.Debug
|
||||
Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex)
|
||||
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
|
||||
Hint("[调试模式] " & ExLine, HintType.Info, False)
|
||||
#Else
|
||||
Case LogLevel.Developer
|
||||
Case LogLevel.Debug
|
||||
Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex)
|
||||
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
|
||||
If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Info, False)
|
||||
#End If
|
||||
Case LogLevel.Hint
|
||||
Dim ExLine As String = Desc & "：" & GetExceptionSummary(Ex)
|
||||
Dim ExLine As String = Desc & "：" & Ex.GetBrief()
|
||||
Hint(ExLine, HintType.Critical, False)
|
||||
Case LogLevel.Msgbox
|
||||
MyMsgBox(ExFull, Title, IsWarn:=True)
|
||||
@@ -3022,22 +2994,26 @@ Retry:
|
||||
Else
|
||||
MyMsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True)
|
||||
End If
|
||||
Case LogLevel.Assert
|
||||
Dim Time As Long = GetTimeTick()
|
||||
Case LogLevel.Critical
|
||||
If IsCriticalErrorTriggered Then
|
||||
FormMain.EndProgramForce(ProcessReturnValues.Exception)
|
||||
Return
|
||||
End If
|
||||
IsCriticalErrorTriggered = True
|
||||
If CanFeedback(False) Then
|
||||
If MsgBox(ExFull & vbCrLf & vbCrLf & "是否反馈此问题？如果不反馈，这个问题可能永远无法得到解决！", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True)
|
||||
Else
|
||||
MsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title)
|
||||
End If
|
||||
If GetTimeTick() - Time < 1500 Then
|
||||
'弹窗无法保留
|
||||
Log("[System] PCL 已崩溃：" & vbCrLf & ExFull)
|
||||
FormMain.EndProgramForce(ProcessReturnValues.Exception)
|
||||
Else
|
||||
FormMain.EndProgramForce(ProcessReturnValues.Fail)
|
||||
End If
|
||||
End Select
|
||||
|
||||
'上报
|
||||
If Level >= LogLevel.Hint Then
|
||||
Telemetry("PCL 异常",
|
||||
"Level", GetStringFromEnum(Level),
|
||||
"Title", FilterUserName(FilterAccessToken(Title, "*"), "*"),
|
||||
"Exception", FilterUserName(FilterAccessToken(ExFull, "*"), "*"))
|
||||
End If
|
||||
End Sub
|
||||
|
||||
'反馈
|
||||
@@ -3047,7 +3023,7 @@ Retry:
|
||||
If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug，请点击 打开文件夹 按钮，并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关，请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then
|
||||
OpenExplorer(Path & "PCL\Log1.txt")
|
||||
End If
|
||||
OpenWebsite("https://github.com/Hex-Dragon/PCL2/issues/")
|
||||
OpenWebsite("https://github.com/Meloong-Git/PCL/issues/")
|
||||
End Sub
|
||||
Public Function CanFeedback(ShowHint As Boolean) As Boolean
|
||||
If False.Equals(PageSetupSystem.IsLauncherNewest) Then
|
||||
@@ -3074,9 +3050,23 @@ Retry:
|
||||
"文件位置：" & Path)
|
||||
End Sub
|
||||
|
||||
'断言
|
||||
Public Sub DebugAssert(Exp As Boolean)
|
||||
If Not Exp Then Throw New Exception("断言命中")
|
||||
'遥测
|
||||
Public Sub Telemetry([Event] As String, ParamArray Datas As String())
|
||||
If Not Setup.Get("SystemSystemTelemetry") Then Return '用户关闭了遥测
|
||||
If Not ClsBaseUrl.StartsWithF("http") Then Return '开源版没有设置遥测地址
|
||||
RunInNewThread(
|
||||
Sub()
|
||||
Try
|
||||
Log($"[System] 匿名数据上报：{[Event]}")
|
||||
Dim Url As String = $"{ClsBaseUrl}&Event={WebUtility.UrlEncode([Event])}"
|
||||
For i = 0 To Datas.Length - 1 Step 2
|
||||
Url &= "&" & WebUtility.UrlEncode(Datas(i)) & "=" & WebUtility.UrlEncode(Datas(i + 1).Replace(vbCrLf, vbLf))
|
||||
Next
|
||||
NetRequestByClient(Url, MakeLog:=False)
|
||||
Catch ex As Exception
|
||||
Log(ex, "匿名数据上报失败")
|
||||
End Try
|
||||
End Sub, "Telemetry", ThreadPriority.Lowest)
|
||||
End Sub
|
||||
|
||||
'获取当前的堆栈信息
|
||||
|
||||
@@ -85,7 +85,7 @@
|
||||
Return _State
|
||||
End Get
|
||||
Set(value As LoadState)
|
||||
If _State = value Then Exit Property
|
||||
If _State = value Then Return
|
||||
Dim OldState = _State
|
||||
If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000))
|
||||
_State = value
|
||||
@@ -112,7 +112,7 @@
|
||||
Return _LoadingState
|
||||
End Get
|
||||
Set(value As MyLoading.MyLoadingState)
|
||||
If _LoadingState = value Then Exit Property
|
||||
If _LoadingState = value Then Return
|
||||
Dim OldState = _LoadingState
|
||||
_LoadingState = value
|
||||
RaiseEvent LoadingStateChanged(value, OldState)
|
||||
@@ -154,7 +154,7 @@
|
||||
End Select
|
||||
End Get
|
||||
Set(value As Double)
|
||||
If _Progress = value Then Exit Property
|
||||
If _Progress = value Then Return
|
||||
Dim OldValue = _Progress
|
||||
_Progress = value
|
||||
RaiseEvent ProgressChanged(value, OldValue)
|
||||
@@ -184,7 +184,7 @@
|
||||
Thread.Sleep(10)
|
||||
Loop
|
||||
If State = LoadState.Finished Then
|
||||
Exit Sub
|
||||
Return
|
||||
ElseIf State = LoadState.Aborted Then
|
||||
Throw New ThreadInterruptedException("加载器执行已中断。")
|
||||
ElseIf IsNothing([Error]) Then
|
||||
@@ -207,7 +207,7 @@
|
||||
If Timeout < 0 Then Throw New TimeoutException(TimeoutMessage)
|
||||
Loop
|
||||
If State = LoadState.Finished Then
|
||||
Exit Sub
|
||||
Return
|
||||
ElseIf State = LoadState.Aborted Then
|
||||
Throw New ThreadInterruptedException("加载器执行已中断。")
|
||||
ElseIf IsNothing([Error]) Then
|
||||
@@ -290,11 +290,12 @@
|
||||
'检验输入以确定情况
|
||||
If IsForceRestart Then Return True '强制要求重启
|
||||
If ((Input Is Nothing) <> (Me.Input Is Nothing)) OrElse (Input IsNot Nothing AndAlso Not Input.Equals(Me.Input)) Then Return True '输入不同
|
||||
If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束
|
||||
(IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '没有超时
|
||||
Return False '则不重试
|
||||
If (State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已结束…
|
||||
(IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse
|
||||
LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '…且没有超时…
|
||||
Return False '…则不重试
|
||||
Else
|
||||
Return True '需要开始
|
||||
Return True '否则需要重启
|
||||
End If
|
||||
End Function
|
||||
Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
|
||||
@@ -308,48 +309,49 @@
|
||||
Progress = -1
|
||||
End SyncLock
|
||||
Else
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
|
||||
LastRunningThread = New Thread(
|
||||
Sub()
|
||||
Try
|
||||
IsForceRestarting = IsForceRestart
|
||||
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
|
||||
LoadDelegate(Me)
|
||||
If IsAborted Then
|
||||
Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", LogLevel.Developer)
|
||||
Else
|
||||
RaisePreviewFinish()
|
||||
State = LoadState.Finished
|
||||
LastFinishedTime = GetTimeTick() '未中断，本次输出有效
|
||||
End If
|
||||
Catch ex As CancelledException
|
||||
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%")
|
||||
If Not IsAborted Then State = LoadState.Aborted
|
||||
Catch ex As ThreadInterruptedException
|
||||
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%")
|
||||
'如果线程是因为判断到 IsAborted 而提前中止，则代表已有新线程被重启，此时不应当改为 Aborted
|
||||
'如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted
|
||||
If Not IsAborted Then State = LoadState.Aborted
|
||||
Catch ex As Exception
|
||||
If IsAborted Then Exit Sub
|
||||
Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer)
|
||||
[Error] = ex
|
||||
State = LoadState.Failed
|
||||
End Try
|
||||
End Sub) With {.Name = Name, .Priority = ThreadPriority}
|
||||
Sub()
|
||||
Try
|
||||
IsForceRestarting = IsForceRestart
|
||||
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
|
||||
LoadDelegate(Me)
|
||||
If IsAborted Then
|
||||
Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束，输出被弃用（最新线程：{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)}）", LogLevel.Developer)
|
||||
Return
|
||||
End If
|
||||
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成")
|
||||
RaisePreviewFinish()
|
||||
State = LoadState.Finished
|
||||
LastFinishedTime = GetTimeTick() '未中断，本次输出有效
|
||||
Catch ex As CancelledException
|
||||
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断，已完成 {Math.Round(Progress * 100)}%")
|
||||
If Not IsAborted Then State = LoadState.Aborted
|
||||
Catch ex As ThreadInterruptedException
|
||||
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断，已完成 {Math.Round(Progress * 100)}%")
|
||||
'如果线程是因为判断到 IsAborted 而提前中止，则代表已有新线程被重启，此时不应当改为 Aborted
|
||||
'如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted
|
||||
If Not IsAborted Then State = LoadState.Aborted
|
||||
Catch ex As Exception
|
||||
If IsAborted Then Return
|
||||
Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错，已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer)
|
||||
[Error] = ex
|
||||
State = LoadState.Failed
|
||||
End Try
|
||||
End Sub) With {.Name = "L/" & Name, .Priority = ThreadPriority}
|
||||
LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsAborted
|
||||
End Sub
|
||||
Public Overrides Sub Abort()
|
||||
If State <> LoadState.Loading Then Exit Sub
|
||||
If State <> LoadState.Loading Then Return
|
||||
SyncLock LockState
|
||||
State = LoadState.Aborted
|
||||
End SyncLock
|
||||
TriggerThreadAbort()
|
||||
End Sub
|
||||
Private Sub TriggerThreadAbort()
|
||||
If LastRunningThread Is Nothing Then Exit Sub
|
||||
If LastRunningThread Is Nothing Then Return
|
||||
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断")
|
||||
If LastRunningThread.IsAlive Then LastRunningThread.Interrupt()
|
||||
LastRunningThread = Nothing
|
||||
@@ -419,7 +421,7 @@
|
||||
'改变状态
|
||||
SyncLock LockState
|
||||
If State = LoadState.Loading Then
|
||||
Exit Sub
|
||||
Return
|
||||
Else
|
||||
State = LoadState.Loading
|
||||
End If
|
||||
@@ -439,7 +441,7 @@
|
||||
If State = LoadState.Loading OrElse State = LoadState.Waiting Then
|
||||
State = LoadState.Aborted
|
||||
Else
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
End SyncLock
|
||||
RunInThread(
|
||||
@@ -470,7 +472,7 @@
|
||||
Case Else
|
||||
'完蛋，出错了
|
||||
SyncLock LockState
|
||||
If State >= LoadState.Finished Then Exit Sub
|
||||
If State >= LoadState.Finished Then Return
|
||||
[Error] = New Exception(Loader.Name & "失败", Loader.Error)
|
||||
State = Loader.State
|
||||
End SyncLock
|
||||
@@ -478,14 +480,14 @@
|
||||
Loader.Abort()
|
||||
Next
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
Exit Sub
|
||||
Return
|
||||
End Select
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 触发一次更新，以启动新加载器或完成。
|
||||
''' </summary>
|
||||
Private Sub Update()
|
||||
If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Exit Sub
|
||||
If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Return
|
||||
Dim IsFinished As Boolean = True
|
||||
Dim Blocked As Boolean = False
|
||||
Dim Input As Object = Me.Input
|
||||
@@ -584,16 +586,11 @@ Restart:
|
||||
Try
|
||||
Dim NewState As Shell.TaskbarItemProgressState
|
||||
Dim NewProgress As Double = LoaderTaskbarProgressGet()
|
||||
'检查任务是否完成，若完成则移除
|
||||
'外显任务是否已经全部完成
|
||||
Dim IsAllDownloadTaskCompleted As Boolean = True
|
||||
For Each Loader In LoaderTaskbar.ToList()
|
||||
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
|
||||
Next
|
||||
'若单个任务已中止或全部任务已完成，则刷新并移除
|
||||
For Each Task In LoaderTaskbar.ToList()
|
||||
If IsAllDownloadTaskCompleted OrElse Task.State = LoadState.Aborted OrElse Task.State = LoadState.Waiting Then
|
||||
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(Task)
|
||||
'若单个任务已中止，或全部任务已完成，则刷新并移除
|
||||
For Each Task In LoaderTaskbar
|
||||
If LoaderTaskbar.All(Function(l) l.State <> LoadState.Loading) OrElse
|
||||
(Task.State = LoadState.Waiting OrElse Task.State = LoadState.Aborted) Then
|
||||
FrmSpeedLeft?.TaskRefresh(Task)
|
||||
LoaderTaskbar.Remove(Task)
|
||||
Log($"[Taskbar] {Task.Name} 已移出任务列表")
|
||||
End If
|
||||
@@ -626,7 +623,7 @@ Restart:
|
||||
Public Function LoaderTaskbarProgressGet() As Double
|
||||
Try
|
||||
If Not LoaderTaskbar.Any Then Return 1
|
||||
Return MathClamp(LoaderTaskbar.Select(Function(e) e.Progress).Average(), 0, 1)
|
||||
Return MathClamp(LoaderTaskbar.Select(Function(l) l.Progress).Average(), 0, 1)
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取任务栏进度出错", LogLevel.Feedback)
|
||||
Return 0.5
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -9,6 +9,7 @@ Public Module ModValidate
|
||||
Dim Result As String = ""
|
||||
For Each ValidateRule As Validate In ValidateRules
|
||||
Result = ValidateRule.Validate(Text)
|
||||
If Result Is Nothing Then Return ""
|
||||
If Result <> "" Then Return Result
|
||||
Next
|
||||
Return Result
|
||||
@@ -21,7 +22,7 @@ End Module
|
||||
''' </summary>
|
||||
Public MustInherit Class Validate
|
||||
''' <summary>
|
||||
''' 验证某字符串是否符合验证要求。若符合，返回空字符串；若不符合，返回错误原因。
|
||||
''' 验证某字符串是否符合验证要求。若符合，返回空字符串；若不符合，返回错误原因；若需要中断检查并直接通过，返回 Nothing。
|
||||
''' </summary>
|
||||
Public MustOverride Function Validate(Str As String) As String
|
||||
End Class
|
||||
@@ -135,9 +136,9 @@ Public Class ValidateLength
|
||||
Me.Max = Max
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Len(Str) <> Max AndAlso Max = Min Then Return "长度必须为 " & Max & " 个字符！"
|
||||
If Len(Str) > Max Then Return "长度最长为 " & Max & " 个字符！"
|
||||
If Len(Str) < Min Then Return "长度至少需 " & Min & " 个字符！"
|
||||
If Len(Str) <> Max AndAlso Max = Min Then Return $"长度必须为 {Max} 个字符！"
|
||||
If Len(Str) > Max Then Return $"长度最长为 {Max} 个字符！"
|
||||
If Len(Str) < Min Then Return $"长度至少需 {Min} 个字符！"
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
@@ -147,7 +148,7 @@ End Class
|
||||
''' </summary>
|
||||
Public Class ValidateExcept
|
||||
Inherits Validate
|
||||
Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String)
|
||||
Public Property Excepts As New ObjectModel.Collection(Of String)
|
||||
Public Property ErrorMessage As String
|
||||
Public Sub New()
|
||||
ErrorMessage = "输入内容不能包含 %"
|
||||
@@ -156,12 +157,15 @@ Public Class ValidateExcept
|
||||
Me.Excepts = Excepts
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
End Sub
|
||||
Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能包含 %")
|
||||
Me.Excepts = New ObjectModel.Collection(Of String)
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
For Each Data As String In Excepts
|
||||
Me.Excepts.Add(Data)
|
||||
Next
|
||||
Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能包含 %")
|
||||
Me.New(
|
||||
New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)),
|
||||
ErrorMessage)
|
||||
End Sub
|
||||
Public Sub New(Excepts As IEnumerable(Of Char), Optional ErrorMessage As String = "输入内容不能包含 %")
|
||||
Me.New(
|
||||
New ObjectModel.Collection(Of String)(Excepts.Select(Function(c) c.ToString).ToList),
|
||||
ErrorMessage)
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
For Each Ch As String In Excepts
|
||||
@@ -180,7 +184,7 @@ End Class
|
||||
''' </summary>
|
||||
Public Class ValidateExceptSame
|
||||
Inherits Validate
|
||||
Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String)
|
||||
Public Property Excepts As New ObjectModel.Collection(Of String)
|
||||
Public Property ErrorMessage As String
|
||||
Public Property IgnoreCase As Boolean = False
|
||||
Public Sub New()
|
||||
@@ -190,13 +194,15 @@ Public Class ValidateExceptSame
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
Me.IgnoreCase = IgnoreCase
|
||||
End Sub
|
||||
Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
|
||||
Me.Excepts = New ObjectModel.Collection(Of String)
|
||||
For Each Data As String In Excepts
|
||||
Me.Excepts.Add(Data)
|
||||
Next
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
Me.IgnoreCase = IgnoreCase
|
||||
Public Sub New(Excepts As IEnumerable(Of String), Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
|
||||
Me.New(
|
||||
New ObjectModel.Collection(Of String)(New List(Of String)(Excepts)),
|
||||
ErrorMessage, IgnoreCase)
|
||||
End Sub
|
||||
Public Sub New(Except As String, Optional ErrorMessage As String = "输入内容不能为 %", Optional IgnoreCase As Boolean = False)
|
||||
Me.New(
|
||||
New ObjectModel.Collection(Of String) From {Except},
|
||||
ErrorMessage, IgnoreCase)
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Str Is Nothing Then Return ErrorMessage.Replace("%", "null")
|
||||
@@ -234,21 +240,21 @@ Public Class ValidateFolderName
|
||||
Try
|
||||
'检查是否为空
|
||||
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
If LengthCheck <> "" Then Return LengthCheck
|
||||
'检查空格
|
||||
If Str.StartsWithF(" ") Then Return "文件夹名不能以空格开头！"
|
||||
If Str.EndsWithF(" ") Then Return "文件夹名不能以空格结尾！"
|
||||
'检查长度
|
||||
LengthCheck = New ValidateLength(1, 100).Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
If LengthCheck <> "" Then Return LengthCheck
|
||||
'检查尾部小数点
|
||||
If Str.EndsWithF(".") Then Return "文件夹名不能以小数点结尾！"
|
||||
'检查特殊字符
|
||||
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "文件夹名不可包含 % 字符！").Validate(Str)
|
||||
If Not CharactCheck = "" Then Return CharactCheck
|
||||
If CharactCheck <> "" Then Return CharactCheck
|
||||
'检查特殊字符串
|
||||
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %！", True).Validate(Str)
|
||||
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
|
||||
If InvalidStrCheck <> "" Then Return InvalidStrCheck
|
||||
'检查 NTFS 8.3 文件名（#4505）
|
||||
If RegexCheck(Str, ".{2,}~\d") Then Return "文件夹名不能包含这一特殊格式！"
|
||||
'检查文件夹重名
|
||||
@@ -295,15 +301,15 @@ Public Class ValidateFileName
|
||||
If Str.EndsWithF(" ") Then Return "文件名不能以空格结尾！"
|
||||
'检查长度
|
||||
LengthCheck = New ValidateLength(1, 253).Validate(Str & If(ParentFolder, ""))
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
If LengthCheck <> "" Then Return LengthCheck
|
||||
'检查尾部小数点
|
||||
If Str.EndsWithF(".") Then Return "文件名不能以小数点结尾！"
|
||||
'检查特殊字符
|
||||
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "文件名不可包含 % 字符！").Validate(Str)
|
||||
If Not CharactCheck = "" Then Return CharactCheck
|
||||
If CharactCheck <> "" Then Return CharactCheck
|
||||
'检查特殊字符串
|
||||
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件名不可为 %！", True).Validate(Str)
|
||||
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
|
||||
If InvalidStrCheck <> "" Then Return InvalidStrCheck
|
||||
'检查 NTFS 8.3 文件名（#4505）
|
||||
If RegexCheck(Str, ".{2,}~\d") Then Return "文件名不能包含这一特殊格式！"
|
||||
'检查文件重名
|
||||
@@ -342,10 +348,10 @@ Public Class ValidateFolderPath
|
||||
If Not Str.TrimEnd("\").EndsWithF(":") Then Str = Str.TrimEnd("\")
|
||||
'检查是否为空
|
||||
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
If LengthCheck <> "" Then Return LengthCheck
|
||||
'检查长度
|
||||
LengthCheck = New ValidateLength(1, 254).Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
If LengthCheck <> "" Then Return LengthCheck
|
||||
'检查开头
|
||||
If Str.StartsWithF("\\Mac\") Then GoTo Fin
|
||||
For Each Drive As DriveInfo In My.Computer.FileSystem.Drives
|
||||
|
||||
@@ -2,6 +2,10 @@
|
||||
|
||||
Public Enum CompType
|
||||
''' <summary>
|
||||
''' 允许任意种类，或种类未知。
|
||||
''' </summary>
|
||||
Any = -1
|
||||
''' <summary>
|
||||
''' Mod。
|
||||
''' </summary>
|
||||
[Mod] = 0
|
||||
@@ -13,6 +17,19 @@
|
||||
''' 资源包。
|
||||
''' </summary>
|
||||
ResourcePack = 2
|
||||
''' <summary>
|
||||
''' 光影包。
|
||||
''' </summary>
|
||||
Shader = 3
|
||||
''' <summary>
|
||||
''' CurseForge：数据包。
|
||||
''' Modrinth：数据包，或数据包与 Mod 的混合。
|
||||
''' </summary>
|
||||
DataPack = 4
|
||||
''' <summary>
|
||||
''' 服务端插件。
|
||||
''' </summary>
|
||||
Plugin = 5
|
||||
End Enum
|
||||
Public Enum CompModLoaderType
|
||||
'https://docs.curseforge.com/?http#tocS_ModLoaderType
|
||||
@@ -61,8 +78,8 @@
|
||||
If SplitedLine.Count >= 2 Then
|
||||
Entry.ChineseName = SplitedLine(1)
|
||||
If Entry.ChineseName.Contains("*") Then '处理 *
|
||||
Entry.ChineseName = Entry.ChineseName.Replace("*", " (" &
|
||||
String.Join(" ", If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Split("-").Select(Function(w) w.Substring(0, 1).ToUpper & w.Substring(1, w.Length - 1))) & ")")
|
||||
Entry.ChineseName = Entry.ChineseName.Replace("*",
|
||||
$" ({If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Replace("-", " ").Capitalize})")
|
||||
End If
|
||||
End If
|
||||
_CompDatabase.Add(Entry)
|
||||
@@ -111,6 +128,7 @@
|
||||
Public ReadOnly FromCurseForge As Boolean
|
||||
''' <summary>
|
||||
''' 工程的种类。
|
||||
''' 由于 Modrinth 混合使用 Mod 和数据包，结果不一定准确。
|
||||
''' </summary>
|
||||
Public ReadOnly Type As CompType
|
||||
''' <summary>
|
||||
@@ -178,7 +196,9 @@
|
||||
Get
|
||||
If Not LoadedDatabase Then
|
||||
LoadedDatabase = True
|
||||
If Type = CompType.Mod Then _DatabaseEntry = CompDatabase.FirstOrDefault(Function(c) If(FromCurseForge, c.CurseForgeSlug, c.ModrinthSlug) = Slug)
|
||||
If Type = CompType.Mod OrElse Type = CompType.DataPack Then
|
||||
_DatabaseEntry = CompDatabase.FirstOrDefault(Function(c) If(FromCurseForge, c.CurseForgeSlug, c.ModrinthSlug) = Slug)
|
||||
End If
|
||||
End If
|
||||
Return _DatabaseEntry
|
||||
End Get
|
||||
@@ -254,6 +274,20 @@
|
||||
LogoUrl = Data("logo")("thumbnailUrl")
|
||||
End If
|
||||
End If
|
||||
'Type
|
||||
If Website.Contains("/mc-mods/") OrElse Website.Contains("/mod/") Then
|
||||
Type = CompType.Mod
|
||||
ElseIf Website.Contains("/modpacks/") Then
|
||||
Type = CompType.ModPack
|
||||
ElseIf Website.Contains("/resourcepacks/") Then
|
||||
Type = CompType.ResourcePack
|
||||
ElseIf Website.Contains("/texture-packs/") Then
|
||||
Type = CompType.ResourcePack
|
||||
ElseIf Website.Contains("/shaders/") Then
|
||||
Type = CompType.Shader
|
||||
Else
|
||||
Type = CompType.DataPack
|
||||
End If
|
||||
'FileIndexes / GameVersions / ModLoaders
|
||||
ModLoaders = New List(Of CompModLoaderType)
|
||||
Dim Files As New List(Of KeyValuePair(Of Integer, List(Of String))) 'FileId, GameVersions
|
||||
@@ -274,20 +308,12 @@
|
||||
Select(Function(v) CInt(Val(v.Split(".")(1).BeforeFirst("-")))).Where(Function(v) v > 0).
|
||||
Distinct.OrderByDescending(Function(v) v).ToList
|
||||
ModLoaders = ModLoaders.Distinct.OrderBy(Of Integer)(Function(t) t).ToList
|
||||
'Type
|
||||
If Website.Contains("/mc-mods/") OrElse Website.Contains("/mod/") Then
|
||||
Type = CompType.Mod
|
||||
ElseIf Website.Contains("/modpacks/") Then
|
||||
Type = CompType.ModPack
|
||||
Else
|
||||
Type = CompType.ResourcePack
|
||||
End If
|
||||
'Tags
|
||||
Tags = New List(Of String)
|
||||
For Each Category In If(Data("categories"), New JArray). '镜像源 API 可能丢失此字段：https://github.com/Hex-Dragon/PCL2/issues/4267#issuecomment-2254590831
|
||||
For Each Category In If(Data("categories"), New JArray). '镜像源 API 可能丢失此字段 (4267#issuecomment-2254590831)
|
||||
Select(Of Integer)(Function(t) t("id")).Distinct.OrderByDescending(Function(c) c)
|
||||
Select Case Category
|
||||
'Mod
|
||||
'Mod
|
||||
Case 406 : Tags.Add("世界元素")
|
||||
Case 407 : Tags.Add("生物群系")
|
||||
Case 410 : Tags.Add("维度")
|
||||
@@ -311,7 +337,7 @@
|
||||
Case 435 : Tags.Add("服务器")
|
||||
Case 5191 : Tags.Add("改良")
|
||||
Case 421 : Tags.Add("支持库")
|
||||
'整合包
|
||||
'整合包
|
||||
Case 4484 : Tags.Add("多人")
|
||||
Case 4479 : Tags.Add("硬核")
|
||||
Case 4483 : Tags.Add("战斗")
|
||||
@@ -321,17 +347,43 @@
|
||||
Case 4475 : Tags.Add("冒险")
|
||||
Case 4476 : Tags.Add("探索")
|
||||
Case 4477 : Tags.Add("小游戏")
|
||||
Case 4471 : Tags.Add("科幻")
|
||||
Case 4474 : Tags.Add("科幻")
|
||||
Case 4736 : Tags.Add("空岛")
|
||||
Case 5128 : Tags.Add("原版改良")
|
||||
Case 4487 : Tags.Add("FTB")
|
||||
Case 4480 : Tags.Add("基于地图")
|
||||
Case 4481 : Tags.Add("轻量")
|
||||
Case 4482 : Tags.Add("大型")
|
||||
'FUTURE: Res
|
||||
'资源包
|
||||
Case 403 : Tags.Add("原版风")
|
||||
Case 400 : Tags.Add("写实风")
|
||||
Case 401 : Tags.Add("现代风")
|
||||
Case 402 : Tags.Add("中世纪")
|
||||
Case 399 : Tags.Add("蒸汽朋克")
|
||||
Case 5244 : Tags.Add("含字体")
|
||||
Case 404 : Tags.Add("动态效果")
|
||||
Case 4465 : Tags.Add("兼容 Mod")
|
||||
Case 393 : Tags.Add("16x")
|
||||
Case 394 : Tags.Add("32x")
|
||||
Case 395 : Tags.Add("64x")
|
||||
Case 396 : Tags.Add("128x")
|
||||
Case 397 : Tags.Add("256x")
|
||||
Case 398 : Tags.Add("超高清")
|
||||
Case 5193 : Tags.Add("数据包") '有这个 Tag 的项会从资源包请求中被移除
|
||||
'光影包
|
||||
Case 6553 : Tags.Add("写实风")
|
||||
Case 6554 : Tags.Add("幻想风")
|
||||
Case 6555 : Tags.Add("原版风")
|
||||
'数据包
|
||||
Case 6948 : Tags.Add("冒险")
|
||||
Case 6949 : Tags.Add("幻想")
|
||||
Case 6950 : Tags.Add("支持库")
|
||||
Case 6952 : Tags.Add("魔法")
|
||||
Case 6946 : Tags.Add("Mod 相关")
|
||||
Case 6951 : Tags.Add("科技")
|
||||
Case 6953 : Tags.Add("实用")
|
||||
End Select
|
||||
Next
|
||||
If Not Tags.Any() Then Tags.Add("杂项")
|
||||
#End Region
|
||||
Else
|
||||
#Region "Modrinth"
|
||||
@@ -353,9 +405,10 @@
|
||||
Distinct.OrderByDescending(Function(v) v).ToList
|
||||
'Type
|
||||
Select Case Data("project_type").ToString
|
||||
Case "mod" : Type = CompType.Mod
|
||||
Case "modpack" : Type = CompType.ModPack
|
||||
Case "resourcepack" : Type = CompType.ResourcePack
|
||||
Case "shader" : Type = CompType.Shader
|
||||
Case Else : Type = CompType.Mod 'Modrinth 将数据包标为 Mod
|
||||
End Select
|
||||
'Tags & ModLoaders
|
||||
Tags = New List(Of String)
|
||||
@@ -377,41 +430,78 @@
|
||||
Case "fabric" : ModLoaders.Add(CompModLoaderType.Fabric)
|
||||
Case "quilt" : ModLoaders.Add(CompModLoaderType.Quilt)
|
||||
Case "neoforge" : ModLoaders.Add(CompModLoaderType.NeoForge)
|
||||
'Mod
|
||||
Case "worldgen" : Tags.Add("世界元素")
|
||||
Case "datapack" : Type = CompType.DataPack '若包含数据包版本，则优先标为 DataPack
|
||||
'共用
|
||||
Case "technology" : Tags.Add("科技")
|
||||
Case "magic" : Tags.Add("魔法")
|
||||
Case "adventure" : Tags.Add("冒险")
|
||||
Case "utility" : Tags.Add("实用")
|
||||
Case "optimization" : Tags.Add("性能优化")
|
||||
Case "vanilla-like" : Tags.Add("原版风")
|
||||
Case "realistic" : Tags.Add("写实风")
|
||||
'Mod/数据包
|
||||
Case "worldgen" : Tags.Add("世界元素")
|
||||
Case "food" : Tags.Add("食物/烹饪")
|
||||
Case "game-mechanics" : Tags.Add("游戏机制")
|
||||
Case "transportation" : Tags.Add("运输")
|
||||
Case "storage" : Tags.Add("仓储")
|
||||
Case "magic" : Tags.Add("魔法")
|
||||
Case "adventure" : Tags.Add("冒险")
|
||||
Case "decoration" : Tags.Add("装饰")
|
||||
Case "mobs" : Tags.Add("生物")
|
||||
Case "equipment" : Tags.Add("装备")
|
||||
Case "optimization" : Tags.Add("性能优化")
|
||||
Case "decoration" : If Type <> CompType.ResourcePack Then Tags.Add("装饰")
|
||||
Case "mobs" : If Type <> CompType.ResourcePack Then Tags.Add("生物")
|
||||
Case "equipment" : If Type <> CompType.ResourcePack Then Tags.Add("装备")
|
||||
Case "social" : Tags.Add("服务器")
|
||||
Case "utility" : Tags.Add("改良")
|
||||
Case "library" : Tags.Add("支持库")
|
||||
'整合包
|
||||
Case "multiplayer" : Tags.Add("多人")
|
||||
Case "optimization" : Tags.Add("性能优化")
|
||||
Case "challenging" : Tags.Add("硬核")
|
||||
Case "combat" : Tags.Add("战斗")
|
||||
Case "quests" : Tags.Add("任务")
|
||||
Case "technology" : Tags.Add("科技")
|
||||
Case "magic" : Tags.Add("魔法")
|
||||
Case "adventure" : Tags.Add("冒险")
|
||||
Case "kitchen-sink" : Tags.Add("水槽包/大杂烩")
|
||||
Case "kitchen-sink" : Tags.Add("水槽包")
|
||||
Case "lightweight" : Tags.Add("轻量")
|
||||
'FUTURE: Res
|
||||
'资源包
|
||||
Case "simplistic" : Tags.Add("简洁")
|
||||
Case "combat" : Tags.Add("战斗")
|
||||
Case "tweaks" : Tags.Add("改良")
|
||||
|
||||
Case "8x-" : Tags.Add("极简")
|
||||
Case "16x" : Tags.Add("16x")
|
||||
Case "32x" : Tags.Add("32x")
|
||||
Case "48x" : Tags.Add("48x")
|
||||
Case "64x" : Tags.Add("64x")
|
||||
Case "128x" : Tags.Add("128x")
|
||||
Case "256x" : Tags.Add("256x")
|
||||
Case "512x+" : Tags.Add("超高清")
|
||||
|
||||
Case "audio" : Tags.Add("含声音")
|
||||
Case "fonts" : Tags.Add("含字体")
|
||||
Case "models" : Tags.Add("含模型")
|
||||
Case "gui" : Tags.Add("含 UI")
|
||||
Case "locale" : Tags.Add("含语言")
|
||||
Case "core-shaders" : Tags.Add("核心着色器")
|
||||
Case "modded" : Tags.Add("兼容 Mod")
|
||||
'光影包
|
||||
Case "fantasy" : Tags.Add("幻想风")
|
||||
Case "semi-realistic" : Tags.Add("半写实风")
|
||||
Case "cartoon" : Tags.Add("卡通风")
|
||||
'暂时不添加性能负荷 Tag
|
||||
'Case "potato" : Tags.Add("极低")
|
||||
'Case "low" : Tags.Add("低")
|
||||
'Case "medium" : Tags.Add("中")
|
||||
'Case "high" : Tags.Add("高")
|
||||
Case "colored-lighting" : Tags.Add("彩色光照")
|
||||
Case "path-tracing" : Tags.Add("路径追踪")
|
||||
Case "pbr" : Tags.Add("PBR")
|
||||
Case "reflections" : Tags.Add("反射")
|
||||
|
||||
Case "iris" : Tags.Add("Iris")
|
||||
Case "optifine" : Tags.Add("OptiFine")
|
||||
Case "vanilla" : Tags.Add("原版可用")
|
||||
End Select
|
||||
Next
|
||||
If Not Tags.Any() Then Tags.Add("杂项")
|
||||
Tags.Sort()
|
||||
ModLoaders.Sort()
|
||||
#End Region
|
||||
End If
|
||||
If Not Tags.Any() Then Tags.Add("其他")
|
||||
Tags.Sort()
|
||||
ModLoaders.Sort()
|
||||
End If
|
||||
'保存缓存
|
||||
CompProjectCache(Id) = Me
|
||||
@@ -534,7 +624,7 @@
|
||||
NewItem.ColumnVersion1.Width = New GridLength(0)
|
||||
NewItem.ColumnVersion2.MaxWidth = 0
|
||||
NewItem.ColumnVersion3.Width = New GridLength(0)
|
||||
ElseIf ShowMcVersionDesc AndAlso ShowMcVersionDesc Then
|
||||
ElseIf ShowMcVersionDesc AndAlso ShowLoaderDesc Then
|
||||
'全部显示
|
||||
NewItem.LabVersion.Text = If(ModLoaderDescriptionPart = "", "", ModLoaderDescriptionPart & " ") & GameVersionDescription
|
||||
ElseIf ShowMcVersionDesc Then
|
||||
@@ -664,8 +754,8 @@ NoSubtitle:
|
||||
If FromCurseForge = Project.FromCurseForge Then Return False
|
||||
'Mod 加载器一致
|
||||
If ModLoaders.Count <> Project.ModLoaders.Count OrElse ModLoaders.Except(Project.ModLoaders).Any() Then Return False
|
||||
'MC 版本一致
|
||||
If GameVersions.Count <> Project.GameVersions.Count OrElse GameVersions.Except(Project.GameVersions).Any() Then Return False
|
||||
'若不为光影，则要求 MC 版本一致
|
||||
If Type <> CompType.Shader AndAlso (GameVersions.Count <> Project.GameVersions.Count OrElse GameVersions.Except(Project.GameVersions).Any()) Then Return False
|
||||
'最近更新时间差距在一周以内
|
||||
If LastUpdate IsNot Nothing AndAlso Project.LastUpdate IsNot Nothing AndAlso
|
||||
Math.Abs((LastUpdate - Project.LastUpdate).Value.TotalDays) > 7 Then Return False
|
||||
@@ -775,8 +865,12 @@ NoSubtitle:
|
||||
Address += "&classId=6"
|
||||
Case CompType.ModPack
|
||||
Address += "&classId=4471"
|
||||
Case CompType.DataPack
|
||||
Address += "&classId=6945"
|
||||
Case CompType.Shader
|
||||
Address += "&classId=6552"
|
||||
Case CompType.ResourcePack
|
||||
'FUTURE: Res
|
||||
Address += "&classId=12"
|
||||
End Select
|
||||
Address += "&categoryId=" & If(Tag = "", "0", Tag.BeforeFirst("/"))
|
||||
If ModLoader <> CompModLoaderType.Any Then Address += "&modLoaderType=" & CType(ModLoader, Integer)
|
||||
@@ -856,38 +950,39 @@ NoSubtitle:
|
||||
''' 根据搜索请求获取一系列的工程列表。需要基于加载器运行。
|
||||
''' </summary>
|
||||
Public Sub CompProjectsGet(Task As LoaderTask(Of CompProjectRequest, Integer))
|
||||
Dim Storage = Task.Input.Storage '避免多线程问题
|
||||
Dim Request As CompProjectRequest = Task.Input
|
||||
Dim Storage = Request.Storage '避免多线程问题
|
||||
|
||||
If Task.Input.Storage.Results.Count >= Task.Input.TargetResultCount Then
|
||||
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果，多于所需的 {Task.Input.TargetResultCount} 个结果，结束处理")
|
||||
Exit Sub
|
||||
ElseIf Not Task.Input.CanContinue Then
|
||||
If Not Task.Input.Storage.Results.Any() Then
|
||||
If Request.Storage.Results.Count >= Request.TargetResultCount Then
|
||||
Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果，多于所需的 {Request.TargetResultCount} 个结果，结束处理")
|
||||
Return
|
||||
ElseIf Not Request.CanContinue Then
|
||||
If Not Request.Storage.Results.Any() Then
|
||||
Throw New Exception("没有符合条件的结果")
|
||||
Else
|
||||
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果，少于所需的 {Task.Input.TargetResultCount} 个结果，但无法继续获取，结束处理")
|
||||
Exit Sub
|
||||
Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果，少于所需的 {Request.TargetResultCount} 个结果，但无法继续获取，结束处理")
|
||||
Return
|
||||
End If
|
||||
End If
|
||||
|
||||
#Region "拒绝 1.13- Quilt（这个版本根本没有 Quilt）"
|
||||
|
||||
If Task.Input.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Task.Input.GameVersion, "1.15"), "1.14") = -1 Then
|
||||
Throw New Exception("Quilt 不支持 Minecraft " & Task.Input.GameVersion)
|
||||
If Request.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Request.GameVersion, "1.15"), "1.14") = -1 Then
|
||||
Throw New Exception("Quilt 不支持 Minecraft " & Request.GameVersion)
|
||||
End If
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "处理搜索文本，赋值回 Task.Input.SearchText"
|
||||
|
||||
Dim RawFilter As String = If(Task.Input.SearchText, "").Trim
|
||||
Task.Input.SearchText = RawFilter
|
||||
Dim RawFilter As String = If(Request.SearchText, "").Trim
|
||||
Request.SearchText = RawFilter
|
||||
RawFilter = RawFilter.ToLower
|
||||
Log("[Comp] 工程列表搜索原始文本：" & RawFilter)
|
||||
|
||||
'中文请求关键字处理
|
||||
Dim IsChineseSearch As Boolean = RegexCheck(RawFilter, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawFilter)
|
||||
If IsChineseSearch AndAlso Task.Input.Type = CompType.Mod Then
|
||||
If IsChineseSearch AndAlso (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then
|
||||
'构造搜索请求
|
||||
Dim SearchEntries As New List(Of SearchEntry(Of CompDatabaseEntry))
|
||||
For Each Entry In CompDatabase
|
||||
@@ -900,7 +995,7 @@ NoSubtitle:
|
||||
})
|
||||
Next
|
||||
'获取搜索结果
|
||||
Dim SearchResults = Search(SearchEntries, Task.Input.SearchText, 3)
|
||||
Dim SearchResults = Search(SearchEntries, Request.SearchText, 3)
|
||||
If Not SearchResults.Any() Then Throw New Exception("无搜索结果，请尝试搜索英文名称")
|
||||
Dim SearchResult As String = ""
|
||||
For i = 0 To Math.Min(4, SearchResults.Count - 1) '就算全是准确的，也最多只要 5 个
|
||||
@@ -918,14 +1013,14 @@ NoSubtitle:
|
||||
If SearchResult.Split(" ").Count > 3 AndAlso {"ftb"}.Contains(Word.ToLower) Then Continue For
|
||||
RealFilter += Word.TrimStart("{[(").TrimEnd("}])") & " "
|
||||
Next
|
||||
Task.Input.SearchText = RealFilter
|
||||
Request.SearchText = RealFilter
|
||||
Log("[Comp] 中文搜索最终关键词：" & RealFilter, LogLevel.Developer)
|
||||
End If
|
||||
|
||||
'驼峰英文请求关键字处理
|
||||
Dim SpacedKeywords = Task.Input.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ")
|
||||
Dim ConnectedKeywords = Task.Input.SearchText.Replace(" ", "")
|
||||
Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Task.Input.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower
|
||||
Dim SpacedKeywords = Request.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ")
|
||||
Dim ConnectedKeywords = Request.SearchText.Replace(" ", "")
|
||||
Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Request.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower
|
||||
|
||||
'最终处理关键字：分割、去重
|
||||
Dim RightKeywords As New List(Of String)
|
||||
@@ -939,15 +1034,15 @@ NoSubtitle:
|
||||
RightKeywords.Add(Keyword)
|
||||
Next
|
||||
If RawFilter.Length > 0 AndAlso Not RightKeywords.Any() Then
|
||||
Task.Input.SearchText = RawFilter '全都被过滤掉了
|
||||
Request.SearchText = RawFilter '全都被过滤掉了
|
||||
Else
|
||||
Task.Input.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower
|
||||
Request.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower
|
||||
End If
|
||||
|
||||
'例外项：OptiForge、OptiFabric（拆词后因为包含 Forge/Fabric 导致无法搜到实际的 Mod）
|
||||
If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Task.Input.SearchText = "optiforge"
|
||||
If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Task.Input.SearchText = "optifabric"
|
||||
Log("[Comp] 工程列表搜索最终文本：" & Task.Input.SearchText, LogLevel.Debug)
|
||||
If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Request.SearchText = "optiforge"
|
||||
If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Request.SearchText = "optifabric"
|
||||
Log("[Comp] 工程列表搜索最终文本：" & Request.SearchText, LogLevel.Debug)
|
||||
Task.Progress = 0.1
|
||||
|
||||
#End Region
|
||||
@@ -963,10 +1058,17 @@ Retry:
|
||||
Dim ModrinthThread As Thread = Nothing
|
||||
Dim ResultsLock As New Object
|
||||
|
||||
'在 1.14-，部分老 Mod 没有设置支持的加载器，因此添加 Forge 筛选就会出现遗漏
|
||||
'所以，在发起请求时不筛选加载器，然后在返回的结果中自行筛除不是 Forge 的 Mod
|
||||
Dim IsOldForgeRequest = Request.ModLoader = CompModLoaderType.Forge AndAlso Request.GameVersion?.Contains(".") AndAlso Val(Request.GameVersion.Split(".")(1)) < 14
|
||||
If IsOldForgeRequest Then Request.ModLoader = CompModLoaderType.Any
|
||||
Dim CurseForgeUrl As String = Request.GetCurseForgeAddress()
|
||||
Dim ModrinthUrl As String = Request.GetModrinthAddress()
|
||||
If IsOldForgeRequest Then Request.ModLoader = CompModLoaderType.Forge '设置回去
|
||||
|
||||
Try
|
||||
|
||||
'启动 CurseForge 线程
|
||||
Dim CurseForgeUrl As String = Task.Input.GetCurseForgeAddress()
|
||||
Dim CurseForgeFailed As Boolean = False
|
||||
If CurseForgeUrl IsNot Nothing Then
|
||||
CurseForgeThread = RunInNewThread(
|
||||
@@ -974,11 +1076,13 @@ Retry:
|
||||
Try
|
||||
'获取工程列表
|
||||
Log("[Comp] 开始从 CurseForge 获取工程列表：" & CurseForgeUrl)
|
||||
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl, IsJson:=True)
|
||||
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl)
|
||||
Task.Progress += 0.2
|
||||
Dim ProjectList As New List(Of CompProject)
|
||||
For Each JsonEntry As JObject In RequestResult("data")
|
||||
ProjectList.Add(New CompProject(JsonEntry))
|
||||
Dim Project As New CompProject(JsonEntry)
|
||||
If Request.Type = CompType.ResourcePack AndAlso Project.Tags.Contains("数据包") Then Continue For 'CurseForge 将一些数据包分类成了资源包
|
||||
ProjectList.Add(Project)
|
||||
Next
|
||||
'更新结果
|
||||
SyncLock ResultsLock
|
||||
@@ -997,14 +1101,13 @@ Retry:
|
||||
End If
|
||||
|
||||
'启动 Modrinth 线程
|
||||
Dim ModrinthUrl As String = Task.Input.GetModrinthAddress()
|
||||
Dim ModrinthFailed As Boolean = False
|
||||
If ModrinthUrl IsNot Nothing Then
|
||||
ModrinthThread = RunInNewThread(
|
||||
Sub()
|
||||
Try
|
||||
Log("[Comp] 开始从 Modrinth 获取工程列表：" & ModrinthUrl)
|
||||
Dim RequestResult As JObject = DlModRequest(ModrinthUrl, IsJson:=True)
|
||||
Dim RequestResult As JObject = DlModRequest(ModrinthUrl)
|
||||
Task.Progress += 0.2
|
||||
Dim ProjectList As New List(Of CompProject)
|
||||
For Each JsonEntry As JObject In RequestResult("hits")
|
||||
@@ -1013,7 +1116,6 @@ Retry:
|
||||
'更新结果
|
||||
SyncLock ResultsLock
|
||||
For Each Project In ProjectList
|
||||
If Task.Input.Type = CompType.Mod AndAlso Not Project.ModLoaders.Any() Then Continue For '过滤插件（#2458）
|
||||
RawResults.Add(Project)
|
||||
Next
|
||||
End SyncLock
|
||||
@@ -1031,9 +1133,14 @@ Retry:
|
||||
|
||||
'等待线程结束
|
||||
If CurseForgeThread IsNot Nothing Then CurseForgeThread.Join()
|
||||
If Task.IsAborted Then Exit Sub '会自动触发 Finally
|
||||
If Task.IsAborted Then Return '会自动触发 Finally
|
||||
If ModrinthThread IsNot Nothing Then ModrinthThread.Join()
|
||||
If Task.IsAborted Then Exit Sub
|
||||
If Task.IsAborted Then Return
|
||||
|
||||
'筛除不是 Forge 的 Mod
|
||||
If IsOldForgeRequest Then
|
||||
RawResults = RawResults.Where(Function(p) Not p.ModLoaders.Any() OrElse p.ModLoaders.Contains(CompModLoaderType.Forge)).ToList
|
||||
End If
|
||||
|
||||
'确保存在结果
|
||||
Storage.ErrorMessage = Nothing
|
||||
@@ -1041,11 +1148,11 @@ Retry:
|
||||
If [Error] IsNot Nothing Then
|
||||
Throw [Error]
|
||||
Else
|
||||
If IsChineseSearch AndAlso Task.Input.Type <> CompType.Mod Then
|
||||
Throw New Exception($"{If(Task.Input.Type = CompType.ModPack, "整合包", "资源包")}搜索仅支持英文")
|
||||
ElseIf Task.Input.Source = CompSourceType.CurseForge AndAlso Task.Input.Tag.StartsWithF("/") Then
|
||||
If IsChineseSearch AndAlso Not (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then
|
||||
Throw New Exception("没有搜索结果，请尝试使用英文搜索")
|
||||
ElseIf Request.Source = CompSourceType.CurseForge AndAlso Request.Tag.StartsWithF("/") Then
|
||||
Throw New Exception("CurseForge 不兼容所选的类型")
|
||||
ElseIf Task.Input.Source = CompSourceType.Modrinth AndAlso Task.Input.Tag.EndsWithF("/") Then
|
||||
ElseIf Request.Source = CompSourceType.Modrinth AndAlso Request.Tag.EndsWithF("/") Then
|
||||
Throw New Exception("Modrinth 不兼容所选的类型")
|
||||
Else
|
||||
Throw New Exception("没有搜索结果")
|
||||
@@ -1054,15 +1161,15 @@ Retry:
|
||||
ElseIf [Error] IsNot Nothing Then
|
||||
'有结果但是有错误
|
||||
If CurseForgeFailed Then
|
||||
Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，结果可能不全。{vbCrLf}请尝试使用 VPN 或加速器以改善网络。"
|
||||
Storage.ErrorMessage = $"无法连接到 CurseForge，所以目前仅显示了来自 Modrinth 的内容，搜索结果可能不全。{vbCrLf}请稍后再试，或使用 VPN 改善网络环境。"
|
||||
Else
|
||||
Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，结果可能不全。{vbCrLf}请尝试使用 VPN 或加速器以改善网络。"
|
||||
Storage.ErrorMessage = $"无法连接到 Modrinth，所以目前仅显示了来自 CurseForge 的内容，搜索结果可能不全。{vbCrLf}请稍后再试，或使用 VPN 改善网络环境。"
|
||||
End If
|
||||
End If
|
||||
|
||||
Finally
|
||||
If CurseForgeThread IsNot Nothing Then CurseForgeThread.Interrupt()
|
||||
If ModrinthThread IsNot Nothing Then ModrinthThread.Interrupt()
|
||||
CurseForgeThread?.Interrupt()
|
||||
ModrinthThread?.Interrupt()
|
||||
End Try
|
||||
|
||||
#End Region
|
||||
@@ -1085,9 +1192,9 @@ Retry:
|
||||
|
||||
#Region "检查结果数量，如果不足且可继续，会继续加载下一页"
|
||||
|
||||
If RealResults.Count + Storage.Results.Count < Task.Input.TargetResultCount Then
|
||||
Log($"[Comp] 总结果数需求最少 {Task.Input.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个")
|
||||
If Task.Input.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试，这时候重试可能导致无限循环
|
||||
If RealResults.Count + Storage.Results.Count < Request.TargetResultCount Then
|
||||
Log($"[Comp] 总结果数需求最少 {Request.TargetResultCount} 个，仅获得了 {RealResults.Count + Storage.Results.Count} 个")
|
||||
If Request.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试，这时候重试可能导致无限循环
|
||||
Log("[Comp] 将继续尝试加载下一页")
|
||||
GoTo Retry
|
||||
Else
|
||||
@@ -1100,10 +1207,23 @@ Retry:
|
||||
#Region "将结果排序并添加"
|
||||
|
||||
Dim Scores As New Dictionary(Of CompProject, Double) '排序分
|
||||
If String.IsNullOrEmpty(Task.Input.SearchText) Then
|
||||
Dim GetDownloadCountMult =
|
||||
Function(Project As CompProject) As Double
|
||||
Select Case Request.Type
|
||||
Case CompType.Mod, CompType.ModPack
|
||||
Return If(Project.FromCurseForge, 1, 7)
|
||||
Case CompType.DataPack
|
||||
Return If(Project.FromCurseForge, 10, 1)
|
||||
Case CompType.ResourcePack, CompType.Shader
|
||||
Return If(Project.FromCurseForge, 1, 5)
|
||||
Case Else
|
||||
Return 1
|
||||
End Select
|
||||
End Function
|
||||
If String.IsNullOrEmpty(Request.SearchText) Then
|
||||
'如果没有搜索文本，按下载量将结果排序
|
||||
For Each Result As CompProject In RealResults
|
||||
Scores.Add(Result, Result.DownloadCount * If(Result.FromCurseForge, 1, 5))
|
||||
Scores.Add(Result, Result.DownloadCount * GetDownloadCountMult(Result))
|
||||
Next
|
||||
Else
|
||||
'如果有搜索文本，按关联度将结果排序
|
||||
@@ -1111,7 +1231,7 @@ Retry:
|
||||
Dim Entry As New List(Of SearchEntry(Of CompProject))
|
||||
For Each Result As CompProject In RealResults
|
||||
Scores.Add(Result, If(Result.WikiId > 0, 0.2, 0) +
|
||||
Math.Log10(Math.Max(Result.DownloadCount, 1) * If(Result.FromCurseForge, 1, 5)) / 9)
|
||||
Math.Log10(Math.Max(Result.DownloadCount, 1) * GetDownloadCountMult(Result)) / 9)
|
||||
Entry.Add(New SearchEntry(Of CompProject) With {.Item = Result, .SearchSource = New List(Of KeyValuePair(Of String, Double)) From {
|
||||
New KeyValuePair(Of String, Double)(If(IsChineseSearch, Result.TranslatedName, Result.RawName), 1),
|
||||
New KeyValuePair(Of String, Double)(Result.Description, 0.05)}})
|
||||
@@ -1194,7 +1314,7 @@ Retry:
|
||||
Case CompFileStatus.Beta
|
||||
Return If(ModeDebug, "Beta 版", "测试版")
|
||||
Case Else
|
||||
Return If(ModeDebug, "Alpha 版", "测试版")
|
||||
Return If(ModeDebug, "Alpha 版", "早期测试版")
|
||||
End Select
|
||||
End Get
|
||||
End Property
|
||||
@@ -1234,7 +1354,7 @@ Retry:
|
||||
''' </summary>
|
||||
''' <param name="LocalAddress">目标本地文件夹，或完整的文件路径。会自动判断类型。</param>
|
||||
Public Function ToNetFile(LocalAddress As String) As NetFile
|
||||
Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), UseBrowserUserAgent:=True)
|
||||
Return New NetFile(DownloadUrls, LocalAddress & If(LocalAddress.EndsWithF("\"), FileName, ""), New FileChecker(Hash:=Hash), SimulateBrowserHeaders:=True)
|
||||
End Function
|
||||
|
||||
'实例化
|
||||
@@ -1242,8 +1362,8 @@ Retry:
|
||||
''' <summary>
|
||||
''' 从文件 Json 中初始化实例。若出错会抛出异常。
|
||||
''' </summary>
|
||||
Public Sub New(Data As JObject, Type As CompType)
|
||||
Me.Type = Type
|
||||
Public Sub New(Data As JObject, DefaultType As CompType)
|
||||
Type = DefaultType
|
||||
If Data.ContainsKey("FromCurseForge") Then
|
||||
#Region "CompJson"
|
||||
FromCurseForge = Data("FromCurseForge").ToObject(Of Boolean)
|
||||
@@ -1275,13 +1395,12 @@ Retry:
|
||||
If Hash Is Nothing Then Hash = CType(Data("hashes"), JArray).ToList.FirstOrDefault(Function(s) s("algo").ToObject(Of Integer) = 2)?("value")
|
||||
'DownloadAddress
|
||||
Dim Url = Data("downloadUrl").ToString
|
||||
If Url = "" Then Url = $"https://media.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
|
||||
Url = Url.Replace(FileName, Net.WebUtility.UrlEncode(FileName)) '对文件名进行编码
|
||||
DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正
|
||||
DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源，这个写法是为了让镜像源排在后面
|
||||
If Url = "" Then Url = $"https://edge.forgecdn.net/files/{CInt(Id.ToString.Substring(0, 4))}/{CInt(Id.ToString.Substring(4))}/{FileName}"
|
||||
DownloadUrls = HandleCurseForgeDownloadUrls(Url.Replace(FileName, WebUtility.UrlEncode(FileName))) '对脑残 CurseForge 的下载地址进行多种修正
|
||||
DownloadUrls.Add(DlSourceModGet(Url)) '添加镜像源；注意 MCIM 源不支持 URL 编码后的文件名，必须传入 URL 编码前的文件名
|
||||
DownloadUrls = DownloadUrls.Distinct.ToList '最终去重
|
||||
'Dependencies
|
||||
If Type = CompType.Mod Then
|
||||
If Data.ContainsKey("dependencies") Then
|
||||
RawDependencies = Data("dependencies").
|
||||
Where(Function(d) d("relationType").ToObject(Of Integer) = 3 AndAlso '种类为依赖
|
||||
d("modId").ToObject(Of Integer) <> 306612 AndAlso d("modId").ToObject(Of Integer) <> 634179). '排除 Fabric API 和 Quilt API
|
||||
@@ -1292,7 +1411,7 @@ Retry:
|
||||
GameVersions = RawVersions.Where(Function(v) v.StartsWithF("1.")).Select(Function(v) v.Replace("-snapshot", " 预览版")).ToList
|
||||
If GameVersions.Count > 1 Then
|
||||
GameVersions = GameVersions.Sort(AddressOf VersionSortBoolean).ToList
|
||||
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)}
|
||||
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)} '整合包理应只 “支持” 一个版本
|
||||
ElseIf GameVersions.Count = 1 Then
|
||||
GameVersions = GameVersions.ToList
|
||||
Else
|
||||
@@ -1319,8 +1438,27 @@ Retry:
|
||||
DownloadUrls = New List(Of String) From {File("url"), DlSourceModGet(File("url"))}.Distinct.ToList '同时添加了镜像源
|
||||
Hash = File("hashes")("sha1")
|
||||
End If
|
||||
'ModLoaders
|
||||
'结果可能混杂着 Mod、数据包和服务端插件
|
||||
Dim RawLoaders As List(Of String) = Data("loaders").Select(Function(v) v.ToString).ToList
|
||||
ModLoaders = New List(Of CompModLoaderType)
|
||||
If Type = CompType.Mod Then '以尽量宽容的方式检测加载器，以免同时兼容两种的项被删除
|
||||
If RawLoaders.Intersect({"bukkit", "folia", "paper", "purpur", "spigot"}).Any() Then Type = CompType.Plugin 'Veinminer Enchantment 同时支持服务端与 Fabric
|
||||
If RawLoaders.Contains("datapack") Then Type = CompType.DataPack
|
||||
If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt) : Type = CompType.Mod
|
||||
ElseIf Type = CompType.DataPack Then
|
||||
If RawLoaders.Intersect({"bukkit", "folia", "paper", "purpur", "spigot"}).Any() Then Type = CompType.Plugin
|
||||
If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt) : Type = CompType.Mod
|
||||
If RawLoaders.Contains("datapack") Then Type = CompType.DataPack
|
||||
End If
|
||||
'Dependencies
|
||||
If Type = CompType.Mod Then
|
||||
If Data.ContainsKey("dependencies") Then
|
||||
RawDependencies = Data("dependencies").
|
||||
Where(Function(d) d("dependency_type") = "required" AndAlso '种类为依赖
|
||||
d("project_id") <> "P7dR8mSH" AndAlso d("project_id") <> "qvIfYCYJ" AndAlso '排除 Fabric API 和 Quilt API
|
||||
@@ -1333,7 +1471,7 @@ Retry:
|
||||
Select(Function(v) If(v.Contains("-"), v.BeforeFirst("-") & " 预览版", If(v.StartsWithF("b1."), "远古版本", v))).ToList
|
||||
If GameVersions.Count > 1 Then
|
||||
GameVersions = GameVersions.Sort(AddressOf VersionSortBoolean).ToList
|
||||
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)}
|
||||
If Type = CompType.ModPack Then GameVersions = New List(Of String) From {GameVersions(0)} '整合包理应只 “支持” 一个版本
|
||||
ElseIf GameVersions.Count = 1 Then
|
||||
'无需处理
|
||||
ElseIf RawVersions.Any(Function(v) RegexCheck(v, "[0-9]{2}w[0-9]{2}[a-z]{1}")) Then
|
||||
@@ -1341,13 +1479,6 @@ Retry:
|
||||
Else
|
||||
GameVersions = New List(Of String) From {"未知版本"}
|
||||
End If
|
||||
'ModLoaders
|
||||
Dim RawLoaders As List(Of String) = Data("loaders").Select(Function(v) v.ToString).ToList
|
||||
ModLoaders = New List(Of CompModLoaderType)
|
||||
If RawLoaders.Contains("forge") Then ModLoaders.Add(CompModLoaderType.Forge)
|
||||
If RawLoaders.Contains("neoforge") Then ModLoaders.Add(CompModLoaderType.NeoForge)
|
||||
If RawLoaders.Contains("fabric") Then ModLoaders.Add(CompModLoaderType.Fabric)
|
||||
If RawLoaders.Contains("quilt") Then ModLoaders.Add(CompModLoaderType.Quilt)
|
||||
#End Region
|
||||
End If
|
||||
End If
|
||||
@@ -1358,9 +1489,10 @@ Retry:
|
||||
''' </summary>
|
||||
Public Shared Function HandleCurseForgeDownloadUrls(Url As String) As List(Of String)
|
||||
Return {
|
||||
Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge", "://media"),
|
||||
Url.Replace("-service.overwolf.wtf", ".forgecdn.net").Replace("://edge.", "://mediafilez.").Replace("://media.", "://mediafilez."),
|
||||
Url.Replace("://edge.", "://mediafilez.").Replace("://media.", "://mediafilez."),
|
||||
Url.Replace("-service.overwolf.wtf", ".forgecdn.net"),
|
||||
Url.Replace("://edge", "://media"),
|
||||
Url.Replace("://media.", "://edge."),
|
||||
Url
|
||||
}.Distinct.ToList
|
||||
End Function
|
||||
@@ -1395,12 +1527,8 @@ Retry:
|
||||
Dim Title As String = If(BadDisplayName, FileName, DisplayName)
|
||||
Dim Info As New List(Of String)
|
||||
If Title <> FileName.BeforeLast(".") Then Info.Add(FileName.BeforeLast("."))
|
||||
Select Case Type
|
||||
Case CompType.Mod
|
||||
If Dependencies.Any Then Info.Add(Dependencies.Count & " 个前置 Mod")
|
||||
Case CompType.ModPack
|
||||
If GameVersions.All(Function(v) v.Contains("w")) Then Info.Add($"游戏版本 {Join(GameVersions, "、")}")
|
||||
End Select
|
||||
If Dependencies.Any Then Info.Add(Dependencies.Count & " 项前置")
|
||||
If GameVersions.All(Function(v) Not IsVersionNameLikeRelease(v)) Then Info.Add($"游戏版本 {Join(GameVersions, "、")}")
|
||||
If DownloadCount > 0 Then 'CurseForge 的下载次数经常错误地返回 0
|
||||
Info.Add("下载 " & If(DownloadCount > 100000, Math.Round(DownloadCount / 10000) & " 万次", DownloadCount & " 次"))
|
||||
End If
|
||||
@@ -1461,50 +1589,63 @@ Retry:
|
||||
If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存
|
||||
TargetProject = CompProjectCache(ProjectId)
|
||||
ElseIf FromCurseForge Then 'CurseForge
|
||||
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId, IsJson:=True)("data"))
|
||||
TargetProject = New CompProject(DlModRequest("https://api.curseforge.com/v1/mods/" & ProjectId)("data"))
|
||||
Else 'Modrinth
|
||||
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId, IsJson:=True))
|
||||
TargetProject = New CompProject(DlModRequest("https://api.modrinth.com/v2/project/" & ProjectId))
|
||||
End If
|
||||
'获取工程对象的文件列表
|
||||
If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回，这时候前置 Mod 可能没获取（#5173）
|
||||
If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回，这时候前置可能没获取（#5173）
|
||||
Log("[Comp] 开始获取文件列表：" & ProjectId)
|
||||
Dim ResultJsonArray As JArray
|
||||
Dim ResultJsonArray As JArray = Nothing
|
||||
If FromCurseForge Then
|
||||
'CurseForge
|
||||
'HMCL 一次性请求了 10000 个文件，虽然不知道会不会出问题但先这样吧……（#5522）
|
||||
ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=10000", IsJson:=True)("data")
|
||||
'之前只请求一部分文件的方法备份如下：
|
||||
'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
|
||||
' ResultJsonArray = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data")
|
||||
'Else '否则使用全部文件
|
||||
' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data")
|
||||
'End If
|
||||
For RetryCount As Integer = 0 To 2
|
||||
Dim ResultJson As JObject = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=" &
|
||||
(10000 + RetryCount)) '每次重试多请求一个文件，以避免触发 CDN 缓存
|
||||
'HMCL 一次性请求了 10000 个文件，虽然不知道会不会出问题但先这样吧……（#5522）
|
||||
'之前只请求一部分文件的方法备份如下：
|
||||
'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
|
||||
' ResultJsonArray = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json")("data")
|
||||
'Else '否则使用全部文件
|
||||
' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999")("data")
|
||||
'End If
|
||||
If ResultJson("pagination")("resultCount").ToObject(Of Integer) = ResultJson("pagination")("totalCount").ToObject(Of Integer) Then
|
||||
ResultJsonArray = ResultJson("data")
|
||||
Exit For
|
||||
ElseIf RetryCount < 2 Then
|
||||
Log($"[Comp] CurseForge 返回的文件列表存在缺失，即将进行第 {RetryCount + 1} 次重试", LogLevel.Debug) '#6224
|
||||
Log($"[Comp] 返回的原始内容如下：{vbCrLf}{ResultJson}")
|
||||
Else
|
||||
Log($"[Comp] CurseForge 返回的文件列表存在缺失，返回的原始内容如下：{vbCrLf}{ResultJson}")
|
||||
Throw New Exception("CurseForge 返回的文件列表存在缺失")
|
||||
End If
|
||||
Next
|
||||
Else
|
||||
'Modrinth
|
||||
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version", IsJson:=True)
|
||||
ResultJsonArray = DlModRequest($"https://api.modrinth.com/v2/project/{ProjectId}/version")
|
||||
End If
|
||||
CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)).
|
||||
Where(Function(a) a.Available).ToList.Distinct(Function(a, b) a.Id = b.Id) 'CurseForge 可能会重复返回相同项（#1330）
|
||||
Where(Function(a) a.Available).ToList.
|
||||
Distinct(Function(a, b) a.Id = b.Id) 'CurseForge 可能会重复返回相同项（#1330）
|
||||
End If
|
||||
'获取前置 Mod 列表
|
||||
If TargetProject.Type <> CompType.Mod Then Return CompFilesCache(ProjectId)
|
||||
'获取前置列表
|
||||
Dim Deps As List(Of String) = CompFilesCache(ProjectId).SelectMany(Function(f) f.RawDependencies).Distinct().ToList
|
||||
Dim UndoneDeps = Deps.Where(Function(f) Not CompProjectCache.ContainsKey(f)).ToList
|
||||
'获取前置 Mod 工程信息
|
||||
'获取前置工程信息
|
||||
If UndoneDeps.Any Then
|
||||
Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置 Mod：{Join(UndoneDeps, "，")}")
|
||||
Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置：{Join(UndoneDeps, "，")}")
|
||||
Dim Projects As JArray
|
||||
If TargetProject.FromCurseForge Then
|
||||
Projects = GetJson(DlModRequest("https://api.curseforge.com/v1/mods",
|
||||
"POST", "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json"))("data")
|
||||
Projects = DlModRequest("https://api.curseforge.com/v1/mods",
|
||||
HttpMethod.Post, "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json")("data")
|
||||
Else
|
||||
Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]", IsJson:=True)
|
||||
Projects = DlModRequest($"https://api.modrinth.com/v2/projects?ids=[""{Join(UndoneDeps, """,""")}""]")
|
||||
End If
|
||||
For Each Project In Projects
|
||||
Dim NewProject As New CompProject(Project) '在 New 的时候就添加了缓存
|
||||
Dim Unused As New CompProject(Project) '在 New 的时候会添加缓存以便之后读取
|
||||
Next
|
||||
End If
|
||||
'更新前置 Mod 信息
|
||||
'更新前置信息
|
||||
If Deps.Any Then
|
||||
For Each DepProject In Deps.Where(Function(id) CompProjectCache.ContainsKey(id)).Select(Function(id) CompProjectCache(id))
|
||||
For Each File In CompFilesCache(ProjectId)
|
||||
@@ -1518,28 +1659,28 @@ Retry:
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 预载包含大量 CompFile 的卡片，添加必要的元素和前置 Mod 列表。
|
||||
''' 预载包含大量 CompFile 的卡片，添加必要的元素和前置列表。
|
||||
''' </summary>
|
||||
Public Sub CompFilesCardPreload(Stack As StackPanel, Files As List(Of CompFile))
|
||||
'获取卡片对应的前置 ID
|
||||
'如果为整合包就不会有 Dependencies 信息，所以不用管
|
||||
Dim Deps As List(Of String) = Files.SelectMany(Function(f) f.Dependencies).Distinct.ToList()
|
||||
Deps.Sort()
|
||||
If Not Deps.Any() Then Exit Sub
|
||||
If Not Deps.Any() Then Return
|
||||
Deps = Deps.Where(
|
||||
Function(dep)
|
||||
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置 Mod 信息", LogLevel.Debug)
|
||||
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置信息", LogLevel.Debug)
|
||||
Return CompProjectCache.ContainsKey(dep)
|
||||
End Function).ToList
|
||||
'添加开头间隔
|
||||
Stack.Children.Add(New TextBlock With {.Text = "前置 Mod", .FontSize = 14, .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 2, 0, 5)})
|
||||
'添加前置 Mod 列表
|
||||
Stack.Children.Add(New TextBlock With {.Text = "前置资源", .FontSize = 14, .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 2, 0, 5)})
|
||||
'添加前置列表
|
||||
For Each Dep In Deps
|
||||
Dim Item = CompProjectCache(Dep).ToCompItem(False, False)
|
||||
Stack.Children.Add(Item)
|
||||
Next
|
||||
'添加结尾间隔
|
||||
Stack.Children.Add(New TextBlock With {.Text = "可选版本", .FontSize = 14, .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 12, 0, 5)})
|
||||
Stack.Children.Add(New TextBlock With {.Text = "版本列表", .FontSize = 14, .HorizontalAlignment = HorizontalAlignment.Left, .Margin = New Thickness(6, 12, 0, 5)})
|
||||
End Sub
|
||||
|
||||
#End Region
|
||||
|
||||
@@ -2,7 +2,9 @@
|
||||
|
||||
'构造函数
|
||||
Private TempFolder As String
|
||||
Public Sub New(UUID As Integer)
|
||||
Private TargetVersion As McVersion
|
||||
Public Sub New(Optional TargetVersion As McVersion = Nothing)
|
||||
Me.TargetVersion = TargetVersion
|
||||
'构建文件结构
|
||||
TempFolder = RequestTaskTempFolder()
|
||||
Directory.CreateDirectory(TempFolder & "Temp\")
|
||||
@@ -71,11 +73,7 @@
|
||||
'将可能可用的日志文件导出
|
||||
For Each FilePath In RightLogs
|
||||
Try
|
||||
If FilePath.Contains("crash-") Then
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Split(vbCrLf.ToCharArray)))
|
||||
Else
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath, Encoding.UTF8).Split(vbCrLf.ToCharArray)))
|
||||
End If
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Split(vbCrLf.ToCharArray)))
|
||||
Catch ex As Exception
|
||||
Log(ex, "读取可能的崩溃日志文件失败（" & FilePath & "）")
|
||||
End Try
|
||||
@@ -117,11 +115,7 @@ Extracted:
|
||||
If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For
|
||||
Dim Ext As String = TargetFile.Extension.ToLower
|
||||
If Ext = ".log" OrElse Ext = ".txt" Then
|
||||
If TargetFile.Name.StartsWithF("crash-") Then
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray)))
|
||||
Else
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName, Encoding.UTF8).Split(vbCrLf.ToCharArray)))
|
||||
End If
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Split(vbCrLf.ToCharArray)))
|
||||
Else
|
||||
File.Delete(TargetFile.FullName)
|
||||
End If
|
||||
@@ -137,20 +131,21 @@ Extracted:
|
||||
Private Enum AnalyzeFileType
|
||||
HsErr
|
||||
MinecraftLog
|
||||
ExtraLog
|
||||
ExtraLogFile
|
||||
ExtraReportFile
|
||||
CrashReport
|
||||
End Enum
|
||||
Private DirectFile As KeyValuePair(Of String, String())? = Nothing '在弹窗中选择直接打开的文件
|
||||
''' <summary>
|
||||
''' 从 AnalyzeRawFiles 中提取实际有用的文本片段存储到 AnalyzeFiles，并整理可用于生成报告的文件。
|
||||
''' 返回找到的用于分析的项目数。
|
||||
''' 返回是否有足够信息可用于分析。
|
||||
''' </summary>
|
||||
Public Function Prepare() As Integer
|
||||
Public Function Prepare() As Boolean
|
||||
Log("[Crash] 步骤 2：准备日志文本")
|
||||
|
||||
'对日志文件进行分类
|
||||
DirectFile = Nothing
|
||||
Dim TotalFiles As New List(Of KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String())))
|
||||
Dim AllFiles As New List(Of KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String())))
|
||||
For Each LogFile In AnalyzeRawFiles
|
||||
Dim MatchName As String = GetFileNameFromPath(LogFile.Key).ToLower
|
||||
Dim TargetType As AnalyzeFileType
|
||||
@@ -170,27 +165,35 @@ Extracted:
|
||||
TargetType = AnalyzeFileType.MinecraftLog
|
||||
If DirectFile Is Nothing Then DirectFile = LogFile
|
||||
Else
|
||||
TargetType = AnalyzeFileType.ExtraLog
|
||||
TargetType = AnalyzeFileType.ExtraLogFile
|
||||
End If
|
||||
ElseIf MatchName.EndsWithF(".log", True) OrElse MatchName.EndsWithF(".txt", True) Then
|
||||
TargetType = AnalyzeFileType.ExtraLog
|
||||
ElseIf MatchName.EndsWithF(".log", True) Then
|
||||
TargetType = AnalyzeFileType.ExtraLogFile
|
||||
ElseIf MatchName.EndsWithF(".txt", True) Then
|
||||
TargetType = AnalyzeFileType.ExtraReportFile
|
||||
Else
|
||||
Log("[Crash] " & MatchName & " 分类为 Ignore")
|
||||
Continue For
|
||||
End If
|
||||
If Not LogFile.Value.Any() Then
|
||||
Log("[Crash] " & MatchName & " 由于内容为空跳过")
|
||||
Else
|
||||
TotalFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
|
||||
If LogFile.Value.Any Then
|
||||
AllFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
|
||||
Log("[Crash] " & MatchName & " 分类为 " & GetStringFromEnum(TargetType))
|
||||
Else
|
||||
Log("[Crash] " & MatchName & " 由于内容为空跳过")
|
||||
End If
|
||||
Next
|
||||
|
||||
'若只有额外日志，则将它们视作 Minecraft 日志
|
||||
If AllFiles.Any() AndAlso AllFiles.All(Function(p) p.Key = AnalyzeFileType.ExtraLogFile) Then
|
||||
Log("[Crash] 由于仅发现了额外日志，将它们视作 Minecraft 日志进行分析")
|
||||
AllFiles = AllFiles.Select(Function(p) New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(AnalyzeFileType.MinecraftLog, p.Value)).ToList
|
||||
End If
|
||||
|
||||
'将分类后的文件分别写入
|
||||
For Each SelectType In {AnalyzeFileType.MinecraftLog, AnalyzeFileType.HsErr, AnalyzeFileType.ExtraLog, AnalyzeFileType.CrashReport}
|
||||
For Each SelectType In {AnalyzeFileType.MinecraftLog, AnalyzeFileType.HsErr, AnalyzeFileType.ExtraLogFile, AnalyzeFileType.CrashReport}
|
||||
'获取该种类的所有文件 {文件路径 -> 文件内容行}
|
||||
Dim SelectedFiles As New List(Of KeyValuePair(Of String, String()))
|
||||
For Each File In TotalFiles
|
||||
For Each File In AllFiles
|
||||
If SelectType = File.Key Then SelectedFiles.Add(File.Value)
|
||||
Next
|
||||
If Not SelectedFiles.Any() Then Continue For
|
||||
@@ -232,54 +235,59 @@ Extracted:
|
||||
Next
|
||||
'选择一份最佳的来自启动器的游戏日志
|
||||
For Each FileName As String In {"rawoutput.log", "启动器日志.txt", "log1.txt", "游戏崩溃前的输出.txt", "PCL2 启动器日志.txt", "PCL 启动器日志.txt"}
|
||||
If FileNameDict.ContainsKey(FileName) Then
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
'截取 “以下为游戏输出的最后一段内容” 后的内容
|
||||
Dim HasLauncherMark As Boolean = False
|
||||
For Each Line In CurrentLog.Value
|
||||
If HasLauncherMark Then
|
||||
LogMc += Line & vbLf
|
||||
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
|
||||
HasLauncherMark = True
|
||||
Log("[Crash] 找到 PCL 输出的游戏实时日志头")
|
||||
End If
|
||||
Next
|
||||
'导入后 500 行
|
||||
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
|
||||
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为启动器日志")
|
||||
Exit For
|
||||
End If
|
||||
If Not FileNameDict.ContainsKey(FileName) Then Continue For
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
'截取 “以下为游戏输出的最后一段内容” 后的内容
|
||||
Dim HasLauncherMark As Boolean = False
|
||||
For Each Line In CurrentLog.Value
|
||||
If HasLauncherMark Then
|
||||
LogMc += Line & vbLf
|
||||
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
|
||||
HasLauncherMark = True
|
||||
Log("[Crash] 找到 PCL 输出的游戏实时日志头")
|
||||
End If
|
||||
Next
|
||||
'导入后 500 行
|
||||
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
|
||||
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为启动器日志")
|
||||
Exit For
|
||||
Next
|
||||
'选择一份最佳的 Minecraft Log
|
||||
For Each FileName As String In {"latest.log", "latest log.txt", "debug.log", "debug log.txt"}
|
||||
If FileNameDict.ContainsKey(FileName) Then
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
LogMc += GetHeadTailLines(CurrentLog.Value, 250, 500)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft 日志")
|
||||
Exit For
|
||||
End If
|
||||
If Not FileNameDict.ContainsKey(FileName) Then Continue For
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft 日志")
|
||||
Exit For
|
||||
Next
|
||||
'查找 Debug Log
|
||||
For Each FileName As String In {"debug.log", "debug log.txt"}
|
||||
If FileNameDict.ContainsKey(FileName) Then
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft Debug 日志")
|
||||
Exit For
|
||||
End If
|
||||
If Not FileNameDict.ContainsKey(FileName) Then Continue For
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft Debug 日志")
|
||||
Exit For
|
||||
Next
|
||||
'检查错误
|
||||
'兜底
|
||||
If LogMc = "" Then
|
||||
LogMc = Nothing
|
||||
Throw New Exception("无法找到匹配的 Minecraft Log")
|
||||
If LogMcDebug <> "" Then '如果没有找到 Minecraft 日志，则使用 Debug 日志作为兜底
|
||||
LogMc = LogMcDebug
|
||||
ElseIf FileNameDict.Any() Then '如果都没有找到，则使用第一个文件
|
||||
Dim CurrentLog = FileNameDict.First.Value
|
||||
LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为兜底日志")
|
||||
Else
|
||||
LogMc = Nothing
|
||||
Throw New Exception("无法找到匹配的 Minecraft Log")
|
||||
End If
|
||||
End If
|
||||
If LogMcDebug = "" Then LogMcDebug = Nothing
|
||||
Case AnalyzeFileType.ExtraLog
|
||||
Case AnalyzeFileType.ExtraLogFile, AnalyzeFileType.ExtraReportFile
|
||||
'全部丢过去
|
||||
For Each SelectedFile In SelectedFiles
|
||||
OutputFiles.Add(SelectedFile.Key)
|
||||
Log("[Crash] 输出报告：" & SelectedFile.Key & "，作为额外日志")
|
||||
Log("[Crash] 输出报告：" & SelectedFile.Key & "，不用作分析")
|
||||
Next
|
||||
End Select
|
||||
Catch ex As Exception
|
||||
@@ -287,15 +295,13 @@ Extracted:
|
||||
End Try
|
||||
Next
|
||||
|
||||
'获取种类数
|
||||
Dim ResultCount As Integer = If(LogMc Is Nothing, 0, 1) + If(LogHs Is Nothing, 0, 1) + If(LogCrash Is Nothing, 0, 1)
|
||||
If ResultCount = 0 Then
|
||||
Log("[Crash] 步骤 2：准备日志文本完成，没有任何可供分析的日志")
|
||||
Else
|
||||
'结束
|
||||
Prepare = LogMc IsNot Nothing OrElse LogHs IsNot Nothing OrElse LogCrash IsNot Nothing
|
||||
If Prepare Then
|
||||
Log(("[Crash] 步骤 2：准备日志文本完成，找到" & If(LogMc Is Nothing, "", "游戏日志、") & If(LogMcDebug Is Nothing, "", "游戏 Debug 日志、") & If(LogHs Is Nothing, "", "虚拟机日志、") & If(LogCrash Is Nothing, "", "崩溃日志、")).TrimEnd("、") & "用作分析")
|
||||
Else
|
||||
Log("[Crash] 步骤 2：准备日志文本完成，没有任何可供分析的日志")
|
||||
End If
|
||||
Return ResultCount
|
||||
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 输出字符串的前后某些行，并统一行尾为 vbLf (正则 \n)、删除空行和重复行。
|
||||
@@ -335,6 +341,7 @@ Extracted:
|
||||
''' 导致崩溃的原因枚举。
|
||||
''' </summary>
|
||||
Private Enum CrashReason
|
||||
Java虚拟机参数有误
|
||||
Mod文件被解压
|
||||
MixinBootstrap缺失
|
||||
内存不足
|
||||
@@ -386,7 +393,7 @@ Extracted:
|
||||
''' </summary>
|
||||
Public Sub Analyze(Optional Version As McVersion = Nothing)
|
||||
Log("[Crash] 步骤 3：分析崩溃原因")
|
||||
LogAll = (If(LogMc, "") & If(LogMcDebug, "") & If(LogHs, "") & If(LogCrash, ""))
|
||||
LogAll = If(LogMc, If(LogMcDebug, "")) & If(LogHs, "") & If(LogCrash, "")
|
||||
|
||||
'1. 精准日志匹配，中/高优先级
|
||||
AnalyzeCrit1()
|
||||
@@ -472,16 +479,18 @@ Done:
|
||||
'空白分析
|
||||
If LogMc Is Nothing AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing Then
|
||||
AppendReason(CrashReason.没有可用的分析文件)
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
|
||||
'崩溃报告分析，高优先级
|
||||
If LogCrash IsNot Nothing Then
|
||||
If LogCrash.Contains("Unable to make protected final java.lang.Class java.lang.ClassLoader.defineClass") Then AppendReason(CrashReason.Java版本过高)
|
||||
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)}) '#7071
|
||||
End If
|
||||
|
||||
'游戏日志分析
|
||||
If LogMc IsNot Nothing Then
|
||||
If LogMc.Contains("Unrecognized option:") Then AppendReason(CrashReason.Java虚拟机参数有误)
|
||||
If LogMc.Contains("Found multiple arguments for option fml.forgeVersion, but you asked for only one") Then AppendReason(CrashReason.版本Json中存在多个Forge)
|
||||
If LogMc.Contains("The driver does not appear to support OpenGL") Then AppendReason(CrashReason.显卡不支持OpenGL)
|
||||
If LogMc.Contains("java.lang.ClassCastException: java.base/jdk") Then AppendReason(CrashReason.使用JDK)
|
||||
@@ -504,13 +513,13 @@ Done:
|
||||
If LogMc.Contains("Couldn't set pixel format") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式)
|
||||
If LogMc.Contains("java.lang.OutOfMemoryError") OrElse LogMc.Contains("an out of memory error") Then AppendReason(CrashReason.内存不足)
|
||||
If LogMc.Contains("java.lang.RuntimeException: Shaders Mod detected. Please remove it, OptiFine has built-in support for shaders.") Then AppendReason(CrashReason.ShadersMod与OptiFine同时安装)
|
||||
If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容)
|
||||
If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") OrElse LogMc.Contains("java.lang.NoSuchMethodError: 'void sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容)
|
||||
If LogMc.Contains("1282: Invalid operation") Then AppendReason(CrashReason.光影或资源包导致OpenGL1282错误)
|
||||
If LogMc.Contains("signer information does not match signer information of other classes in the same package") Then AppendReason(CrashReason.文件或内容校验失败, If(RegexSeek(LogMc, "(?<=class "")[^']+(?=""'s signer information)"), "").TrimEnd(vbCrLf))
|
||||
If LogMc.Contains("Maybe try a lower resolution resourcepack?") Then AppendReason(CrashReason.材质过大或显卡配置不足)
|
||||
If LogMc.Contains("java.lang.NoSuchMethodError: net.minecraft.world.server.ChunkManager$ProxyTicketManager.shouldForceTicks(J)Z") AndAlso LogMc.Contains("OptiFine") Then AppendReason(CrashReason.OptiFine导致无法加载世界)
|
||||
If LogMc.Contains("Unsupported class file major version") Then AppendReason(CrashReason.Java版本不兼容)
|
||||
If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") Then AppendReason(CrashReason.NightConfig的Bug)
|
||||
If LogMc.Contains("com.electronwill.nightconfig.core.io.ParsingException: Not enough data available") AndAlso Not CrashReasons.ContainsKey(CrashReason.Mod配置文件导致游戏崩溃) Then AppendReason(CrashReason.NightConfig的Bug)
|
||||
If LogMc.Contains("Cannot find launch target fmlclient, unable to launch") Then AppendReason(CrashReason.Forge安装不完整)
|
||||
If LogMc.Contains("Invalid paths argument, contained no existing paths") AndAlso LogMc.Contains("libraries\net\minecraftforge\fmlcore") Then AppendReason(CrashReason.Forge安装不完整)
|
||||
If LogMc.Contains("Invalid module name: '' is not a Java identifier") Then AppendReason(CrashReason.Mod名称包含特殊字符)
|
||||
@@ -533,8 +542,8 @@ Done:
|
||||
If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
|
||||
If LogMc.Contains("Found duplicate mods") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=Mod ID: ')\w+?(?=' from mod files:)").Distinct.ToList)
|
||||
If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
|
||||
If LogMc.Contains("Incompatible mods found!") Then '#5006
|
||||
AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), ""))
|
||||
If LogMc.Contains("Incompatible mods found!") Then '#5006, #5115
|
||||
AppendReason(CrashReason.Mod互不兼容, If(RegexSeek(LogMc, "(?<=Incompatible mods found![\s\S]+: )[\s\S]+?(?=\tat )"), "").BeforeFirst("更多信息：").Replace("Some of your mods are incompatible with the game or each other!", "").Trim((vbCrLf & " ").ToCharArray))
|
||||
End If
|
||||
If LogMc.Contains("Missing or unsupported mandatory dependencies:") Then
|
||||
AppendReason(CrashReason.Mod缺少前置或MC版本错误,
|
||||
@@ -614,9 +623,9 @@ Done:
|
||||
Dim IsMixin As Boolean = MixinAnalyze(LogMc)
|
||||
'常规信息
|
||||
If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, RegexSeek(LogMc, "(?<=the game will display an error screen and halt.[\n\r]+[^\n]+?Exception: )[\s\S]+?(?=\n\tat)")?.Trim(vbCrLf))
|
||||
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
|
||||
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
|
||||
If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\n]+"), vbLf))
|
||||
If LogMc.Contains("A potential solution has been determined:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
|
||||
If LogMc.Contains("A potential solution has been determined, this may resolve your problem:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=A potential solution has been determined, this may resolve your problem:\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
|
||||
If LogMc.Contains("确定了一种可能的解决方法，这样做可能会解决你的问题：") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法，这样做可能会解决你的问题：\n)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
|
||||
If Not IsMixin AndAlso LogMc.Contains("due to errors, provided by ") Then '在 #3104 的情况下，这一句导致 OptiFabric 的 Mixin 失败错判为 Fabric Loader 加载失败
|
||||
AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
|
||||
End If
|
||||
@@ -650,7 +659,7 @@ Done:
|
||||
End If
|
||||
'Mod 解析错误（常见于 Fabric 前置校验失败）
|
||||
If LogMc.Contains("Mod resolution failed") Then AppendReason(CrashReason.Mod加载器报错)
|
||||
'Mixin 失败可以导致大量 Mod 实例创建失败
|
||||
'Mixin 失败可以导致大量 Mod 实例创建失败，因此需要放到低优先级中
|
||||
If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf)))
|
||||
'注意：Fabric 的 Warnings were found! 不一定是崩溃原因，它可能是单纯的警报
|
||||
End If
|
||||
@@ -704,11 +713,12 @@ NextStack:
|
||||
If Word.Length <= 2 OrElse Word.StartsWithF("func_") Then Continue For
|
||||
If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api", "dsi", "top", "mcp",
|
||||
"core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base", "oshi", "impl", "data", "pool", "task",
|
||||
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world",
|
||||
"forge", "setup", "block", "model", "mixin", "event", "unimi", "netty", "world", "lwjgl",
|
||||
"gitlab", "common", "server", "config", "mixins", "compat", "loader", "launch", "entity", "assist", "client", "plugin", "modapi", "mojang", "shader", "events", "github", "recipe", "render", "packet", "events",
|
||||
"preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service",
|
||||
"fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge",
|
||||
"injection", "listeners", "scheduler", "minecraft", "transformer", "transformers", "neoforged", "universal", "multipart", "minecraftforge", "blockentity", "spongepowered", "electronwill"
|
||||
"injection", "listeners", "scheduler", "minecraft", "universal", "multipart", "neoforged", "microsoft",
|
||||
"transformer", "transformers", "minecraftforge", "blockentity", "spongepowered", "electronwill", "concurrent"
|
||||
}.Contains(Word.ToLower) Then Continue For
|
||||
PossibleWords.Add(Word.Trim)
|
||||
Next
|
||||
@@ -851,20 +861,21 @@ NextStack:
|
||||
''' <summary>
|
||||
''' 弹出崩溃弹窗，并指导导出崩溃报告。
|
||||
''' </summary>
|
||||
Public Sub Output(IsHandAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing)
|
||||
Public Sub Output(IsManualAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing)
|
||||
'弹窗提示
|
||||
FrmMain.ShowWindowToTop()
|
||||
Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
|
||||
"确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"),
|
||||
Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing,
|
||||
Dim Detail As String = GetAnalyzeResult(IsManualAnalyze)
|
||||
Select Case MyMsgBox(Detail, If(IsManualAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
|
||||
"确定", If(IsManualAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsManualAnalyze, "", "导出错误报告"),
|
||||
Button2Action:=If(IsManualAnalyze OrElse DirectFile Is Nothing, Nothing,
|
||||
Sub()
|
||||
'弹窗选择：查看日志
|
||||
If File.Exists(DirectFile.Value.Key) Then
|
||||
ShellOnly(DirectFile.Value.Key)
|
||||
StartProcess(DirectFile.Value.Key)
|
||||
Else
|
||||
Dim FilePath As String = PathTemp & "Crash.txt"
|
||||
WriteFile(FilePath, Join(DirectFile.Value.Value, vbCrLf))
|
||||
ShellOnly(FilePath)
|
||||
StartProcess(FilePath)
|
||||
End If
|
||||
End Sub))
|
||||
Case 3
|
||||
@@ -873,7 +884,7 @@ NextStack:
|
||||
Try
|
||||
'获取文件路径
|
||||
RunInUiWait(Sub() FileAddress = SelectSaveFile("选择保存位置", "错误报告-" & Date.Now.ToString("G").Replace("/", "-").Replace(":", ".").Replace(" ", "_") & ".zip", "Minecraft 错误报告(*.zip)|*.zip"))
|
||||
If String.IsNullOrEmpty(FileAddress) Then Exit Sub
|
||||
If String.IsNullOrEmpty(FileAddress) Then Return
|
||||
Directory.CreateDirectory(GetPathFromFullPath(FileAddress))
|
||||
If File.Exists(FileAddress) Then File.Delete(FileAddress)
|
||||
'输出诊断信息
|
||||
@@ -896,9 +907,10 @@ NextStack:
|
||||
End Select
|
||||
If File.Exists(OutputFile) Then
|
||||
If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile))
|
||||
WriteFile(TempFolder & "Report\" & FileName,
|
||||
SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")),
|
||||
Encoding:=FileEncoding)
|
||||
Dim FileContent As String = ReadFile(OutputFile, FileEncoding)
|
||||
FileContent = FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*"))
|
||||
FileContent = FilterUserName(FileContent, "*")
|
||||
WriteFile(TempFolder & "Report\" & FileName, FileContent, Encoding:=FileEncoding)
|
||||
Log($"[Crash] 导出文件：{FileName}，编码：{FileEncoding.HeaderName}")
|
||||
End If
|
||||
Next
|
||||
@@ -908,10 +920,15 @@ NextStack:
|
||||
Hint("错误报告已导出！", HintType.Finish)
|
||||
Catch ex As Exception
|
||||
Log(ex, "导出错误报告失败", LogLevel.Feedback)
|
||||
Exit Sub
|
||||
Return
|
||||
End Try
|
||||
OpenExplorer(FileAddress)
|
||||
End Select
|
||||
'上报
|
||||
If IsManualAnalyze Then Return
|
||||
Telemetry("Minecraft 崩溃",
|
||||
"Version", If(TargetVersion Is Nothing, "null", TargetVersion.Version.ToString),
|
||||
"Detail", FilterUserName(Detail, "*"))
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 获取崩溃分析的结果描述。
|
||||
@@ -932,12 +949,14 @@ NextStack:
|
||||
For Each Reason In CrashReasons
|
||||
Dim Additional As List(Of String) = Reason.Value
|
||||
Select Case Reason.Key
|
||||
Case CrashReason.Java虚拟机参数有误
|
||||
Results.Add("由于 Java 参数有误，导致游戏无法继续运行。\n请检查高级选项中的 Java 虚拟机参数和游戏参数设置是否有误。")
|
||||
Case CrashReason.Mod文件被解压
|
||||
Results.Add("由于 Mod 文件被解压了，导致游戏无法继续运行。\n直接把整个 Mod 文件放进 Mod 文件夹中即可，若解压就会导致游戏出错。\n\n请删除 Mod 文件夹中已被解压的 Mod，然后再启动游戏。")
|
||||
Case CrashReason.内存不足
|
||||
Results.Add("Minecraft 内存不足，导致其无法继续运行。\n这很可能是因为电脑内存不足、游戏分配的内存不足，或是配置要求过高。\n\n你可以尝试在 更多 → 百宝箱 中选择 内存优化，然后再启动游戏。\n如果还是不行，请在启动设置中增加为游戏分配的内存，并删除配置要求较高的材质、Mod、光影。\n如果依然不奏效，请在开始游戏前尽量关闭其他软件，或者……换台电脑？\h")
|
||||
Case CrashReason.使用OpenJ9
|
||||
Results.Add("游戏因为使用 Open J9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java，然后再启动游戏。")
|
||||
Results.Add("游戏因为使用 OpenJ9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java，然后再启动游戏。")
|
||||
Case CrashReason.使用JDK
|
||||
Results.Add("游戏似乎因为使用 JDK，或 Java 版本过高而崩溃了。\n请在启动设置的 Java 选择一项中改用 JRE 8（Java 8），然后再启动游戏。\n如果你没有安装 JRE 8，你可以从网络中下载、安装一个。")
|
||||
Case CrashReason.Java版本过高
|
||||
@@ -1012,14 +1031,22 @@ NextStack:
|
||||
End If
|
||||
Case CrashReason.特定实体导致崩溃
|
||||
If Additional.Count = 1 Then
|
||||
Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并生成一个该实体，然后观察游戏的运行情况：\n - 若正常运行，则是该实体导致出错，你或许需要使用一些方式删除此实体。\n - 若仍然出错，问题就可能来自其他原因……\h")
|
||||
If Additional.First.Contains("minecraft:player") Then
|
||||
If Additional.First.Contains(" ") Then
|
||||
Results.Add($"游戏因为位于 {Additional.First.AfterFirst(" ")} 的玩家实体导致了崩溃。\h")
|
||||
Else
|
||||
Results.Add($"游戏因为玩家实体导致了崩溃。\h")
|
||||
End If
|
||||
Else
|
||||
Results.Add($"游戏因为实体 {Additional.First} 导致了崩溃。\h")
|
||||
End If
|
||||
Else
|
||||
Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界，并生成各种实体，观察游戏的运行情况：\n - 若正常运行，则是某些实体导致出错，你或许需要删除该世界。\n - 若仍然出错，问题就可能来自其他原因……\h")
|
||||
Results.Add($"游戏因为下列实体导致了崩溃：{Additional.Join("、")}\h")
|
||||
End If
|
||||
Case CrashReason.OptiFine与Forge不兼容
|
||||
Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容，导致了游戏崩溃。\n\n请前往 OptiFine 官网（https://optifine.net/downloads）查看 OptiFine 所兼容的 Forge 版本，并严格按照对应版本重新安装游戏。")
|
||||
Case CrashReason.ShadersMod与OptiFine同时安装
|
||||
Results.Add("无需同时安装 Optifine 和 Shaders Mod，OptiFine 已经集成了 Shaders Mod 的功能。\n在删除 Shaders Mod 后，游戏即可正常运行。")
|
||||
Results.Add("无需同时安装 OptiFine 和 Shaders Mod，OptiFine 已经集成了 Shaders Mod 的功能。\n在删除 Shaders Mod 后，游戏即可正常运行。")
|
||||
Case CrashReason.低版本Forge与高版本Java不兼容
|
||||
Results.Add("由于低版本 Forge 与当前 Java 不兼容，导致了游戏崩溃。\n\n请尝试以下解决方案：\n - 更新 Forge 到 36.2.26 或更高版本\n - 换用版本低于 1.8.0.320 的 Java")
|
||||
Case CrashReason.版本Json中存在多个Forge
|
||||
@@ -1096,7 +1123,7 @@ NextStack:
|
||||
If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "",
|
||||
vbCrLf & "如果要寻求帮助，请把错误报告文件发给对方，而不是发送这个窗口的照片或者截图。" &
|
||||
If(If(PageSetupSystem.IsLauncherNewest(), True), "",
|
||||
vbCrLf & vbCrLf & "此外，你正在使用老版本 PCL，更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。"))
|
||||
vbCrLf & vbCrLf & "此外，你正在使用老版本 PCL，更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 [设置 → 其他 → 启动器 → 检查更新] 更新 PCL。"))
|
||||
End Function
|
||||
|
||||
End Class
|
||||
|
||||
@@ -197,10 +197,17 @@
|
||||
Public DlClientListMojangLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Mojang", AddressOf DlClientListMojangMain)
|
||||
Private IsNewClientVersionHinted As Boolean = False
|
||||
Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult))
|
||||
Dim Json As JObject = NetGetCodeByRequestRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", IsJson:=True)
|
||||
Dim StartTime As Long = GetTimeTick()
|
||||
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", RequireJson:=True))
|
||||
Try
|
||||
Dim Versions As JArray = Json("versions")
|
||||
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）")
|
||||
'确定官方源是否可用
|
||||
If Not DlPreferMojang Then
|
||||
Dim DeltaTime = GetTimeTick() - StartTime
|
||||
DlPreferMojang = DeltaTime < 4000
|
||||
Log($"[Download] Mojang 官方源加载耗时：{DeltaTime}ms，{If(DlPreferMojang, "可优先使用官方源", "不优先使用官方源")}")
|
||||
End If
|
||||
'添加 PCL 特供项
|
||||
If File.Exists(PathTemp & "Cache\download.json") Then Versions.Merge(GetJson(ReadFile(PathTemp & "Cache\download.json")))
|
||||
'返回
|
||||
@@ -228,7 +235,7 @@
|
||||
''' </summary>
|
||||
Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
|
||||
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult))
|
||||
Dim Json As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", IsJson:=True)
|
||||
Dim Json As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/mc/game/version_manifest.json", RequireJson:=True))
|
||||
Try
|
||||
Dim Versions As JArray = Json("versions")
|
||||
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Json.ToString & "）")
|
||||
@@ -237,7 +244,7 @@
|
||||
'检查是否有要求的版本（#5195）
|
||||
If Not String.IsNullOrEmpty(Loader.Input) Then
|
||||
Dim Id = Loader.Input
|
||||
If Not DlClientListLoader.Output.Value("versions").Any(Function(v) v("id") = Id) Then
|
||||
If DlClientListLoader.Output.Value IsNot Nothing AndAlso Not DlClientListLoader.Output.Value("versions").Any(Function(v) v("id") = Id) Then
|
||||
Throw New Exception("BMCLAPI 源未包含目标版本 " & Id)
|
||||
End If
|
||||
End If
|
||||
@@ -370,7 +377,7 @@
|
||||
''' </summary>
|
||||
Public DlOptiFineListOfficialLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Official", AddressOf DlOptiFineListOfficialMain)
|
||||
Private Sub DlOptiFineListOfficialMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
|
||||
Dim Result As String = NetGetCodeByClient("https://optifine.net/downloads", Encoding.Default)
|
||||
Dim Result As String = NetRequestByClientRetry("https://optifine.net/downloads", Encoding:=Encoding.Default)
|
||||
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
|
||||
Try
|
||||
'获取所有版本信息
|
||||
@@ -406,7 +413,7 @@
|
||||
''' </summary>
|
||||
Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain)
|
||||
Private Sub DlOptiFineListBmclapiMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult))
|
||||
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/optifine/versionList", IsJson:=True)
|
||||
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/optifine/versionList", RequireJson:=True))
|
||||
Try
|
||||
Dim Versions As New List(Of DlOptiFineListEntry)
|
||||
For Each Token As JObject In Json
|
||||
@@ -476,7 +483,7 @@
|
||||
''' </summary>
|
||||
Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain)
|
||||
Private Sub DlForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
|
||||
Dim Result As String = NetGetCodeByRequestRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding.Default, "text/html", UseBrowserUserAgent:=True)
|
||||
Dim Result As String = NetRequestByClientRetry("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_1.2.4.html", Encoding:=Encoding.Default, Accept:="text/html", SimulateBrowserHeaders:=True)
|
||||
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
|
||||
'获取所有版本信息
|
||||
Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)")
|
||||
@@ -490,7 +497,7 @@
|
||||
''' </summary>
|
||||
Public DlForgeListBmclapiLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Bmclapi", AddressOf DlForgeListBmclapiMain)
|
||||
Private Sub DlForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlForgeListResult))
|
||||
Dim Result As String = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding.Default)
|
||||
Dim Result As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft", Encoding:=Encoding.Default)
|
||||
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足（" & Result & "）")
|
||||
'获取所有版本信息
|
||||
Dim Names As List(Of String) = RegexSearch(Result, "[0-9.]+(_pre[0-9]?)?")
|
||||
@@ -587,7 +594,7 @@
|
||||
VersionName = Version
|
||||
Me.Version = New Version(Version)
|
||||
Me.Inherit = Inherit
|
||||
FileVersion = Version & If(Branch Is Nothing, ""， "-" & Branch)
|
||||
FileVersion = Version & If(Branch Is Nothing, "", "-" & Branch)
|
||||
End Sub
|
||||
End Class
|
||||
|
||||
@@ -622,11 +629,11 @@
|
||||
Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
|
||||
Dim Result As String
|
||||
Try
|
||||
Result = NetGetCodeByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" &
|
||||
Result = NetRequestByLoader("https://files.minecraftforge.net/maven/net/minecraftforge/forge/index_" &
|
||||
Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4，#4057
|
||||
".html", UseBrowserUserAgent:=True)
|
||||
".html", SimulateBrowserHeaders:=True)
|
||||
Catch ex As Exception
|
||||
If GetExceptionSummary(ex).Contains("(404)") Then
|
||||
If ex.GetBrief().Contains("(404)") Then
|
||||
Throw New Exception("不可用")
|
||||
Else
|
||||
Throw
|
||||
@@ -693,9 +700,8 @@
|
||||
''' Forge 版本列表，BMCLAPI。
|
||||
''' </summary>
|
||||
Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
|
||||
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
|
||||
Loader.Input.Replace("-", "_"), '兼容 Forge 1.7.10-pre4，#4057
|
||||
IsJson:=True)
|
||||
Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
|
||||
Loader.Input.Replace("-", "_"), RequireJson:=True)) '兼容 Forge 1.7.10-pre4，#4057
|
||||
Dim Versions As New List(Of DlForgeVersionEntry)
|
||||
Try
|
||||
Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input)
|
||||
@@ -829,8 +835,8 @@
|
||||
Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain)
|
||||
Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
|
||||
'获取版本列表 JSON
|
||||
Dim ResultLatest As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True)
|
||||
Dim ResultLegacy As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True)
|
||||
Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", RequireJson:=True)
|
||||
Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", RequireJson:=True)
|
||||
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）")
|
||||
'解析
|
||||
Try
|
||||
@@ -847,8 +853,8 @@
|
||||
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain)
|
||||
Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
|
||||
'获取版本列表 JSON
|
||||
Dim ResultLatest As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True)
|
||||
Dim ResultLegacy As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True)
|
||||
Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", RequireJson:=True)
|
||||
Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", RequireJson:=True)
|
||||
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足（" & ResultLatest & "）")
|
||||
'解析
|
||||
Try
|
||||
@@ -953,7 +959,7 @@
|
||||
''' </summary>
|
||||
Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain)
|
||||
Private Sub DlLiteLoaderListOfficialMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
|
||||
Dim Result As JObject = NetGetCodeByRequestRetry("https://dl.liteloader.com/versions/versions.json", IsJson:=True)
|
||||
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://dl.liteloader.com/versions/versions.json", RequireJson:=True))
|
||||
Try
|
||||
Dim Json As JObject = Result("versions")
|
||||
Dim Versions As New List(Of DlLiteLoaderListEntry)
|
||||
@@ -981,7 +987,7 @@
|
||||
''' </summary>
|
||||
Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain)
|
||||
Private Sub DlLiteLoaderListBmclapiMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult))
|
||||
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", IsJson:=True)
|
||||
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/maven/com/mumfrey/liteloader/versions.json", RequireJson:=True))
|
||||
Try
|
||||
Dim Json As JObject = Result("versions")
|
||||
Dim Versions As New List(Of DlLiteLoaderListEntry)
|
||||
@@ -1052,7 +1058,7 @@
|
||||
''' </summary>
|
||||
Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain)
|
||||
Private Sub DlFabricListOfficialMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
|
||||
Dim Result As JObject = NetGetCodeByRequestRetry("https://meta.fabricmc.net/v2/versions", IsJson:=True)
|
||||
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://meta.fabricmc.net/v2/versions", RequireJson:=True))
|
||||
Try
|
||||
Dim Output = New DlFabricListResult With {.IsOfficial = True, .SourceName = "Fabric 官方源", .Value = Result}
|
||||
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
|
||||
@@ -1067,7 +1073,7 @@
|
||||
''' </summary>
|
||||
Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain)
|
||||
Private Sub DlFabricListBmclapiMain(Loader As LoaderTask(Of Integer, DlFabricListResult))
|
||||
Dim Result As JObject = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", IsJson:=True)
|
||||
Dim Result As JObject = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/fabric-meta/v2/versions", RequireJson:=True))
|
||||
Try
|
||||
Dim Output = New DlFabricListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Result}
|
||||
If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
|
||||
@@ -1094,72 +1100,37 @@
|
||||
#Region "DlMod | Mod 镜像源请求"
|
||||
|
||||
''' <summary>
|
||||
''' 对可能涉及 Mod 镜像源的请求进行处理，返回字符串或 JObject。
|
||||
''' 调用 NetGetCodeByRequest，会进行重试。
|
||||
''' </summary>
|
||||
Public Function DlModRequest(Url As String, Optional IsJson As Boolean = False) As Object
|
||||
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
|
||||
'Dim McimUrl As String = DlSourceModGet(Url)
|
||||
'If McimUrl <> Url Then
|
||||
' Select Case Setup.Get("ToolDownloadMod")
|
||||
' Case 0
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
|
||||
' Case 1
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
' Case Else
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
' End Select
|
||||
'End If
|
||||
Dim Exs As String = ""
|
||||
For Each Source In Urls
|
||||
Try
|
||||
Return NetGetCodeByRequestOnce(Source.Key, Encode:=Encoding.UTF8, Timeout:=Source.Value * 1000, IsJson:=IsJson, UseBrowserUserAgent:=True)
|
||||
Catch ex As Exception
|
||||
Exs += ex.Message + vbCrLf
|
||||
End Try
|
||||
Next
|
||||
Throw New Exception(Exs)
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 对可能涉及 Mod 镜像源的请求进行处理。
|
||||
''' 对可能涉及 Mod 镜像源的请求进行处理，返回 JToken。
|
||||
''' 调用 NetRequest，会进行重试。
|
||||
''' </summary>
|
||||
Public Function DlModRequest(Url As String, Method As String, Data As String, ContentType As String) As String
|
||||
Public Function DlModRequest(Url As String, Optional Method As HttpMethod = Nothing,
|
||||
Optional Content As String = Nothing, Optional ContentType As String = Nothing) As JToken
|
||||
Dim Urls As New List(Of KeyValuePair(Of String, Integer))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20))
|
||||
'Dim McimUrl As String = DlSourceModGet(Url)
|
||||
'If McimUrl <> Url Then
|
||||
' Select Case Setup.Get("ToolDownloadMod")
|
||||
' Case 0
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
|
||||
' Case 1
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
' Case Else
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15))
|
||||
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
' End Select
|
||||
'End If
|
||||
Dim McimUrl As String = DlSourceModGet(Url)
|
||||
If McimUrl <> Url Then
|
||||
Select Case Setup.Get("ToolDownloadMod")
|
||||
Case 0
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
|
||||
Case 1
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10)) '至少 10s，要不然有时候远端服务器来不及完成
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
|
||||
Case Else
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
|
||||
End Select
|
||||
Else
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10))
|
||||
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
|
||||
End If
|
||||
Dim Exs As String = ""
|
||||
For Each Source In Urls
|
||||
Try
|
||||
Return NetRequestOnce(Source.Key, Method, Data, ContentType, Timeout:=Source.Value * 1000)
|
||||
Return GetJson(NetRequestByClient(Source.Key, Method, Content, ContentType, Timeout:=Source.Value * 1000, Encoding:=Encoding.UTF8, RequireJson:=True))
|
||||
Catch ex As Exception
|
||||
Exs += ex.Message + vbCrLf
|
||||
End Try
|
||||
@@ -1171,18 +1142,54 @@
|
||||
|
||||
#Region "DlSource | 镜像下载源"
|
||||
|
||||
Public Function DlSourceResourceGet(Original As String) As String()
|
||||
Original = Original.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
|
||||
Return {
|
||||
Original.
|
||||
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").
|
||||
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").
|
||||
Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets"),
|
||||
Original
|
||||
}
|
||||
Private DlPreferMojang As Boolean = False
|
||||
''' <summary>
|
||||
''' 下载文件（而非获取版本列表）的时候，是否优先使用官方源。
|
||||
''' </summary>
|
||||
Public ReadOnly Property DlSourcePreferMojang As Boolean
|
||||
Get
|
||||
Return Setup.Get("ToolDownloadSource") = 2 OrElse (Setup.Get("ToolDownloadSource") = 1 AndAlso DlPreferMojang)
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' 下载文件（而非获取版本列表）的时候，根据是否优先使用官方源决定使用 Url 的顺序。
|
||||
''' </summary>
|
||||
Public Function DlSourceOrder(OfficialUrls As IEnumerable(Of String), MirrorUrls As IEnumerable(Of String)) As IEnumerable(Of String)
|
||||
Return If(DlSourcePreferMojang, OfficialUrls.Union(MirrorUrls), MirrorUrls.Union(OfficialUrls))
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 获取版本列表（而非下载文件）的时候，是否优先使用官方源。
|
||||
''' </summary>
|
||||
Public ReadOnly Property DlVersionListPreferMojang As Boolean
|
||||
Get
|
||||
Return Setup.Get("ToolDownloadVersion") = 2 OrElse (Setup.Get("ToolDownloadVersion") = 1 AndAlso DlPreferMojang)
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' 获取版本列表（而非下载文件）的时候，根据是否优先使用官方源决定使用 Url 的顺序。
|
||||
''' </summary>
|
||||
Public Function DlVersionListOrder(OfficialUrls As IEnumerable(Of String), MirrorUrls As IEnumerable(Of String)) As IEnumerable(Of String)
|
||||
Return If(DlVersionListPreferMojang, OfficialUrls.Union(MirrorUrls), MirrorUrls.Union(OfficialUrls))
|
||||
End Function
|
||||
|
||||
Public Function DlSourceLibraryGet(Original As String) As String()
|
||||
|
||||
''' <summary>
|
||||
''' 下载 Assets 文件。
|
||||
''' </summary>
|
||||
Public Function DlSourceAssetsGet(Original As String) As IEnumerable(Of String)
|
||||
Original = Original.Replace("http://resources.download.minecraft.net", "https://resources.download.minecraft.net")
|
||||
Return DlSourceOrder(
|
||||
{Original},
|
||||
{Original.
|
||||
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/assets").
|
||||
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/assets").
|
||||
Replace("https://resources.download.minecraft.net", "https://bmclapi2.bangbang93.com/assets")
|
||||
})
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 下载 Libraries 文件。
|
||||
''' </summary>
|
||||
Public Function DlSourceLibraryGet(Original As String) As IEnumerable(Of String)
|
||||
If {"minecraftforge", "fabricmc", "neoforged"}.Any(Function(k) Original.Contains(k)) Then '不添加原版源
|
||||
Return {
|
||||
Original.
|
||||
@@ -1195,44 +1202,48 @@
|
||||
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries")
|
||||
}
|
||||
Else
|
||||
Return {
|
||||
Original.
|
||||
Return DlSourceOrder(
|
||||
{Original},
|
||||
{Original.
|
||||
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/maven").
|
||||
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/maven").
|
||||
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/maven"),
|
||||
Original.
|
||||
Original.
|
||||
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com/libraries").
|
||||
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com/libraries").
|
||||
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries"),
|
||||
Original
|
||||
}
|
||||
Replace("https://libraries.minecraft.net", "https://bmclapi2.bangbang93.com/libraries")
|
||||
})
|
||||
End If
|
||||
End Function
|
||||
|
||||
Public Function DlSourceModGet(Original As String) As String
|
||||
Return Original
|
||||
'Return Original.
|
||||
' Replace("api.modrinth.com", "mod.mcimirror.top/modrinth").
|
||||
' Replace("staging-api.modrinth.com", "mod.mcimirror.top/modrinth").
|
||||
' Replace("cdn.modrinth.com", "mod.mcimirror.top").
|
||||
' Replace("api.curseforge.com", "mod.mcimirror.top/curseforge").
|
||||
' Replace("edge.forgecdn.net", "mod.mcimirror.top").
|
||||
' Replace("mediafilez.forgecdn.net", "mod.mcimirror.top").
|
||||
' Replace("media.forgecdn.net", "mod.mcimirror.top")
|
||||
End Function
|
||||
|
||||
Public Function DlSourceLauncherOrMetaGet(Original As String) As String()
|
||||
''' <summary>
|
||||
''' 下载 Launcher 或 Meta 文件。
|
||||
''' 不应使用它来获取版本列表（因为它只使用文件下载源设置来决定源顺序）。
|
||||
''' </summary>
|
||||
Public Function DlSourceLauncherOrMetaGet(Original As String) As IEnumerable(Of String)
|
||||
If Original Is Nothing Then Throw New Exception("无对应的 json 下载地址")
|
||||
Return {
|
||||
Original.
|
||||
Return DlSourceOrder(
|
||||
{Original},
|
||||
{Original.
|
||||
Replace("https://piston-data.mojang.com", "https://bmclapi2.bangbang93.com").
|
||||
Replace("https://piston-meta.mojang.com", "https://bmclapi2.bangbang93.com").
|
||||
Replace("https://launcher.mojang.com", "https://bmclapi2.bangbang93.com").
|
||||
Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com"),
|
||||
Original
|
||||
}
|
||||
Replace("https://launchermeta.mojang.com", "https://bmclapi2.bangbang93.com")
|
||||
})
|
||||
End Function
|
||||
|
||||
'Mod 下载源
|
||||
Public Function DlSourceModGet(Original As String) As String
|
||||
Return Original.
|
||||
Replace("api.modrinth.com", "mod.mcimirror.top/modrinth").
|
||||
Replace("staging-api.modrinth.com", "mod.mcimirror.top/modrinth").
|
||||
Replace("cdn.modrinth.com", "mod.mcimirror.top").
|
||||
Replace("api.curseforge.com", "mod.mcimirror.top/curseforge").
|
||||
Replace("edge.forgecdn.net", "mod.mcimirror.top").
|
||||
Replace("mediafilez.forgecdn.net", "mod.mcimirror.top").
|
||||
Replace("media.forgecdn.net", "mod.mcimirror.top")
|
||||
End Function
|
||||
|
||||
'Loader 自动切换
|
||||
Private Sub DlSourceLoader(Of InputType, OutputType)(MainLoader As LoaderTask(Of InputType, OutputType),
|
||||
LoaderList As List(Of KeyValuePair(Of LoaderTask(Of InputType, OutputType), Integer)),
|
||||
Optional IsForceRestart As Boolean = False)
|
||||
@@ -1251,7 +1262,7 @@
|
||||
'检查加载器成功
|
||||
MainLoader.Output = SubLoader.Key.Output
|
||||
DlSourceLoaderAbort(LoaderList)
|
||||
Exit Sub
|
||||
Return
|
||||
ElseIf BeforeLoadersAllFailed Then
|
||||
'此前的加载器全部失败，直接启动后续加载器
|
||||
If WaitCycle < SubLoader.Value * 100 Then WaitCycle = SubLoader.Value * 100
|
||||
@@ -1293,7 +1304,7 @@
|
||||
'检查父加载器中断
|
||||
If MainLoader.IsAborted Then
|
||||
DlSourceLoaderAbort(LoaderList)
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
Loop
|
||||
End Sub
|
||||
|
||||
@@ -10,7 +10,7 @@
|
||||
|
||||
'路径
|
||||
''' <summary>
|
||||
''' Java.exe 文件的完整路径。
|
||||
''' java.exe 文件的完整路径。
|
||||
''' </summary>
|
||||
Public ReadOnly Property PathJava As String
|
||||
Get
|
||||
@@ -18,15 +18,7 @@
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' Javaw.exe 文件的完整路径。
|
||||
''' </summary>
|
||||
Public ReadOnly Property PathJavaw As String
|
||||
Get
|
||||
Return PathFolder & "javaw.exe"
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' Javaw.exe 文件所在文件夹的路径，以 \ 结尾。
|
||||
''' java.exe 文件所在文件夹的路径，以 \ 结尾。
|
||||
''' </summary>
|
||||
Public PathFolder As String
|
||||
''' <summary>
|
||||
@@ -98,22 +90,19 @@
|
||||
''' 检查并获取 Java 详细信息。在 Java 存在异常时抛出错误。
|
||||
''' </summary>
|
||||
Public Sub Check()
|
||||
If IsChecked Then Exit Sub
|
||||
If IsChecked Then Return
|
||||
Dim Output As String = Nothing
|
||||
Try
|
||||
'确定文件存在
|
||||
If Not File.Exists(PathJavaw) Then
|
||||
Throw New FileNotFoundException("未找到 javaw.exe 文件", PathJavaw)
|
||||
End If
|
||||
If Not File.Exists(PathFolder & "java.exe") Then
|
||||
Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe")
|
||||
End If
|
||||
If Not File.Exists(PathJava) Then Throw New FileNotFoundException("未找到 java.exe 文件", PathJava)
|
||||
If File.Exists(PathFolder & "pdf-bookmark") Then Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
|
||||
IsJre = Not File.Exists(PathFolder & "javac.exe")
|
||||
'运行 -version
|
||||
Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower
|
||||
Output = StartProcessAndGetOutput(PathJava, "-version", 15000).ToLower
|
||||
If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败")
|
||||
If ModeDebug Then Log("[Java] Java 检查输出：" & PathFolder & "java.exe" & vbCrLf & Output)
|
||||
If ModeDebug Then Log("[Java] Java 检查输出：" & PathJava & vbCrLf & Output)
|
||||
If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java，请在删除 Java 文件夹中的 /lib/ext 文件夹后再试")
|
||||
If Output.Contains("a fatal error") Then Throw New ApplicationException("无法运行该 Java，该 Java 或系统存在问题")
|
||||
'获取详细信息
|
||||
Dim VersionString = If(RegexSeek(Output, "(?<=version "")[^""]+"), If(RegexSeek(Output, "(?<=openjdk )[0-9]+"), "")).Replace("_", ".").Split("-").First
|
||||
If VersionString.Split(".").Count > 4 Then VersionString = VersionString.Replace(".0.", ".") '#3493，VersionString = "21.0.2.0.2"
|
||||
@@ -132,17 +121,17 @@
|
||||
End If
|
||||
Is64Bit = Output.Contains("64-bit")
|
||||
If Version.Minor <= 4 OrElse Version.Minor >= 100 Then Throw New ApplicationException("分析详细信息失败，获取的版本为 " & Version.ToString)
|
||||
'基于 #3649，在 64 位系统上禁用 32 位 Java
|
||||
'#3649：在 64 位系统上禁用 32 位 Java
|
||||
If Not Is64Bit AndAlso Not Is32BitSystem Then Throw New Exception("该 Java 为 32 位版本，请安装 64 位的 Java")
|
||||
'基于 #2249 发现 JRE 17 似乎也导致了 Forge 安装失败，干脆禁用更多版本的 JRE
|
||||
'#2249：JRE 17 似乎会导致 Forge 安装失败，干脆禁用更多版本的 JRE
|
||||
If IsJre AndAlso VersionCode >= 16 Then Throw New Exception("由于高版本 JRE 对游戏的兼容性很差，因此不再允许使用。你可以使用对应版本的 JDK，而非 JRE！")
|
||||
Catch ex As ApplicationException
|
||||
Throw ex
|
||||
Catch ex As ThreadInterruptedException
|
||||
Throw ex
|
||||
Catch ex As Exception
|
||||
Log("[Java] 检查失败的 Java 输出：" & PathFolder & "java.exe" & vbCrLf & If(Output, "无程序输出"))
|
||||
Throw New Exception("检查 Java 失败（" & If(PathJavaw, "Nothing") & "）", ex)
|
||||
Log("[Java] 检查失败的 Java 输出：" & If(PathJava, "Nothing") & vbCrLf & If(Output, "无程序输出"))
|
||||
Throw New Exception("检查 Java 失败（" & If(PathJava, "Nothing") & "）", ex)
|
||||
End Try
|
||||
IsChecked = True
|
||||
End Sub
|
||||
@@ -372,6 +361,7 @@ ExitUserJavaCheck:
|
||||
For Each Java In AllowedJavaList
|
||||
'如果在官启文件夹启动，会将官启自带 Java 错误视作 MC 文件夹指定 Java，导致了 #2054 的第二例
|
||||
If Java.PathFolder.Contains(".minecraft\cache\java") Then Continue For
|
||||
If Java.PathFolder.Contains("PCL\MyDownload\") Then Continue For '#5780
|
||||
If TargetJavaList.Contains(Java) Then
|
||||
'直接使用指定的 Java
|
||||
AllowedJavaList = New List(Of JavaEntry) From {Java}
|
||||
@@ -455,10 +445,12 @@ NoUserJava:
|
||||
''' 将 Java 按照适用性排序。
|
||||
''' </summary>
|
||||
Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean
|
||||
Dim PathInfo As New DirectoryInfo(Path)
|
||||
Dim PathMcInfo As New DirectoryInfo(PathMcFolder)
|
||||
'1. 尽量在当前文件夹或当前 Minecraft 文件夹
|
||||
Dim ProgramPathParent As String, MinecraftPathParent As String = ""
|
||||
ProgramPathParent = If(New DirectoryInfo(Path).Parent, New DirectoryInfo(Path)).FullName
|
||||
If PathMcFolder <> "" Then MinecraftPathParent = If(New DirectoryInfo(PathMcFolder).Parent, New DirectoryInfo(PathMcFolder)).FullName
|
||||
ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName
|
||||
If PathMcFolder <> "" Then MinecraftPathParent = If(PathMcInfo.Parent, PathMcInfo).FullName
|
||||
If Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Not Right.PathFolder.StartsWithF(ProgramPathParent) Then Return True
|
||||
If Not Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Right.PathFolder.StartsWithF(ProgramPathParent) Then Return False
|
||||
If PathMcFolder <> "" Then
|
||||
@@ -525,6 +517,8 @@ NoUserJava:
|
||||
If Disk.DriveType = DriveType.Network Then Continue For '跳过网络驱动器（#3705）
|
||||
JavaSearchFolder(Disk.Name, JavaPreList, False)
|
||||
Next
|
||||
'查找 .jdks 文件夹中的 Java
|
||||
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.jdks\", JavaPreList, False, True)
|
||||
'查找 APPDATA 文件夹中的 Java
|
||||
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\", JavaPreList, False)
|
||||
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\", JavaPreList, False)
|
||||
@@ -555,10 +549,9 @@ NoUserJava:
|
||||
'若不全为特殊引用，则清除特殊引用的地址
|
||||
Dim JavaWithoutInherit As New Dictionary(Of String, Boolean)
|
||||
For Each Pair In JavaPreList
|
||||
If Pair.Key.Contains("java8path_target_") OrElse Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") Then
|
||||
Log("[Java] 位于 " & Pair.Key & " 的 Java 包含特殊引用")
|
||||
If Pair.Key.Contains("java8path_target_") OrElse Pair.Key.Contains("javapath_target_") OrElse Pair.Key.Contains("javatmp") OrElse Pair.Key.ContainsF("system32") Then
|
||||
Log("[Java] 位于 " & Pair.Key & " 的 Java 位于特殊路径，不应优先使用")
|
||||
Else
|
||||
Log("[Java] 位于 " & Pair.Key & " 的 Java 不含特殊引用")
|
||||
JavaWithoutInherit.Add(Pair.Key, Pair.Value)
|
||||
End If
|
||||
Next
|
||||
@@ -653,7 +646,7 @@ Wait:
|
||||
Private Sub JavaSearchFolder(OriginalPath As String, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False)
|
||||
Try
|
||||
Log("[Java] 开始" & If(IsFullSearch, "完全", "部分") & "遍历查找：" & OriginalPath)
|
||||
JavaSearchFolder(New DirectoryInfo(ShortenPath(OriginalPath)), Results, Source, IsFullSearch)
|
||||
JavaSearchFolder(New DirectoryInfo(OriginalPath), Results, Source, IsFullSearch)
|
||||
Catch ex As UnauthorizedAccessException
|
||||
Log("[Java] 遍历查找 Java 时遭遇无权限的文件夹：" & OriginalPath)
|
||||
Catch ex As Exception
|
||||
@@ -668,20 +661,20 @@ Wait:
|
||||
Private Sub JavaSearchFolder(OriginalPath As DirectoryInfo, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False)
|
||||
Try
|
||||
'确认目录存在
|
||||
If Not OriginalPath.Exists Then Exit Sub
|
||||
If Not OriginalPath.Exists Then Return
|
||||
Dim Path As String = OriginalPath.FullName.Replace("\\", "\")
|
||||
If Not Path.EndsWithF("\") Then Path += "\"
|
||||
'若该目录有 Java，则加入结果
|
||||
If File.Exists(Path & "javaw.exe") Then Results(Path) = Source
|
||||
'查找其下的所有文件夹
|
||||
'不应使用网易的 Java：https://github.com/Hex-Dragon/PCL2/issues/1279#issuecomment-2761489121
|
||||
Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon",
|
||||
'不应使用网易的 Java：https://github.com/Meloong-Git/PCL/issues/1279#issuecomment-2761489121
|
||||
Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon", "bin",
|
||||
"soft", "cache", "temp", "corretto", "roaming", "users", "craft", "program", "世界", "net",
|
||||
"游戏", "oracle", "game", "file", "data", "jvm", "服务", "server", "客户", "client", "整合",
|
||||
"应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot",
|
||||
"runtime", "x86", "x64", "forge", "原版", "optifine", "官方", "启动", "hmcl", "mod", "高清",
|
||||
"download", "launch", "程序", "path", "version", "baka", "pcl", "zulu", "local", "packages",
|
||||
"4297127d64ec6", "1.", "启动"}
|
||||
"4297127d64ec6", "1.", "启动", "jbr"}
|
||||
For Each FolderInfo As DirectoryInfo In OriginalPath.EnumerateDirectories
|
||||
If FolderInfo.Attributes.HasFlag(FileAttributes.ReparsePoint) Then Continue For '跳过符号链接
|
||||
Dim SearchEntry = GetFolderNameFromPath(FolderInfo.Name).ToLower '用于搜索的字符串
|
||||
@@ -712,8 +705,8 @@ Wait:
|
||||
Return False
|
||||
Else
|
||||
Return MyMsgBox($"PCL 未找到 {VersionDescription}，是否需要 PCL 自动下载？" & vbCrLf &
|
||||
$"如果你已经安装了 {VersionDescription}，请在 设置 → 启动选项 → 游戏 Java 中手动导入。",
|
||||
"未找到 Java", "自动下载", "取消") = 1
|
||||
$"如果你已经安装了 {VersionDescription}，可以在 设置 → 启动选项 → 游戏 Java 中手动导入。",
|
||||
"自动下载 Java？", "自动下载", "取消") = 1
|
||||
End If
|
||||
End Function
|
||||
|
||||
@@ -742,10 +735,10 @@ Wait:
|
||||
Private LastJavaBaseDir As String = Nothing '用于在下载中断或失败时删除未完成下载的 Java 文件夹，防止残留只下了一半但 -version 能跑的 Java
|
||||
Private Sub JavaFileList(Loader As LoaderTask(Of Integer, List(Of NetFile)))
|
||||
Log("[Java] 开始获取 Java 下载信息")
|
||||
Dim IndexFileStr As String = NetGetCodeByLoader(
|
||||
{"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json",
|
||||
"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"},
|
||||
IsJson:=True)
|
||||
Dim IndexFileStr As String = NetRequestByLoader(DlVersionListOrder(
|
||||
{"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"},
|
||||
{"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"}
|
||||
), IsJson:=True)
|
||||
'获取下载地址
|
||||
Dim MainEntry As JObject = CType(GetJson(IndexFileStr), JObject)($"windows-x{If(Is32BitSystem, "86", "64")}")
|
||||
Dim Entries = MainEntry.Children.Reverse. '选择最靠后的一项（最新）
|
||||
@@ -754,7 +747,7 @@ Wait:
|
||||
Dim Address As String = TargetEntry.Value("manifest")("url")
|
||||
Log($"[Java] 准备下载 Java {TargetEntry.Value("version")("name")}（{TargetEntry.Key}）：{Address}")
|
||||
'获取文件列表
|
||||
Dim ListFileStr As String = NetGetCodeByLoader({Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com"), Address}, IsJson:=True)
|
||||
Dim ListFileStr As String = NetRequestByLoader(DlSourceOrder({Address}, {Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com")}), IsJson:=True)
|
||||
LastJavaBaseDir = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\runtime\" & TargetEntry.Key & "\"
|
||||
Dim Results As New List(Of NetFile)
|
||||
For Each File As JProperty In CType(GetJson(ListFileStr), JObject)("files")
|
||||
@@ -767,7 +760,7 @@ Wait:
|
||||
End If
|
||||
If Checker.Check(LastJavaBaseDir & File.Name) Is Nothing Then Continue For '跳过已存在的文件
|
||||
Dim Url As String = Info("url")
|
||||
Results.Add(New NetFile({Url.Replace("piston-data.mojang.com", "bmclapi2.bangbang93.com"), Url}, LastJavaBaseDir & File.Name, Checker))
|
||||
Results.Add(New NetFile(DlSourceOrder({Url}, {Url.Replace("piston-data.mojang.com", "bmclapi2.bangbang93.com")}), LastJavaBaseDir & File.Name, Checker))
|
||||
Next
|
||||
Loader.Output = Results
|
||||
Log($"[Java] 需要下载 {Results.Count} 个文件，目标文件夹：{LastJavaBaseDir}")
|
||||
|
||||
@@ -65,8 +65,8 @@ Public Module ModLaunch
|
||||
''' 记录启动日志。
|
||||
''' </summary>
|
||||
Public Sub McLaunchLog(Text As String)
|
||||
Text = SecretFilter(Text, "*")
|
||||
RunInUi(Sub() FrmLaunchRight.LabLog.Text += vbCrLf & "[" & GetTimeNow() & "] " & Text)
|
||||
Text = FilterUserName(FilterAccessToken(Text, "*"), "*")
|
||||
RunInUi(Sub() FrmLaunchRight.LabLog.Text += $"{vbCrLf}[{GetTimeNow()}] {Text}")
|
||||
Log("[Launch] " & Text)
|
||||
End Sub
|
||||
|
||||
@@ -101,6 +101,8 @@ Public Module ModLaunch
|
||||
If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical)
|
||||
Throw
|
||||
End Try
|
||||
Dim IsSavingBatch As Boolean = CurrentLaunchOptions?.SaveBatch IsNot Nothing
|
||||
|
||||
'正式加载
|
||||
Try
|
||||
'构造主加载器
|
||||
@@ -145,9 +147,15 @@ Public Module ModLaunch
|
||||
Select Case LaunchLoader.State
|
||||
Case LoadState.Finished
|
||||
Hint(McVersionCurrent.Name & " 启动成功！", HintType.Finish)
|
||||
'上报
|
||||
If Not IsSavingBatch Then
|
||||
Telemetry("Minecraft 启动成功",
|
||||
"Version", McVersionCurrent.Version.ToString,
|
||||
"LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)))
|
||||
End If
|
||||
Case LoadState.Aborted
|
||||
If AbortHint Is Nothing Then
|
||||
Hint(If(CurrentLaunchOptions?.SaveBatch Is Nothing, "已取消启动！", "已取消导出启动脚本！"), HintType.Info)
|
||||
Hint(If(IsSavingBatch, "已取消导出启动脚本！", "已取消启动！"), HintType.Info)
|
||||
Else
|
||||
Hint(AbortHint, HintType.Finish)
|
||||
End If
|
||||
@@ -162,7 +170,7 @@ NextInner:
|
||||
If CurrentEx.Message.StartsWithF("$") Then
|
||||
'若有以 $ 开头的错误信息，则以此为准显示提示
|
||||
'若错误信息为 $$，则不提示
|
||||
If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
|
||||
If Not CurrentEx.Message = "$$" Then MyMsgBox(CurrentEx.Message.TrimStart("$"), If(IsSavingBatch, "导出启动脚本失败", "启动失败"))
|
||||
Throw
|
||||
ElseIf CurrentEx.InnerException IsNot Nothing Then
|
||||
'检查下一级错误
|
||||
@@ -170,10 +178,17 @@ NextInner:
|
||||
GoTo NextInner
|
||||
Else
|
||||
'没有特殊处理过的错误信息
|
||||
McLaunchLog("错误：" & GetExceptionDetail(ex))
|
||||
McLaunchLog("错误：" & ex.GetDetail())
|
||||
Log(ex,
|
||||
If(CurrentLaunchOptions?.SaveBatch Is Nothing, "Minecraft 启动失败", "导出启动脚本失败"), LogLevel.Msgbox,
|
||||
If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败"))
|
||||
If(IsSavingBatch, "导出启动脚本失败", "Minecraft 启动失败"), LogLevel.Msgbox,
|
||||
If(IsSavingBatch, "导出启动脚本失败", "启动失败"))
|
||||
'上报
|
||||
If Not IsSavingBatch Then
|
||||
Telemetry("Minecraft 启动失败",
|
||||
"Version", McVersionCurrent.Version.ToString,
|
||||
"LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)),
|
||||
"Exception", FilterUserName(FilterAccessToken(ex.GetDetail(), "*"), "*"))
|
||||
End If
|
||||
Throw
|
||||
End If
|
||||
End Try
|
||||
@@ -578,11 +593,7 @@ SkipLogin:
|
||||
Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult))
|
||||
Dim Input As McLoginServer = Data.Input
|
||||
Dim NeedRefresh As Boolean = False, WasRefreshed As Boolean = False
|
||||
Dim LogUsername As String = Input.UserName
|
||||
If LogUsername.Contains("@") AndAlso Setup.Get("UiLauncherEmail") Then
|
||||
LogUsername = AccountFilter(LogUsername)
|
||||
End If
|
||||
McLaunchLog("登录方式：" & Input.Description & "（" & LogUsername & "）")
|
||||
McLaunchLog("登录方式：" & Input.Description)
|
||||
Data.Progress = 0.05
|
||||
'尝试登录
|
||||
If (Not Data.Input.ForceReselectProfile) AndAlso
|
||||
@@ -598,12 +609,8 @@ SkipLogin:
|
||||
McLoginRequestValidate(Data)
|
||||
GoTo LoginFinish
|
||||
Catch ex As Exception
|
||||
Dim AllMessage = GetExceptionDetail(ex)
|
||||
McLaunchLog("验证登录失败：" & AllMessage)
|
||||
If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then
|
||||
McLaunchLog("已触发超时登录失败")
|
||||
Throw New Exception("$登录失败：连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好，或尝试使用 VPN！")
|
||||
End If
|
||||
Log(ex, "验证登录失败")
|
||||
If IsNetworkRelated(ex) Then Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后再试，或使用加速器、VPN 改善网络环境。")
|
||||
End Try
|
||||
Data.Progress = 0.25
|
||||
'尝试刷新登录
|
||||
@@ -613,7 +620,7 @@ Refresh:
|
||||
McLoginRequestRefresh(Data, NeedRefresh)
|
||||
GoTo LoginFinish
|
||||
Catch ex As Exception
|
||||
McLaunchLog("刷新登录失败：" & GetExceptionDetail(ex))
|
||||
McLaunchLog("刷新登录失败：" & ex.GetDetail())
|
||||
If WasRefreshed Then Throw New Exception("二轮刷新登录失败", ex)
|
||||
End Try
|
||||
Data.Progress = If(NeedRefresh, 0.85, 0.45)
|
||||
@@ -623,7 +630,7 @@ Refresh:
|
||||
If Data.IsAborted Then Throw New ThreadInterruptedException
|
||||
NeedRefresh = McLoginRequestLogin(Data)
|
||||
Catch ex As Exception
|
||||
McLaunchLog("登录失败：" & GetExceptionDetail(ex))
|
||||
McLaunchLog("登录失败：" & ex.GetDetail())
|
||||
Throw
|
||||
End Try
|
||||
If NeedRefresh Then
|
||||
@@ -688,11 +695,10 @@ LoginFinish:
|
||||
'发送登录请求
|
||||
Dim RequestData As New JObject(
|
||||
New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True))
|
||||
NetRequestRetry(
|
||||
Url:=Data.Input.BaseUrl & "/validate",
|
||||
Method:="POST",
|
||||
Data:=RequestData.ToString(0),
|
||||
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
|
||||
NetRequestByClientRetry(
|
||||
Data.Input.BaseUrl & "/validate", HttpMethod.Post,
|
||||
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
|
||||
Headers:={{"Accept-Language", "zh-CN"}},
|
||||
ContentType:="application/json; charset=utf-8") '没有返回值的
|
||||
'将登录结果输出
|
||||
Data.Output.AccessToken = AccessToken
|
||||
@@ -705,10 +711,9 @@ LoginFinish:
|
||||
End Sub
|
||||
Private Sub McLoginRequestRefresh(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult), RequestUser As Boolean)
|
||||
McLaunchLog("刷新登录开始（Refresh, " & Data.Input.Token & "）")
|
||||
Dim LoginJson As JObject = GetJson(NetRequestRetry(
|
||||
Url:=Data.Input.BaseUrl & "/refresh",
|
||||
Method:="POST",
|
||||
Data:=New JObject(
|
||||
Dim LoginJson As JObject = GetJson(NetRequestByClientRetry(
|
||||
Data.Input.BaseUrl & "/refresh", HttpMethod.Post,
|
||||
Content:=New JObject(
|
||||
New JProperty("selectedProfile", New JObject(
|
||||
New JProperty("name", Setup.Get($"Cache{Data.Input.Token}Name")),
|
||||
New JProperty("id", Setup.Get($"Cache{Data.Input.Token}Uuid"))
|
||||
@@ -716,8 +721,8 @@ LoginFinish:
|
||||
New JProperty("accessToken", Setup.Get($"Cache{Data.Input.Token}Access")),
|
||||
New JProperty("requestUser", True)
|
||||
).ToString(Newtonsoft.Json.Formatting.None),
|
||||
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
|
||||
ContentType:="application/json; charset=utf-8"))
|
||||
Headers:={{"Accept-Language", "zh-CN"}},
|
||||
ContentType:="application/json; charset=utf-8", RequireJson:=True))
|
||||
'将登录结果输出
|
||||
If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效！")
|
||||
Data.Output.AccessToken = LoginJson("accessToken").ToString
|
||||
@@ -743,12 +748,11 @@ LoginFinish:
|
||||
New JProperty("username", Data.Input.UserName),
|
||||
New JProperty("password", Data.Input.Password),
|
||||
New JProperty("requestUser", True))
|
||||
Dim LoginJson As JObject = GetJson(NetRequestRetry(
|
||||
Url:=Data.Input.BaseUrl & "/authenticate",
|
||||
Method:="POST",
|
||||
Data:=RequestData.ToString(0),
|
||||
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
|
||||
ContentType:="application/json; charset=utf-8"))
|
||||
Dim LoginJson As JObject = GetJson(NetRequestByClientRetry(
|
||||
Data.Input.BaseUrl & "/authenticate", HttpMethod.Post,
|
||||
Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
|
||||
Headers:={{"Accept-Language", "zh-CN"}},
|
||||
ContentType:="application/json; charset=utf-8", RequireJson:=True))
|
||||
'检查登录结果
|
||||
If LoginJson("availableProfiles").Count = 0 Then
|
||||
If Data.Input.ForceReselectProfile Then Hint("你还没有创建角色，无法更换！", HintType.Critical)
|
||||
@@ -806,13 +810,14 @@ LoginFinish:
|
||||
McLaunchLog("登录成功（Login, " & Data.Input.Token & "）")
|
||||
Return NeedRefresh
|
||||
Catch ex As Exception
|
||||
Dim AllMessage As String = GetExceptionSummary(ex)
|
||||
Dim AllMessage As String = ex.GetBrief()
|
||||
Log(ex, "登录失败原始错误信息", LogLevel.Normal)
|
||||
'读取服务器返回的错误
|
||||
If TypeOf ex Is ResponsedWebException Then
|
||||
Dim ErrorMessage As String = Nothing
|
||||
Try
|
||||
ErrorMessage = GetJson(DirectCast(ex, ResponsedWebException).Response)("errorMessage")
|
||||
Dim Response = DirectCast(ex, ResponsedWebException).Response
|
||||
If ErrorMessage.ContainsF("errorMessage", True) Then ErrorMessage = GetJson(Response)("errorMessage")
|
||||
Catch
|
||||
End Try
|
||||
If Not String.IsNullOrWhiteSpace(ErrorMessage) Then
|
||||
@@ -830,7 +835,7 @@ LoginFinish:
|
||||
End If
|
||||
End If
|
||||
'通用关键字检测
|
||||
If AllMessage.Contains("403") Then
|
||||
If AllMessage.Contains("(403)") Then
|
||||
Select Case Data.Input.Type
|
||||
Case McLoginType.Auth
|
||||
Throw New Exception("$登录失败，以下为可能的原因：" & vbCrLf &
|
||||
@@ -844,8 +849,8 @@ LoginFinish:
|
||||
If(Data.Input.UserName.Contains("@"), "", " - 登录账号应为邮箱或统一通行证账号，而非游戏角色 ID。" & vbCrLf) &
|
||||
" - 只注册了账号，但没有加入对应服务器。")
|
||||
End Select
|
||||
ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then
|
||||
Throw New Exception("$登录失败：连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好，或尝试使用 VPN！")
|
||||
ElseIf ex.IsNetworkRelated() Then
|
||||
Throw New Exception("$登录失败：你的网络环境不佳，导致难以连接到海外服务器。" & vbCrLf & "请稍后再试，或使用加速器、VPN 改善网络环境。")
|
||||
ElseIf ex.Message.StartsWithF("$") Then
|
||||
Throw
|
||||
Else
|
||||
@@ -862,8 +867,9 @@ LoginFinish:
|
||||
'初始请求
|
||||
Retry:
|
||||
McLaunchLog("开始微软登录步骤 1/6（原始登录）")
|
||||
Dim PrepareJson As JObject = GetJson(NetRequestRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST",
|
||||
$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded"))
|
||||
Dim PrepareJson As JObject = GetJson(NetRequestByClientRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", HttpMethod.Post,
|
||||
Content:=$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access",
|
||||
ContentType:="application/x-www-form-urlencoded", RequireJson:=True))
|
||||
McLaunchLog("网页登录地址：" & PrepareJson("verification_uri").ToString)
|
||||
|
||||
'弹窗
|
||||
@@ -892,13 +898,23 @@ Retry:
|
||||
|
||||
Dim Result As String
|
||||
Try
|
||||
Result = NetRequestMultiple("https://login.live.com/oauth20_token.srf", "POST",
|
||||
$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
|
||||
"application/x-www-form-urlencoded", 2)
|
||||
Catch ex As Exception
|
||||
If ex.Message.ContainsF("must sign in again", True) OrElse ex.Message.ContainsF("password expired", True) OrElse
|
||||
(ex.Message.Contains("refresh_token") AndAlso ex.Message.Contains("is not valid")) Then '#269
|
||||
Result = NetRequestByClientMultiple("https://login.live.com/oauth20_token.srf", HttpMethod.Post,
|
||||
Content:=$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
|
||||
ContentType:="application/x-www-form-urlencoded",
|
||||
Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}},
|
||||
ThreadCount:=2)
|
||||
Catch ex As ResponsedWebException
|
||||
'修改错误列表时，同时检查 MyMsgLogin.xaml.vb 中的对应代码
|
||||
Dim Response = ex.Response
|
||||
If Response.ContainsF("must sign in again", True) OrElse Response.ContainsF("password expired", True) OrElse
|
||||
(Response.Contains("refresh_token") AndAlso Response.Contains("is not valid")) Then '#269
|
||||
Return {"Relogin", ""}
|
||||
ElseIf Response.Contains("Account security interrupt") Then
|
||||
MyMsgBox("该账号由于安全问题无法登陆，请前往微软账户页获取更多信息。", "登录失败", "我知道了", IsWarn:=True)
|
||||
Throw New Exception("$$")
|
||||
ElseIf Response.Contains("service abuse") Then
|
||||
MyMsgBox("非常抱歉，该账号已被微软封禁，无法登录。", "登录失败", "我知道了", IsWarn:=True)
|
||||
Throw New Exception("$$")
|
||||
Else
|
||||
Throw
|
||||
End If
|
||||
@@ -922,8 +938,8 @@ Retry:
|
||||
""RelyingParty"": ""http://auth.xboxlive.com"",
|
||||
""TokenType"": ""JWT""
|
||||
}"
|
||||
Dim Result As String = NetRequestMultiple("https://user.auth.xboxlive.com/user/authenticate", "POST", Request, "application/json", 3)
|
||||
|
||||
Dim Result As String = NetRequestByClientMultiple("https://user.auth.xboxlive.com/user/authenticate", HttpMethod.Post,
|
||||
Content:=Request, ContentType:="application/json", RequireJson:=True)
|
||||
Dim ResultJson As JObject = GetJson(Result)
|
||||
Dim XBLToken As String = ResultJson("Token").ToString
|
||||
Return XBLToken
|
||||
@@ -944,21 +960,22 @@ Retry:
|
||||
}"
|
||||
Dim Result As String
|
||||
Try
|
||||
Result = NetRequestMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3)
|
||||
Catch ex As Net.WebException
|
||||
Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post,
|
||||
Content:=Request, ContentType:="application/json", RequireJson:=True)
|
||||
Catch ex As ResponsedWebException
|
||||
'参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js
|
||||
If ex.Message.Contains("2148916227") Then
|
||||
If ex.Response.Contains("2148916227") Then
|
||||
MyMsgBox("该账号似乎已被微软封禁，无法登录。", "登录失败", "我知道了", IsWarn:=True)
|
||||
Throw New Exception("$$")
|
||||
ElseIf ex.Message.Contains("2148916233") Then
|
||||
ElseIf ex.Response.Contains("2148916233") Then
|
||||
If MyMsgBox("你尚未注册 Xbox 账户，请在注册后再登录。", "登录提示", "注册", "取消") = 1 Then
|
||||
OpenWebsite("https://signup.live.com/signup")
|
||||
End If
|
||||
Throw New Exception("$$")
|
||||
ElseIf ex.Message.Contains("2148916235") Then
|
||||
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请尝试使用加速器或 VPN。", "登录失败", "我知道了")
|
||||
ElseIf ex.Response.Contains("2148916235") Then
|
||||
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN，然后再试。", "登录失败", "我知道了")
|
||||
Throw New Exception("$$")
|
||||
ElseIf ex.Message.Contains("2148916238") Then
|
||||
ElseIf ex.Response.Contains("2148916238") Then
|
||||
If MyMsgBox("该账号年龄不足，你需要先修改出生日期，然后才能登录。" & vbCrLf &
|
||||
"该账号目前填写的年龄是否在 13 岁以上？", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then
|
||||
OpenWebsite("https://account.live.com/editprof.aspx")
|
||||
@@ -976,9 +993,10 @@ Retry:
|
||||
End Try
|
||||
|
||||
Dim ResultJson As JObject = GetJson(Result)
|
||||
Dim XSTSToken As String = ResultJson("Token").ToString
|
||||
Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
|
||||
Return {XSTSToken, UHS}
|
||||
Return {
|
||||
ResultJson("Token"), 'XSTSToken
|
||||
ResultJson("DisplayClaims")("xui")(0)("uhs") 'UHS
|
||||
}
|
||||
End Function
|
||||
'微软登录步骤 4：从 {XSTSToken, UHS} 获取 Minecraft AccessToken
|
||||
Private Function MsLoginStep4(Tokens As String()) As String
|
||||
@@ -987,29 +1005,29 @@ Retry:
|
||||
Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0)
|
||||
Dim Result As String
|
||||
Try
|
||||
Result = NetRequestRetry("https://api.minecraftservices.com/authentication/login_with_xbox", "POST", Request, "application/json")
|
||||
Result = NetRequestByClientRetry("https://api.minecraftservices.com/authentication/login_with_xbox", HttpMethod.Post,
|
||||
Content:=Request, ContentType:="application/json", RequireJson:=True)
|
||||
Catch ex As Net.WebException
|
||||
Dim Message As String = GetExceptionSummary(ex)
|
||||
Dim Message As String = ex.GetBrief()
|
||||
If Message.Contains("(429)") Then
|
||||
Log(ex, "微软登录第 5 步汇报 429")
|
||||
Log(ex, "微软登录第 4 步汇报 429")
|
||||
Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！")
|
||||
ElseIf Message.Contains("(403)") Then
|
||||
Log(ex, "微软登录第 5 步汇报 403")
|
||||
Log(ex, "微软登录第 4 步汇报 403")
|
||||
Throw New Exception("$当前 IP 的登录尝试异常。" & vbCrLf & "如果你使用了 VPN 或加速器，请把它们关掉或更换节点后再试！")
|
||||
Else
|
||||
Throw
|
||||
End If
|
||||
End Try
|
||||
|
||||
Dim ResultJson As JObject = GetJson(Result)
|
||||
Dim AccessToken As String = ResultJson("access_token").ToString
|
||||
Return AccessToken
|
||||
Return GetJson(Result)("access_token").ToString
|
||||
End Function
|
||||
'微软登录步骤 5：验证微软账号是否持有 MC，这也会刷新 XGP
|
||||
Private Sub MsLoginStep5(AccessToken As String)
|
||||
McLaunchLog("开始微软登录步骤 5/6")
|
||||
|
||||
Dim Result As String = NetRequestMultiple("https://api.minecraftservices.com/entitlements/mcstore", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
|
||||
Dim Result As String = NetRequestByClientMultiple("https://api.minecraftservices.com/entitlements/mcstore",
|
||||
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True)
|
||||
Try
|
||||
Dim ResultJson As JObject = GetJson(Result)
|
||||
If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
|
||||
@@ -1020,7 +1038,7 @@ Retry:
|
||||
Throw New Exception("$$")
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "微软登录第 6 步异常：" & Result)
|
||||
Log(ex, "微软登录第 5 步异常：" & Result)
|
||||
Throw
|
||||
End Try
|
||||
End Sub
|
||||
@@ -1030,14 +1048,15 @@ Retry:
|
||||
|
||||
Dim Result As String
|
||||
Try
|
||||
Result = NetRequestMultiple("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}})
|
||||
Catch ex As Net.WebException
|
||||
Dim Message As String = GetExceptionSummary(ex)
|
||||
Result = NetRequestByClientMultiple("https://api.minecraftservices.com/minecraft/profile",
|
||||
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}}, RequireJson:=True)
|
||||
Catch ex As WebException
|
||||
Dim Message As String = ex.GetBrief()
|
||||
If Message.Contains("(429)") Then
|
||||
Log(ex, "微软登录第 7 步汇报 429")
|
||||
Log(ex, "微软登录第 6 步汇报 429")
|
||||
Throw New Exception("$登录尝试太过频繁，请等待几分钟后再试！")
|
||||
ElseIf Message.Contains("(404)") Then
|
||||
Log(ex, "微软登录第 7 步汇报 404")
|
||||
Log(ex, "微软登录第 6 步汇报 404")
|
||||
RunInNewThread(
|
||||
Sub()
|
||||
Select Case MyMsgBox("请先创建 Minecraft 玩家档案，然后再重新登录。", "登录失败", "创建档案", "取消")
|
||||
@@ -1084,8 +1103,7 @@ Retry:
|
||||
Uuid = McLoginMojangUuid(SkinName, False)
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "离线启动时使用的正版皮肤获取失败")
|
||||
MyMsgBox("由于设置的离线启动时使用的正版皮肤获取失败，游戏将以无皮肤的方式启动。" & vbCrLf & "请检查你的网络是否通畅，或尝试使用 VPN！" & vbCrLf & vbCrLf & "详细的错误信息：" & ex.Message, "皮肤获取失败")
|
||||
Log(ex, "皮肤信息获取失败，游戏将以无皮肤的方式启动", LogLevel.Hint)
|
||||
End Try
|
||||
Case 4
|
||||
'自定义
|
||||
@@ -1104,7 +1122,7 @@ Retry:
|
||||
If Len(Uuid) = 32 Then Return Uuid
|
||||
'从官网获取
|
||||
Try
|
||||
Dim GotJson As JObject = NetGetCodeByRequestRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, IsJson:=True)
|
||||
Dim GotJson As JObject = GetJson(NetRequestByClientRetry("https://api.mojang.com/users/profiles/minecraft/" & Name, RequireJson:=True))
|
||||
If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在（" & Name & "）")
|
||||
Uuid = If(GotJson("id"), "")
|
||||
Catch ex As Exception
|
||||
@@ -1134,23 +1152,22 @@ Retry:
|
||||
Dim MinVer As New Version(0, 0, 0, 0), MaxVer As New Version(999, 999, 999, 999)
|
||||
|
||||
'MC 大版本检测
|
||||
If (McVersionCurrent.ReleaseTime >= New Date(2024, 4, 2) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
|
||||
(McVersionCurrent.Version.McCodeMain > 20 AndAlso McVersionCurrent.Version.McCodeMain <> 99) OrElse
|
||||
(McVersionCurrent.Version.McCodeMain = 20 AndAlso McVersionCurrent.Version.McCodeSub >= 5) Then
|
||||
If (Not McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.ReleaseTime >= New Date(2024, 4, 2)) OrElse
|
||||
(McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.Version.McVersion >= New Version(1, 20, 5)) Then
|
||||
'1.20.5+（24w14a+）：至少 Java 21
|
||||
MinVer = New Version(1, 21, 0, 0)
|
||||
ElseIf (McVersionCurrent.ReleaseTime >= New Date(2021, 11, 16) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
|
||||
(McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain <> 99) Then
|
||||
ElseIf (Not McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.ReleaseTime >= New Date(2021, 11, 16)) OrElse
|
||||
(McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.Version.McVersion >= New Version(1, 18)) Then
|
||||
'1.18 pre2+：至少 Java 17
|
||||
MinVer = New Version(1, 17, 0, 0)
|
||||
ElseIf (McVersionCurrent.ReleaseTime >= New Date(2021, 5, 11) AndAlso McVersionCurrent.Version.McCodeMain = 99) OrElse
|
||||
(McVersionCurrent.Version.McCodeMain >= 17 AndAlso McVersionCurrent.Version.McCodeMain <> 99) Then
|
||||
ElseIf (Not McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.ReleaseTime >= New Date(2021, 5, 11)) OrElse
|
||||
(McVersionCurrent.Version.IsStandardVersion AndAlso McVersionCurrent.Version.McVersion >= New Version(1, 17)) Then
|
||||
'1.17+ (21w19a+)：至少 Java 16
|
||||
MinVer = New Version(1, 16, 0, 0)
|
||||
ElseIf McVersionCurrent.ReleaseTime.Year >= 2017 Then 'Minecraft 1.12 与 1.11 的分界线正好是 2017 年，太棒了
|
||||
'1.12+：至少 Java 8
|
||||
MinVer = New Version(1, 8, 0, 0)
|
||||
ElseIf McVersionCurrent.ReleaseTime <= New Date(2013, 5, 1) AndAlso McVersionCurrent.ReleaseTime.Year >= 2001 Then '避免某些版本的 1960 癌
|
||||
ElseIf McVersionCurrent.ReleaseTime <= New Date(2013, 5, 1) AndAlso McVersionCurrent.ReleaseTime.Year >= 2001 Then '避免某些版本写个 1960 年
|
||||
'1.5.2-：最高 Java 12
|
||||
MaxVer = New Version(1, 12, 999, 999)
|
||||
End If
|
||||
@@ -1161,11 +1178,11 @@ Retry:
|
||||
End If
|
||||
|
||||
'OptiFine 检测
|
||||
If McVersionCurrent.Version.HasOptiFine Then
|
||||
If McVersionCurrent.Version.McCodeMain <= 7 AndAlso McVersionCurrent.Version.McCodeMain > 0 Then
|
||||
If McVersionCurrent.Version.HasOptiFine AndAlso McVersionCurrent.Version.IsStandardVersion Then '不管非标准版本
|
||||
If McVersionCurrent.Version.McVersion < New Version(1, 7) Then
|
||||
'<1.7：至多 Java 8
|
||||
MaxVer = New Version(1, 8, 999, 999)
|
||||
ElseIf McVersionCurrent.Version.McCodeMain >= 8 AndAlso McVersionCurrent.Version.McCodeMain <= 11 Then
|
||||
ElseIf McVersionCurrent.Version.McVersion >= New Version(1, 8) AndAlso McVersionCurrent.Version.McVersion < New Version(1, 12) Then
|
||||
'1.8 - 1.11：必须恰好 Java 8
|
||||
MinVer = New Version(1, 8, 0, 0) : MaxVer = New Version(1, 8, 999, 999)
|
||||
ElseIf McVersionCurrent.Version.McCodeMain = 12 Then
|
||||
@@ -1176,14 +1193,14 @@ Retry:
|
||||
|
||||
'Forge 检测
|
||||
If McVersionCurrent.Version.HasForge Then
|
||||
If McVersionCurrent.Version.McName = "1.7.2" Then
|
||||
'1.7.2：必须 Java 7
|
||||
If McVersionCurrent.Version.McVersion >= New Version(1, 6, 1) AndAlso McVersionCurrent.Version.McVersion <= New Version(1, 7, 2) Then
|
||||
'1.6.1 - 1.7.2：必须 Java 7
|
||||
MinVer = If(New Version(1, 7, 0, 0) > MinVer, New Version(1, 7, 0, 0), MinVer)
|
||||
MaxVer = If(New Version(1, 7, 999, 999) < MaxVer, New Version(1, 7, 999, 999), MaxVer)
|
||||
ElseIf McVersionCurrent.Version.McCodeMain <= 12 AndAlso McVersionCurrent.Version.McCodeMain > 0 Then
|
||||
ElseIf McVersionCurrent.Version.McCodeMain <= 12 OrElse Not McVersionCurrent.Version.IsStandardVersion Then '非标准版本
|
||||
'<=1.12：Java 8
|
||||
MaxVer = New Version(1, 8, 999, 999)
|
||||
ElseIf McVersionCurrent.Version.McCodeMain <= 14 AndAlso McVersionCurrent.Version.McCodeMain >= 13 Then
|
||||
ElseIf McVersionCurrent.Version.McCodeMain <= 14 Then
|
||||
'1.13 - 1.14：Java 8 - 10
|
||||
MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer)
|
||||
MaxVer = If(New Version(1, 10, 999, 999) < MaxVer, New Version(1, 10, 999, 999), MaxVer)
|
||||
@@ -1201,16 +1218,22 @@ Retry:
|
||||
End If
|
||||
|
||||
'Fabric 检测
|
||||
If McVersionCurrent.Version.HasFabric Then
|
||||
If McVersionCurrent.Version.McCodeMain >= 15 AndAlso McVersionCurrent.Version.McCodeMain <= 16 AndAlso McVersionCurrent.Version.McCodeMain <> -1 Then
|
||||
If McVersionCurrent.Version.HasFabric AndAlso McVersionCurrent.Version.IsStandardVersion Then '不管非标准版本
|
||||
If McVersionCurrent.Version.McCodeMain >= 15 AndAlso McVersionCurrent.Version.McCodeMain <= 16 Then
|
||||
'1.15 - 1.16：Java 8+
|
||||
MinVer = If(New Version(1, 8, 0, 0) > MinVer, New Version(1, 8, 0, 0), MinVer)
|
||||
ElseIf McVersionCurrent.Version.McCodeMain >= 18 AndAlso McVersionCurrent.Version.McCodeMain < 99 Then
|
||||
ElseIf McVersionCurrent.Version.McCodeMain >= 18 Then
|
||||
'1.18+：Java 17+
|
||||
MinVer = If(New Version(1, 17, 0, 0) > MinVer, New Version(1, 17, 0, 0), MinVer)
|
||||
End If
|
||||
End If
|
||||
|
||||
'LiteLoader 检测
|
||||
If McVersionCurrent.Version.HasLiteLoader AndAlso McVersionCurrent.Version.IsStandardVersion Then '不管非标准版本
|
||||
'最高 Java 8
|
||||
MaxVer = If(New Version(1, 8, 999, 999) < MaxVer, New Version(1, 8, 999, 999), MaxVer)
|
||||
End If
|
||||
|
||||
'统一通行证检测
|
||||
If Setup.Get("LoginType") = McLoginType.Nide Then
|
||||
'至少 Java 8u101
|
||||
@@ -1222,28 +1245,32 @@ Retry:
|
||||
'选择 Java
|
||||
McLaunchLog("Java 版本需求：最低 " & MinVer.ToString & "，最高 " & MaxVer.ToString)
|
||||
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
|
||||
If Task.IsAborted Then Exit Sub
|
||||
If Task.IsAborted Then Return
|
||||
If McLaunchJavaSelected IsNot Nothing Then
|
||||
McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString)
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
|
||||
'无合适的 Java
|
||||
If Task.IsAborted Then Exit Sub '中断加载会导致 JavaSelect 异常地返回空值，误判找不到 Java
|
||||
If Task.IsAborted Then Return '中断加载会导致 JavaSelect 异常地返回空值，误判找不到 Java
|
||||
McLaunchLog("无合适的 Java，需要确认是否自动下载")
|
||||
Dim JavaCode As String
|
||||
If MinVer >= New Version(1, 22, 0, 0) Then '潜在的向后兼容
|
||||
If MinVer >= New Version(1, 22) Then '潜在的向后兼容
|
||||
JavaCode = MinVer.Minor
|
||||
If Not JavaDownloadConfirm("Java " & JavaCode) Then Throw New Exception("$$")
|
||||
ElseIf MinVer >= New Version(1, 21, 0, 0) Then
|
||||
ElseIf MinVer >= New Version(1, 21) Then
|
||||
JavaCode = 21
|
||||
If Not JavaDownloadConfirm("Java 21") Then Throw New Exception("$$")
|
||||
ElseIf MinVer >= New Version(1, 9, 0, 0) Then
|
||||
ElseIf MinVer >= New Version(1, 9) Then
|
||||
JavaCode = 17
|
||||
If Not JavaDownloadConfirm("Java 17") Then Throw New Exception("$$")
|
||||
ElseIf MaxVer < New Version(1, 8, 0, 0) Then
|
||||
ElseIf MaxVer < New Version(1, 8) Then
|
||||
JavaCode = 7
|
||||
If Not JavaDownloadConfirm("Java 7", True) Then Throw New Exception("$$")
|
||||
If McVersionCurrent.Version.HasForge Then
|
||||
MyMsgBox("你需要先安装 LegacyJavaFixer Mod，或自行安装 Java 7，然后才能启动该版本。", "未找到 Java")
|
||||
Else
|
||||
If Not JavaDownloadConfirm("Java 7", True) Then Throw New Exception("$$")
|
||||
End If
|
||||
ElseIf MinVer > New Version(1, 8, 0, 140) AndAlso MaxVer < New Version(1, 8, 0, 321) Then
|
||||
JavaCode = "8u141"
|
||||
If Not JavaDownloadConfirm("Java 8.0.141 ~ 8.0.320", True) Then Throw New Exception("$$")
|
||||
@@ -1273,7 +1300,7 @@ Retry:
|
||||
'检查下载结果
|
||||
If JavaSearchLoader.State <> LoadState.Loading Then JavaSearchLoader.State = LoadState.Waiting '2872#
|
||||
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
|
||||
If Task.IsAborted Then Exit Sub
|
||||
If Task.IsAborted Then Return
|
||||
If McLaunchJavaSelected IsNot Nothing Then
|
||||
McLaunchLog("选择的 Java：" & McLaunchJavaSelected.ToString)
|
||||
Else
|
||||
@@ -1350,22 +1377,14 @@ Retry:
|
||||
Arguments += " " & McLaunchArgumentsGameNew(McVersionCurrent)
|
||||
McLaunchLog("新版 Game 参数获取成功")
|
||||
End If
|
||||
'编码参数（#5818、#5892）
|
||||
'编码参数（#4700、#5892、#5909）
|
||||
If McLaunchJavaSelected.VersionCode >= 18 Then 'Dfile.encoding 需要放在 Dstdout.encoding 后面（#6934）
|
||||
If Not Arguments.Contains("-Dfile.encoding=") Then Arguments = "-Dfile.encoding=COMPAT " & Arguments
|
||||
End If
|
||||
If McLaunchJavaSelected.VersionCode > 8 Then
|
||||
If Not Arguments.Contains("-Dfile.encoding=") Then Arguments += " -Dfile.encoding=UTF-8"
|
||||
If Not Arguments.Contains("-Dstdout.encoding=") Then Arguments += " -Dstdout.encoding=UTF-8"
|
||||
If Not Arguments.Contains("-Dstderr.encoding=") Then Arguments += " -Dstderr.encoding=UTF-8"
|
||||
If Not Arguments.Contains("-Dstdout.encoding=") Then Arguments = "-Dstdout.encoding=UTF-8 " & Arguments
|
||||
If Not Arguments.Contains("-Dstderr.encoding=") Then Arguments = "-Dstderr.encoding=UTF-8 " & Arguments
|
||||
End If
|
||||
'替换参数
|
||||
Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader)
|
||||
If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then
|
||||
'若自定义信息为空，则去掉该部分
|
||||
Arguments = Arguments.Replace(" --versionType ${version_type}", "")
|
||||
ReplaceArguments("${version_type}") = """"""
|
||||
End If
|
||||
For Each entry As KeyValuePair(Of String, String) In ReplaceArguments
|
||||
Arguments = Arguments.Replace(entry.Key, If(entry.Value.Contains(" ") OrElse entry.Value.Contains(":\"), """" & entry.Value & """", entry.Value))
|
||||
Next
|
||||
'MJSB
|
||||
Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""")
|
||||
'全屏
|
||||
@@ -1374,31 +1393,47 @@ Retry:
|
||||
For Each Arg In CurrentLaunchOptions.ExtraArgs
|
||||
Arguments += " " & Arg.Trim
|
||||
Next
|
||||
'自定义
|
||||
Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent)
|
||||
Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)
|
||||
'进行参数替换
|
||||
Dim ReplaceArguments = McLaunchArgumentsReplace(McVersionCurrent, Loader)
|
||||
If String.IsNullOrWhiteSpace(ReplaceArguments("${version_type}")) Then
|
||||
'若自定义信息为空，则去掉该部分
|
||||
Arguments = Arguments.Replace(" --versionType ${version_type}", "")
|
||||
ReplaceArguments("${version_type}") = """"""
|
||||
End If
|
||||
Dim FinalArguments As String = ""
|
||||
For Each Argument In Arguments.Split(" ")
|
||||
For Each Entry As KeyValuePair(Of String, String) In ReplaceArguments
|
||||
Argument = Argument.Replace(Entry.Key, Entry.Value)
|
||||
Next
|
||||
If (Argument.Contains(" ") OrElse Argument.Contains(":\")) AndAlso Not Argument.EndsWithF("""") Then Argument = $"""{Argument}"""
|
||||
FinalArguments += Argument & " "
|
||||
Next
|
||||
FinalArguments = FinalArguments.TrimEnd
|
||||
'进服
|
||||
Dim Server As String = If(String.IsNullOrEmpty(CurrentLaunchOptions.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), CurrentLaunchOptions.ServerIp)
|
||||
If Server.Length > 0 Then
|
||||
If McVersionCurrent.ReleaseTime > New Date(2023, 4, 4) Then
|
||||
'QuickPlay
|
||||
Arguments += $" --quickPlayMultiplayer ""{Server}"""
|
||||
FinalArguments += $" --quickPlayMultiplayer ""{Server}"""
|
||||
Else
|
||||
'老版本
|
||||
If Server.Contains(":") Then
|
||||
'包含端口号
|
||||
Arguments += " --server " & Server.Split(":")(0) & " --port " & Server.Split(":")(1)
|
||||
FinalArguments += $" --server {Server.Split(":")(0)} --port {Server.Split(":")(1)}"
|
||||
Else
|
||||
'不包含端口号
|
||||
Arguments += " --server " & Server & " --port 25565"
|
||||
FinalArguments += $" --server {Server} --port 25565"
|
||||
End If
|
||||
If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容，有概率导致材质丢失甚至游戏崩溃！", HintType.Critical)
|
||||
End If
|
||||
End If
|
||||
'自定义
|
||||
Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent)
|
||||
Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)
|
||||
'输出
|
||||
McLaunchLog("Minecraft 启动参数：")
|
||||
McLaunchLog(Arguments)
|
||||
McLaunchArgument = Arguments
|
||||
McLaunchLog(FinalArguments)
|
||||
McLaunchArgument = FinalArguments
|
||||
End Sub
|
||||
|
||||
'Jvm 部分（第一段）
|
||||
@@ -1424,11 +1459,12 @@ Retry:
|
||||
End If
|
||||
'Authlib-Injector
|
||||
If McLoginLoader.Output.Type = "Auth" Then
|
||||
If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#）
|
||||
Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
|
||||
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
|
||||
Setup.Get("VersionServerAuthServer", McVersionCurrent))
|
||||
Try
|
||||
Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
|
||||
Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8)
|
||||
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
|
||||
" -Dauthlibinjector.side=client" &
|
||||
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
|
||||
@@ -1451,6 +1487,9 @@ Retry:
|
||||
DataList.Add(Version.JsonObject("mainClass"))
|
||||
End If
|
||||
|
||||
'处理 DataList 的换行符
|
||||
DataList = DataList.Select(Function(d) d.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ").Trim).ToList
|
||||
|
||||
Return Join(DataList, " ")
|
||||
End Function
|
||||
Private Function McLaunchArgumentsJvmNew(Version As McVersion) As String
|
||||
@@ -1493,11 +1532,10 @@ NextVersion:
|
||||
End If
|
||||
'Authlib-Injector
|
||||
If McLoginLoader.Output.Type = "Auth" Then
|
||||
Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
|
||||
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
|
||||
Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent))
|
||||
If McLaunchJavaSelected.VersionCode >= 6 Then DataList.Add("-Djavax.net.ssl.trustStoreType=WINDOWS-ROOT") '信任系统根证书（5252#）
|
||||
Dim Server As String = Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)
|
||||
Try
|
||||
Dim Response As String = NetGetCodeByRequestRetry(Server, Encoding.UTF8)
|
||||
Dim Response As String = NetRequestByClientRetry(Server, Encoding:=Encoding.UTF8)
|
||||
DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
|
||||
" -Dauthlibinjector.side=client" &
|
||||
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
|
||||
@@ -1517,7 +1555,7 @@ NextVersion:
|
||||
'如果不合并，会导致 Forge 1.17 启动无效，它有两个 --add-exports，进一步导致其中一个在后面被去重
|
||||
Dim DeDuplicateDataList As New List(Of String)
|
||||
For i = 0 To DataList.Count - 1
|
||||
Dim CurrentEntry As String = DataList(i)
|
||||
Dim CurrentEntry As String = DataList(i).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, " ").Trim
|
||||
If DataList(i).StartsWithF("-") Then
|
||||
Do While i < DataList.Count - 1
|
||||
If DataList(i + 1).StartsWithF("-") Then
|
||||
@@ -1531,10 +1569,8 @@ NextVersion:
|
||||
DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu="))
|
||||
Next
|
||||
|
||||
'#3511 的清理
|
||||
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M")
|
||||
|
||||
'去重
|
||||
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M") '#3511 的清理
|
||||
Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ")
|
||||
|
||||
'添加 MainClass
|
||||
@@ -1671,20 +1707,21 @@ NextVersion:
|
||||
GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken)
|
||||
GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken)
|
||||
GameArguments.Add("${user_type}", "msa") '#1221
|
||||
GameArguments.Add("${primary_jar}", Version.Path & Version.Name & ".jar") '#6942
|
||||
|
||||
'窗口尺寸参数
|
||||
Dim GameSize As Size
|
||||
Select Case Setup.Get("LaunchArgumentWindowType")
|
||||
Case 2
|
||||
Case 2 '与启动器尺寸一致
|
||||
Dim Result As Size
|
||||
RunInUiWait(Sub() Result = New Size(GetPixelSize(FrmMain.PanForm.ActualWidth), GetPixelSize(FrmMain.PanForm.ActualHeight)))
|
||||
GameSize = Result
|
||||
Case 3
|
||||
GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth") - 2), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight") - 2))
|
||||
GameSize.Height -= 29.5 * DPI / 96 '标题栏高度
|
||||
Case 3 '自定义
|
||||
GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth")), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight")))
|
||||
Case Else
|
||||
GameSize = New Size(875 - 2, 540 - 2)
|
||||
GameSize = New Size(854, 480)
|
||||
End Select
|
||||
GameSize.Height -= 29.5 * DPI / 96 '标题栏高度
|
||||
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso
|
||||
McLaunchJavaSelected.VersionCode <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso
|
||||
Not McVersionCurrent.Version.HasOptiFine AndAlso Not McVersionCurrent.Version.HasForge Then
|
||||
@@ -1713,7 +1750,7 @@ NextVersion:
|
||||
CpStrings.Add(Library.LocalPath)
|
||||
End If
|
||||
Next
|
||||
If OptiFineCp IsNot Nothing Then CpStrings.Insert(CpStrings.Count - 2, OptiFineCp)
|
||||
If OptiFineCp IsNot Nothing Then CpStrings.Insert(CpStrings.Count - 2, OptiFineCp) 'OptiFine 的总是需要放到倒数第二位
|
||||
GameArguments.Add("${classpath}", Join(CpStrings.Select(Function(c) ShortenPath(c)), ";"))
|
||||
|
||||
Return GameArguments
|
||||
@@ -1759,7 +1796,7 @@ NextVersion:
|
||||
File.Delete(FilePath)
|
||||
Catch ex As UnauthorizedAccessException
|
||||
McLaunchLog("删除原 dll 访问被拒绝，这通常代表有一个 MC 正在运行，跳过解压：" & FilePath)
|
||||
McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex))
|
||||
McLaunchLog("实际的错误信息：" & ex.GetDetail())
|
||||
Exit For
|
||||
End Try
|
||||
End If
|
||||
@@ -1779,8 +1816,8 @@ NextVersion:
|
||||
File.Delete(FileName)
|
||||
Catch ex As UnauthorizedAccessException
|
||||
McLaunchLog("删除多余文件访问被拒绝，跳过删除步骤")
|
||||
McLaunchLog("实际的错误信息：" & GetExceptionSummary(ex))
|
||||
Exit Sub
|
||||
McLaunchLog("实际的错误信息：" & ex.GetDetail())
|
||||
Return
|
||||
End Try
|
||||
Next
|
||||
|
||||
@@ -1790,9 +1827,9 @@ NextVersion:
|
||||
''' </summary>
|
||||
Private Function GetNativesFolder() As String
|
||||
Dim Result As String = McVersionCurrent.Path & McVersionCurrent.Name & "-natives"
|
||||
If IsGBKEncoding OrElse Result.IsASCII() Then Return Result
|
||||
If IsGBKEncoding OrElse Result.IsASCII() Then Return ShortenPath(Result)
|
||||
Result = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\bin\natives"
|
||||
If Result.IsASCII() Then Return Result
|
||||
If Result.IsASCII() Then Return ShortenPath(Result)
|
||||
Return OsDrive & "ProgramData\PCL\natives"
|
||||
End Function
|
||||
|
||||
@@ -1805,7 +1842,7 @@ NextVersion:
|
||||
'要求 Java 使用高性能显卡
|
||||
If Setup.Get("LaunchAdvanceGraphicCard") Then
|
||||
Try
|
||||
SetGPUPreference(McLaunchJavaSelected.PathJavaw)
|
||||
SetGPUPreference(McLaunchJavaSelected.PathJava)
|
||||
SetGPUPreference(PathWithName)
|
||||
Catch ex As Exception
|
||||
If IsAdmin() Then
|
||||
@@ -1813,7 +1850,7 @@ NextVersion:
|
||||
Else
|
||||
Log(ex, "直接调整显卡设置失败，将以管理员权限重启 PCL 再次尝试")
|
||||
Try
|
||||
If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJavaw}""") = ProcessReturnValues.TaskDone Then
|
||||
If RunAsAdmin($"--gpu ""{McLaunchJavaSelected.PathJava}""") = ProcessReturnValues.TaskDone Then
|
||||
McLaunchLog("以管理员权限重启 PCL 并调整显卡设置成功")
|
||||
Else
|
||||
Throw New Exception("调整过程中出现异常")
|
||||
@@ -2099,21 +2136,20 @@ IgnoreCustomSkin:
|
||||
"@echo off" & vbCrLf &
|
||||
$"title 启动 - {McVersionCurrent.Name}" & vbCrLf &
|
||||
"echo 游戏正在启动，请稍候。" & vbCrLf &
|
||||
$"set APPDATA=""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf &
|
||||
$"cd /D ""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf &
|
||||
CustomCommandGlobal & vbCrLf &
|
||||
CustomCommandVersion & vbCrLf &
|
||||
$"""{McLaunchJavaSelected.PathJava}"" {McLaunchArgument}" & vbCrLf &
|
||||
"echo 游戏已退出。" & vbCrLf &
|
||||
"pause"
|
||||
WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString, "F"),
|
||||
Encoding:=If(Encoding.Default.Equals(Encoding.UTF8), Encoding.UTF8, Encoding.GetEncoding("GB18030")))
|
||||
WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), FilterAccessToken(CmdString, "F"),
|
||||
Encoding:=If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Encoding.Default))
|
||||
If CurrentLaunchOptions.SaveBatch IsNot Nothing Then
|
||||
McLaunchLog("导出启动脚本完成，强制结束启动过程")
|
||||
AbortHint = "导出启动脚本成功！"
|
||||
OpenExplorer(CurrentLaunchOptions.SaveBatch)
|
||||
Loader.Parent.Abort()
|
||||
Exit Sub '导出脚本完成
|
||||
Return '导出脚本完成
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "输出启动脚本失败")
|
||||
@@ -2123,14 +2159,15 @@ IgnoreCustomSkin:
|
||||
'执行自定义命令
|
||||
If CustomCommandGlobal <> "" Then
|
||||
McLaunchLog("正在执行全局自定义命令：" & CustomCommandGlobal)
|
||||
Dim CustomProcess As New Process
|
||||
Dim CustomProcess As Process = Nothing
|
||||
Try
|
||||
CustomProcess.StartInfo.FileName = "cmd.exe"
|
||||
CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandGlobal & """"
|
||||
CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder)
|
||||
CustomProcess.StartInfo.UseShellExecute = False
|
||||
CustomProcess.StartInfo.CreateNoWindow = True
|
||||
CustomProcess.Start()
|
||||
CustomProcess = StartProcess(New ProcessStartInfo With {
|
||||
.FileName = "cmd.exe",
|
||||
.Arguments = $"/c ""{CustomCommandGlobal}""",
|
||||
.WorkingDirectory = PathMcFolder,
|
||||
.UseShellExecute = False,
|
||||
.CreateNoWindow = True
|
||||
})
|
||||
If Setup.Get("LaunchAdvanceRunWait") Then
|
||||
Do Until CustomProcess.HasExited OrElse Loader.IsAborted
|
||||
Thread.Sleep(10)
|
||||
@@ -2139,7 +2176,7 @@ IgnoreCustomSkin:
|
||||
Catch ex As Exception
|
||||
Log(ex, "执行全局自定义命令失败", LogLevel.Hint)
|
||||
Finally
|
||||
If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then
|
||||
If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsAborted Then
|
||||
McLaunchLog("由于取消启动，已强制结束自定义命令 CMD 进程") '#1183
|
||||
CustomProcess.Kill()
|
||||
End If
|
||||
@@ -2147,14 +2184,15 @@ IgnoreCustomSkin:
|
||||
End If
|
||||
If CustomCommandVersion <> "" Then
|
||||
McLaunchLog("正在执行版本自定义命令：" & CustomCommandVersion)
|
||||
Dim CustomProcess As New Process
|
||||
Dim CustomProcess As Process = Nothing
|
||||
Try
|
||||
CustomProcess.StartInfo.FileName = "cmd.exe"
|
||||
CustomProcess.StartInfo.Arguments = "/c """ & CustomCommandVersion & """"
|
||||
CustomProcess.StartInfo.WorkingDirectory = ShortenPath(PathMcFolder)
|
||||
CustomProcess.StartInfo.UseShellExecute = False
|
||||
CustomProcess.StartInfo.CreateNoWindow = True
|
||||
CustomProcess.Start()
|
||||
CustomProcess = StartProcess(New ProcessStartInfo With {
|
||||
.FileName = "cmd.exe",
|
||||
.Arguments = $"/c ""{CustomCommandVersion}""",
|
||||
.WorkingDirectory = PathMcFolder,
|
||||
.UseShellExecute = False,
|
||||
.CreateNoWindow = True
|
||||
})
|
||||
If Setup.Get("VersionAdvanceRunWait", Version:=McVersionCurrent) Then
|
||||
Do Until CustomProcess.HasExited OrElse Loader.IsAborted
|
||||
Thread.Sleep(10)
|
||||
@@ -2163,7 +2201,7 @@ IgnoreCustomSkin:
|
||||
Catch ex As Exception
|
||||
Log(ex, "执行版本自定义命令失败", LogLevel.Hint)
|
||||
Finally
|
||||
If Not CustomProcess.HasExited AndAlso Loader.IsAborted Then
|
||||
If CustomProcess IsNot Nothing AndAlso Not CustomProcess.HasExited AndAlso Loader.IsAborted Then
|
||||
McLaunchLog("由于取消启动，已强制结束自定义命令 CMD 进程") '#1183
|
||||
CustomProcess.Kill()
|
||||
End If
|
||||
@@ -2174,8 +2212,7 @@ IgnoreCustomSkin:
|
||||
Private Sub McLaunchRun(Loader As LoaderTask(Of Integer, Process))
|
||||
|
||||
'启动信息
|
||||
Dim GameProcess = New Process()
|
||||
Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJavaw)
|
||||
Dim StartInfo As New ProcessStartInfo(McLaunchJavaSelected.PathJava) '使用 javaw.exe 会导致 #6263
|
||||
|
||||
'设置环境变量
|
||||
Dim Paths As New List(Of String)(StartInfo.EnvironmentVariables("Path").Split(";"))
|
||||
@@ -2184,23 +2221,20 @@ IgnoreCustomSkin:
|
||||
StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder)
|
||||
|
||||
'设置其他参数
|
||||
StartInfo.StandardErrorEncoding = If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Nothing)
|
||||
StartInfo.StandardOutputEncoding = If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Nothing)
|
||||
StartInfo.WorkingDirectory = ShortenPath(McVersionCurrent.PathIndie)
|
||||
StartInfo.WorkingDirectory = McVersionCurrent.PathIndie
|
||||
StartInfo.UseShellExecute = False
|
||||
StartInfo.RedirectStandardOutput = True
|
||||
StartInfo.RedirectStandardError = True
|
||||
StartInfo.CreateNoWindow = False
|
||||
StartInfo.CreateNoWindow = True
|
||||
StartInfo.Arguments = McLaunchArgument
|
||||
GameProcess.StartInfo = StartInfo
|
||||
|
||||
'开始进程
|
||||
GameProcess.Start()
|
||||
McLaunchLog("已启动游戏进程：" & McLaunchJavaSelected.PathJavaw)
|
||||
Dim GameProcess = StartProcess(StartInfo)
|
||||
McLaunchLog("已启动游戏进程：" & McLaunchJavaSelected.PathJava)
|
||||
If Loader.IsAborted Then
|
||||
McLaunchLog("由于取消启动，已强制结束游戏进程") '#1631
|
||||
GameProcess.Kill()
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
Loader.Output = GameProcess
|
||||
McLaunchProcess = GameProcess
|
||||
|
||||
@@ -86,7 +86,7 @@ Public Module ModMinecraft
|
||||
Next
|
||||
If Not Renamed Then CacheMcFolderList.Add(New McFolder With {.Name = Name, .Path = Path, .Type = McFolderType.Custom})
|
||||
Catch ex As Exception
|
||||
MyMsgBox("失效的 Minecraft 文件夹：" & vbCrLf & Path & vbCrLf & vbCrLf & GetExceptionSummary(ex), "Minecraft 文件夹失效", IsWarn:=True)
|
||||
MyMsgBox("失效的 Minecraft 文件夹：" & vbCrLf & Path & vbCrLf & vbCrLf & ex.GetBrief(), "Minecraft 文件夹失效", IsWarn:=True)
|
||||
Log(ex, $"无法访问 Minecraft 文件夹 {Path}")
|
||||
End Try
|
||||
Next
|
||||
@@ -127,7 +127,7 @@ Public Module ModMinecraft
|
||||
''' </summary>
|
||||
Public Sub McFolderLauncherProfilesJsonCreate(Folder As String)
|
||||
Try
|
||||
If File.Exists(Folder & "launcher_profiles.json") Then Exit Sub
|
||||
If File.Exists(Folder & "launcher_profiles.json") Then Return
|
||||
Dim ResultJson As String =
|
||||
"{
|
||||
""profiles"": {
|
||||
@@ -165,12 +165,12 @@ Public Module ModMinecraft
|
||||
Return _McVersionCurrent
|
||||
End Get
|
||||
Set(value As McVersion)
|
||||
If ReferenceEquals(_McVersionLast, value) Then Exit Property
|
||||
If ReferenceEquals(_McVersionLast, value) Then Return
|
||||
_McVersionCurrent = value '由于有可能是 Nothing，导致无法初始化，才得这样弄一圈
|
||||
_McVersionLast = value
|
||||
If value Is Nothing Then Exit Property
|
||||
'重置缓存的 Mod 文件夹
|
||||
PageDownloadCompDetail.CachedFolder = Nothing
|
||||
If value Is Nothing Then Return
|
||||
'重置缓存的下载文件夹
|
||||
PageDownloadCompDetail.CachedFolder.Clear()
|
||||
'统一通行证重判
|
||||
If AniControlEnabled = 0 AndAlso
|
||||
Setup.Get("VersionServerNide", Version:=value) <> Setup.Get("CacheNideServer") AndAlso
|
||||
@@ -207,46 +207,44 @@ Public Module ModMinecraft
|
||||
''' </summary>
|
||||
Public ReadOnly Property PathIndie As String
|
||||
Get
|
||||
InitPathIndie(Modable)
|
||||
If Setup.IsUnset("VersionArgumentIndieV2", Version:=Me) Then
|
||||
If Not IsLoaded Then Load()
|
||||
'决定该版本是否应该被隔离
|
||||
Dim ShouldBeIndie =
|
||||
Function() As Boolean
|
||||
'从老的版本独立设置中迁移：-1 未决定，0 使用全局设置，1 手动开启，2 手动关闭
|
||||
If Not Setup.IsUnset("VersionArgumentIndie", Version:=Me) AndAlso Setup.Get("VersionArgumentIndie", Version:=Me) > 0 Then
|
||||
Log($"[Minecraft] 版本隔离初始化（{Name}）：从老的版本独立设置中迁移")
|
||||
Return Setup.Get("VersionArgumentIndie", Version:=Me) = 1
|
||||
End If
|
||||
'若版本文件夹下包含 mods 或 saves 文件夹，则自动开启版本隔离
|
||||
Dim ModFolder As New DirectoryInfo(Path & "mods\")
|
||||
Dim SaveFolder As New DirectoryInfo(Path & "saves\")
|
||||
If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Any) OrElse (SaveFolder.Exists AndAlso SaveFolder.EnumerateDirectories.Any) Then
|
||||
Log($"[Minecraft] 版本隔离初始化（{Name}）：版本文件夹下存在 mods 或 saves 文件夹，自动开启")
|
||||
Return True
|
||||
End If
|
||||
'根据全局的默认设置决定是否隔离
|
||||
Dim IsRelease As Boolean = State <> McVersionState.Fool AndAlso State <> McVersionState.Old AndAlso State <> McVersionState.Snapshot
|
||||
Log($"[Minecraft] 版本隔离初始化（{Name}）：从全局默认设置中（{Setup.Get("LaunchArgumentIndieV2")}）判断，State {GetStringFromEnum(State)}，IsRelease {IsRelease}，Modable {Modable}")
|
||||
Select Case Setup.Get("LaunchArgumentIndieV2")
|
||||
Case 0 '关闭
|
||||
Return False
|
||||
Case 1 '仅隔离可安装 Mod 的版本
|
||||
Return Modable
|
||||
Case 2 '仅隔离非正式版
|
||||
Return Not IsRelease
|
||||
Case 3 '隔离非正式版与可安装 Mod 的版本
|
||||
Return Not IsRelease OrElse Modable
|
||||
Case Else '隔离所有版本
|
||||
Return True
|
||||
End Select
|
||||
End Function
|
||||
Setup.Set("VersionArgumentIndieV2", ShouldBeIndie(), Version:=Me)
|
||||
End If
|
||||
Return If(Setup.Get("VersionArgumentIndieV2", Version:=Me), Path, PathMcFolder)
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' 决定该版本是否应该被隔离。
|
||||
''' </summary>
|
||||
Public Sub InitPathIndie(Modable As Boolean)
|
||||
If Not Setup.IsUnset("VersionArgumentIndieV2", Version:=Me) Then Return
|
||||
Dim ShouldBeIndie =
|
||||
Function() As Boolean
|
||||
'从老的版本独立设置中迁移：-1 未决定，0 使用全局设置，1 手动开启，2 手动关闭
|
||||
If Not Setup.IsUnset("VersionArgumentIndie", Version:=Me) AndAlso Setup.Get("VersionArgumentIndie", Version:=Me) > 0 Then
|
||||
Log($"[Minecraft] 版本隔离初始化（{Name}）：从老的版本独立设置中迁移")
|
||||
Return Setup.Get("VersionArgumentIndie", Version:=Me) = 1
|
||||
End If
|
||||
'若版本文件夹下包含 mods 或 saves 文件夹，则自动开启版本隔离
|
||||
Dim ModFolder As New DirectoryInfo(Path & "mods\")
|
||||
Dim SaveFolder As New DirectoryInfo(Path & "saves\")
|
||||
If (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Any) OrElse (SaveFolder.Exists AndAlso SaveFolder.EnumerateFiles.Any) Then
|
||||
Log($"[Minecraft] 版本隔离初始化（{Name}）：版本文件夹下存在 mods 或 saves 文件夹，自动开启")
|
||||
Return True
|
||||
End If
|
||||
'根据全局的默认设置决定是否隔离
|
||||
Log($"[Minecraft] 版本隔离初始化（{Name}）：从全局默认设置中（{Setup.Get("LaunchArgumentIndieV2")}）判断")
|
||||
Select Case Setup.Get("LaunchArgumentIndieV2")
|
||||
Case 0 '关闭
|
||||
Return False
|
||||
Case 1 '仅隔离可安装 Mod 的版本
|
||||
Return Modable
|
||||
Case 2 '仅隔离非正式版
|
||||
Return State = McVersionState.Fool OrElse State = McVersionState.Old OrElse State = McVersionState.Snapshot
|
||||
Case 3 '隔离非正式版与可安装 Mod 的版本
|
||||
Return Modable OrElse State = McVersionState.Fool OrElse State = McVersionState.Old OrElse State = McVersionState.Snapshot
|
||||
Case Else '隔离所有版本
|
||||
Return True
|
||||
End Select
|
||||
End Function
|
||||
Setup.Set("VersionArgumentIndieV2", ShouldBeIndie(), Version:=Me)
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 该版本的版本文件夹名称。
|
||||
@@ -318,14 +316,6 @@ Public Module ModMinecraft
|
||||
_Version.McName = "pending"
|
||||
GoTo VersionSearchFinish
|
||||
End If
|
||||
'从 JumpLoader 信息中获取版本号
|
||||
If HasJumpLoader Then
|
||||
Try
|
||||
_Version.McName = JsonObject("jumploader")("jars")("minecraft")(0)("gameVersion")
|
||||
GoTo VersionSearchFinish
|
||||
Catch
|
||||
End Try
|
||||
End If
|
||||
'从 PCL 下载的版本信息中获取版本号
|
||||
If JsonObject("clientVersion") IsNot Nothing Then
|
||||
_Version.McName = JsonObject("clientVersion")
|
||||
@@ -382,7 +372,6 @@ Public Module ModMinecraft
|
||||
_Version.McName = Regex
|
||||
GoTo VersionSearchFinish
|
||||
End If
|
||||
'FUTURE: [Quilt 支持] 从 Quilt 版本中获取版本号
|
||||
'从 jar 项中获取版本号
|
||||
If JsonObject("jar") IsNot Nothing Then
|
||||
_Version.McName = JsonObject("jar").ToString
|
||||
@@ -432,7 +421,7 @@ VersionSearchFinish:
|
||||
_Version.McCodeMain = If(SplitResult.Length <= 2, Val(SplitResult), "0")
|
||||
SplitResult = If(SplitVersion.Count >= 3, SplitVersion(2), "0")
|
||||
_Version.McCodeSub = If(SplitResult.Length <= 2, Val(SplitResult), "0")
|
||||
ElseIf _Version.McName.Contains("w") OrElse _Version.McName = "pending" Then
|
||||
ElseIf (Not IsVersionNameLikeRelease(_Version.McName)) OrElse _Version.McName = "pending" Then
|
||||
_Version.McCodeMain = 99
|
||||
_Version.McCodeSub = 99
|
||||
End If
|
||||
@@ -451,6 +440,33 @@ VersionSearchFinish:
|
||||
''' </summary>
|
||||
Public ReleaseTime As New Date(1970, 1, 1, 15, 0, 0)
|
||||
|
||||
''' <summary>
|
||||
''' 获取该版本的 JSON 路径。
|
||||
''' </summary>
|
||||
Public Function GetJsonPath() As String
|
||||
Dim JsonPath As String = Path & Name & ".json"
|
||||
If Not File.Exists(JsonPath) Then
|
||||
'尝试寻找 JSON 文件
|
||||
JsonPath = Nothing
|
||||
For Each JsonCandidatePath In Directory.GetFiles(Path, "*.json")
|
||||
Try
|
||||
Dim JsonCandidate As JObject = GetJson(ReadFile(JsonCandidatePath))
|
||||
If Not JsonCandidate.ContainsKey("mainClass") Then Continue For
|
||||
If Not JsonCandidate.ContainsKey("type") Then Continue For
|
||||
If Not JsonCandidate.ContainsKey("id") Then Continue For
|
||||
Catch
|
||||
End Try
|
||||
JsonPath = JsonCandidatePath
|
||||
Exit For
|
||||
Next
|
||||
If JsonPath Is Nothing Then
|
||||
Throw New Exception($"未找到版本 JSON 文件：{Path}{Name}.json")
|
||||
Else
|
||||
Log("[Minecraft] 未找到同名版本 JSON，自动换用 " & JsonPath, LogLevel.Debug)
|
||||
End If
|
||||
End If
|
||||
Return JsonPath
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 该版本的 Json 文本。
|
||||
''' </summary>
|
||||
@@ -463,17 +479,7 @@ VersionSearchFinish:
|
||||
Return TrimedJson.StartsWithF("{") AndAlso TrimedJson.EndsWithF("}")
|
||||
End Function
|
||||
If _JsonText Is Nothing Then
|
||||
Dim JsonPath As String = Path & Name & ".json"
|
||||
If Not File.Exists(JsonPath) Then
|
||||
'如果文件夹下只有一个 JSON 文件，则将其作为版本 JSON
|
||||
Dim JsonFiles As String() = Directory.GetFiles(Path, "*.json")
|
||||
If JsonFiles.Count = 1 Then
|
||||
JsonPath = JsonFiles(0)
|
||||
Log("[Minecraft] 未找到同名版本 JSON，自动换用 " & JsonPath, LogLevel.Debug)
|
||||
Else
|
||||
Throw New Exception($"未找到版本 JSON 文件：{Path}{Name}.json")
|
||||
End If
|
||||
End If
|
||||
Dim JsonPath As String = GetJsonPath()
|
||||
_JsonText = ReadFile(JsonPath)
|
||||
'如果 ReadFile 失败会返回空字符串；这可能是由于文件被临时占用，故延时后重试
|
||||
If Not FastJsonCheck(_JsonText) Then
|
||||
@@ -551,9 +557,15 @@ Recheck:
|
||||
'继续循环
|
||||
If Inherit.InheritVersion = InheritVersion Then Throw New Exception("版本依赖项出现嵌套：" & InheritVersion)
|
||||
InheritVersion = Inherit.InheritVersion
|
||||
'合并
|
||||
'合并 Libraries 项：子版本放在前面，父版本放在后面（5978#：如果多个 jar 包中含有相同的类，Java 8 和之前的版本按照 -cp 指定的顺序选择第一个）
|
||||
Dim CurrentLib As JArray = _JsonObject("libraries").DeepClone()
|
||||
For Each LibToken In Inherit.JsonObject("libraries")
|
||||
CurrentLib.Add(LibToken)
|
||||
Next
|
||||
'合并其他项：子版本优先于父版本
|
||||
Inherit.JsonObject.Merge(_JsonObject)
|
||||
_JsonObject = Inherit.JsonObject
|
||||
_JsonObject("libraries") = CurrentLib
|
||||
GoTo Recheck
|
||||
End If
|
||||
Catch ex As Exception
|
||||
@@ -562,25 +574,6 @@ Recheck:
|
||||
Catch ex As Exception
|
||||
Throw New Exception("初始化版本 JSON 时失败（" & If(Name, "null") & "）", ex)
|
||||
End Try
|
||||
Try
|
||||
'处理 JumpLoader
|
||||
If Text.Contains("minecraftforge") AndAlso File.Exists(PathIndie & "config\jumploader.json") Then
|
||||
For Each ModFile In Directory.EnumerateFiles(PathIndie & "mods")
|
||||
Dim FileName As String = GetFileNameFromPath(ModFile)
|
||||
If FileName.EndsWithF(".jar", True) AndAlso FileName.ContainsF("jumploader", True) Then
|
||||
Log("[Minecraft] 发现 JumpLoader 分支项：" & FileName)
|
||||
HasJumpLoader = True
|
||||
Exit For
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
If HasJumpLoader Then
|
||||
_JsonObject.Remove("jumploader")
|
||||
_JsonObject.Add("jumploader", GetJson(ReadFile(PathIndie & "config\jumploader.json")))
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "处理 JumpLoader 失败")
|
||||
End Try
|
||||
End If
|
||||
Return _JsonObject
|
||||
End Get
|
||||
@@ -601,10 +594,6 @@ Recheck:
|
||||
''' Json 是否为 HMCL 格式。
|
||||
''' </summary>
|
||||
Public Property IsHmclFormatJson As Boolean = False
|
||||
''' <summary>
|
||||
''' 是否包含 JumpLoader。
|
||||
''' </summary>
|
||||
Public Property HasJumpLoader As Boolean = False
|
||||
|
||||
''' <summary>
|
||||
''' 版本 jar 中的 version.json 文件对象。
|
||||
@@ -614,20 +603,18 @@ Recheck:
|
||||
Get
|
||||
If Not JsonVersionInited Then
|
||||
JsonVersionInited = True
|
||||
If File.Exists(Path & Name & ".jar") Then
|
||||
Try
|
||||
Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
|
||||
Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json")
|
||||
If VersionJson IsNot Nothing Then
|
||||
Using VersionJsonStream As New StreamReader(VersionJson.Open)
|
||||
_JsonVersion = GetJson(VersionJsonStream.ReadToEnd)
|
||||
End Using
|
||||
End If
|
||||
Try
|
||||
If Not File.Exists($"{Path}{Name}.jar") Then Exit Try
|
||||
Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
|
||||
Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json")
|
||||
If VersionJson Is Nothing Then Exit Try
|
||||
Using VersionJsonStream As New StreamReader(VersionJson.Open)
|
||||
_JsonVersion = GetJson(VersionJsonStream.ReadToEnd)
|
||||
End Using
|
||||
Catch ex As Exception
|
||||
Log(ex, "从版本 jar 中读取 version.json 失败")
|
||||
End Try
|
||||
End If
|
||||
End Using
|
||||
Catch ex As Exception
|
||||
Log(ex, $"从版本 jar 中读取 version.json 失败（{Path}{Name}.jar）")
|
||||
End Try
|
||||
End If
|
||||
Return _JsonVersion
|
||||
End Get
|
||||
@@ -708,7 +695,7 @@ Recheck:
|
||||
Catch ex As Exception
|
||||
Log(ex, "依赖版本检查出错（" & Name & "）")
|
||||
State = McVersionState.Error
|
||||
Info = "未知错误：" & GetExceptionSummary(ex)
|
||||
Info = "未知错误：" & ex.GetBrief()
|
||||
Return False
|
||||
End Try
|
||||
|
||||
@@ -748,7 +735,6 @@ Recheck:
|
||||
Version.HasLiteLoader = True
|
||||
End If
|
||||
'Fabric、Forge
|
||||
'FUTURE: [Quilt 支持] 确认这里的玩意儿对不对
|
||||
If RealJson.Contains("net.fabricmc:fabric-loader") OrElse RealJson.Contains("org.quiltmc:quilt-loader") Then
|
||||
State = McVersionState.Fabric
|
||||
Version.HasFabric = True
|
||||
@@ -822,7 +808,7 @@ ExitDataLoad:
|
||||
WriteIni(Path & "PCL\Setup.ini", "VersionOriginalSub", Version.McCodeSub)
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Info = "未知错误：" & GetExceptionSummary(ex)
|
||||
Info = "未知错误：" & ex.GetBrief()
|
||||
Logo = PathImage & "Blocks/RedstoneBlock.png"
|
||||
State = McVersionState.Error
|
||||
Log(ex, "加载版本失败（" & Name & "）", LogLevel.Feedback)
|
||||
@@ -859,7 +845,6 @@ ExitDataLoad:
|
||||
Info = "发生了未知错误，请向作者反馈此问题"
|
||||
End Select
|
||||
If Not State = McVersionState.Error Then
|
||||
If HasJumpLoader Then Info += ", JumpLoader"
|
||||
If Setup.Get("VersionServerLogin", Version:=Me) = 3 Then Info += ", 统一通行证验证"
|
||||
If Setup.Get("VersionServerLogin", Version:=Me) = 4 Then Info += ", Authlib 验证"
|
||||
End If
|
||||
@@ -919,6 +904,24 @@ ExitDataLoad:
|
||||
''' 原版次版本号，如 2（For 1.12.2），快照则固定为 99。不可用则为 -1。
|
||||
''' </summary>
|
||||
Public McCodeSub As Integer = -1
|
||||
''' <summary>
|
||||
''' 是否为非快照版，且读取到了一个有效的原版版本号。
|
||||
''' </summary>
|
||||
Public ReadOnly Property IsStandardVersion As Boolean
|
||||
Get
|
||||
Return McCodeMain > -1 AndAlso McCodeMain < 99 AndAlso McCodeSub > -1 AndAlso McCodeSub < 99
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' 标准的原版版本号。
|
||||
''' 若为快照版或没有有效版本号，则返回 0。
|
||||
''' </summary>
|
||||
Public ReadOnly Property McVersion As Version
|
||||
Get
|
||||
If Not IsStandardVersion Then Return New Version(0, 0, 0)
|
||||
Return New Version(1, McCodeMain, McCodeSub)
|
||||
End Get
|
||||
End Property
|
||||
|
||||
'OptiFine
|
||||
|
||||
@@ -986,7 +989,7 @@ ExitDataLoad:
|
||||
If ToString = "" Then
|
||||
Return "原版 " & McName
|
||||
Else
|
||||
Return McName & ToString & If(ModeDebug, " (" & SortCode & "#)", "")
|
||||
Return McName & ToString
|
||||
End If
|
||||
End Function
|
||||
|
||||
@@ -1152,7 +1155,7 @@ Reload:
|
||||
|
||||
'改变当前选择的版本
|
||||
OnLoaded:
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
If Loader.IsAborted Then Return
|
||||
If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then
|
||||
'尝试读取已储存的选择
|
||||
Dim SavedSelection As String = ReadIni(Path & "PCL.ini", "Version")
|
||||
@@ -1164,7 +1167,7 @@ OnLoaded:
|
||||
McVersionCurrent = Version
|
||||
Setup.Set("LaunchVersionSelect", McVersionCurrent.Name)
|
||||
Log("[Minecraft] 选择该文件夹储存的 Minecraft 版本：" & McVersionCurrent.Path)
|
||||
Exit Sub
|
||||
Return
|
||||
End If
|
||||
Next
|
||||
Next
|
||||
@@ -1183,6 +1186,7 @@ OnLoaded:
|
||||
If Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(200, 3000))
|
||||
Catch ex As ThreadInterruptedException
|
||||
Catch ex As Exception
|
||||
If Loader.IsAborted Then Return '#5617
|
||||
WriteIni(Path & "PCL.ini", "VersionCache", "") '要求下次重新加载
|
||||
Log(ex, "加载 .minecraft 版本列表失败", LogLevel.Feedback)
|
||||
End Try
|
||||
@@ -1556,7 +1560,7 @@ OnLoaded:
|
||||
''' 要求玩家选择一个皮肤文件，并进行相关校验。
|
||||
''' </summary>
|
||||
Public Function McSkinSelect() As McSkinInfo
|
||||
Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.webp)|*.png;*.jpg;*.webp", "选择皮肤文件")
|
||||
Dim FileName As String = SelectFile("皮肤文件(*.png;*.jpg;*.jpeg;*.webp)|*.png;*.jpg;*.jpeg;*.webp", "选择皮肤文件")
|
||||
|
||||
'验证有效性
|
||||
If FileName = "" Then Return New McSkinInfo With {.IsVaild = False}
|
||||
@@ -1589,11 +1593,11 @@ OnLoaded:
|
||||
''' <summary>
|
||||
''' 获取 Uuid 对应的皮肤文件地址，失败将抛出异常。
|
||||
''' </summary>
|
||||
Public Function McSkinGetAddress(Uuid As String, Type As String) As String
|
||||
If Uuid = "" Then Throw New Exception("Uuid 为空。")
|
||||
If Uuid.StartsWithF("00000") Then Throw New Exception("离线 Uuid 无正版皮肤文件。")
|
||||
Public Function McSkinGetAddress(UUID As String, Type As String) As String
|
||||
If UUID = "" Then Throw New Exception("UUID 为空。")
|
||||
If UUID.StartsWithF("00000") AndAlso Type <> "Auth" Then Throw New Exception("离线 UUID 无正版皮肤文件：" & UUID)
|
||||
'尝试读取缓存
|
||||
Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid)
|
||||
Dim CacheSkinAddress As String = ReadIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID)
|
||||
If Not CacheSkinAddress = "" Then Return CacheSkinAddress
|
||||
'获取皮肤地址
|
||||
Dim Url As String
|
||||
@@ -1607,7 +1611,7 @@ OnLoaded:
|
||||
Case Else
|
||||
Throw New ArgumentException("皮肤地址种类无效：" & If(Type, "null"))
|
||||
End Select
|
||||
Dim SkinString = NetGetCodeByRequestRetry(Url & Uuid)
|
||||
Dim SkinString = NetRequestByClientRetry(Url & UUID, RequireJson:=True)
|
||||
If SkinString = "" Then Throw New Exception("皮肤返回值为空，可能是未设置自定义皮肤的用户")
|
||||
'处理皮肤地址
|
||||
Dim SkinValue As String
|
||||
@@ -1628,11 +1632,12 @@ OnLoaded:
|
||||
If SkinJson("textures") Is Nothing OrElse SkinJson("textures")("skin") Is Nothing OrElse SkinJson("textures")("skin")("url") Is Nothing Then
|
||||
Throw New Exception("用户未设置自定义皮肤")
|
||||
Else
|
||||
SkinValue = SkinJson("textures")("skin")("url").ToString
|
||||
Dim SkinUrl As String = SkinJson("textures")("skin")("url").ToString
|
||||
SkinValue = If(SkinUrl.Contains("minecraft.net/"), SkinUrl.Replace("http://", "https://"), SkinUrl)
|
||||
End If
|
||||
'保存缓存
|
||||
WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue)
|
||||
Log("[Skin] UUID " & Uuid & " 对应的皮肤文件为 " & SkinValue)
|
||||
WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", UUID, SkinValue)
|
||||
Log("[Skin] UUID " & UUID & " 对应的皮肤文件为 " & SkinValue)
|
||||
Return SkinValue
|
||||
End Function
|
||||
|
||||
@@ -1645,9 +1650,9 @@ OnLoaded:
|
||||
Dim FileAddress As String = PathTemp & "Cache\Skin\" & GetHash(Address) & ".png"
|
||||
SyncLock McSkinDownloadLock
|
||||
If Not File.Exists(FileAddress) Then
|
||||
NetDownloadByClient(Address, FileAddress & NetDownloadEnd)
|
||||
NetDownloadByClient(Address, FileAddress & ".PCLDownloading")
|
||||
File.Delete(FileAddress)
|
||||
FileSystem.Rename(FileAddress & NetDownloadEnd, FileAddress)
|
||||
FileSystem.Rename(FileAddress & ".PCLDownloading", FileAddress)
|
||||
Log("[Minecraft] 皮肤下载成功：" & FileAddress)
|
||||
End If
|
||||
Return FileAddress
|
||||
@@ -1728,10 +1733,6 @@ OnLoaded:
|
||||
''' 原 Json 中的 Name 项。
|
||||
''' </summary>
|
||||
Public OriginalName As String
|
||||
''' <summary>
|
||||
''' 是否为 JumpLoader 项。
|
||||
''' </summary>
|
||||
Public IsJumpLoader As Boolean = False
|
||||
|
||||
Public Overrides Function ToString() As String
|
||||
Return If(IsNatives, "[Native] ", "") & GetString(Size) & " | " & LocalPath
|
||||
@@ -1794,7 +1795,7 @@ OnLoaded:
|
||||
|
||||
'获取当前支持库列表
|
||||
Log("[Minecraft] 获取支持库列表：" & Version.Name)
|
||||
McLibListGet = McLibListGetWithJson(Version.JsonObject, JumpLoaderFolder:=Version.PathIndie & ".jumploader\")
|
||||
Dim Result = McLibListGetWithJson(Version.JsonObject)
|
||||
|
||||
'需要添加原版 Jar
|
||||
If IncludeVersionJar Then
|
||||
@@ -1834,28 +1835,20 @@ OnLoaded:
|
||||
ClientSHA1 = Nothing
|
||||
End If
|
||||
'把所需的原版 Jar 添加进去
|
||||
McLibListGet.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1})
|
||||
Result.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1})
|
||||
End If
|
||||
|
||||
Return Result
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 获取 Minecraft 某一版本忽视继承的支持库列表，即结果中没有继承项。
|
||||
''' </summary>
|
||||
Public Function McLibListGetWithJson(JsonObject As JObject, Optional KeepSameNameDifferentVersionResult As Boolean = False, Optional CustomMcFolder As String = Nothing, Optional JumpLoaderFolder As String = Nothing) As List(Of McLibToken)
|
||||
Public Function McLibListGetWithJson(JsonObject As JObject, Optional KeepSameNameDifferentVersionResult As Boolean = False, Optional CustomMcFolder As String = Nothing) As List(Of McLibToken)
|
||||
CustomMcFolder = If(CustomMcFolder, PathMcFolder)
|
||||
Dim BasicArray As New List(Of McLibToken)
|
||||
|
||||
'添加基础 Json 项
|
||||
Dim AllLibs As JArray = JsonObject("libraries")
|
||||
'添加 JumpLoader Json 项
|
||||
If JsonObject("jumploader") IsNot Nothing AndAlso JsonObject("jumploader")("jars") IsNot Nothing AndAlso JsonObject("jumploader")("jars")("maven") IsNot Nothing Then
|
||||
For Each JumpLoaderToken In JsonObject("jumploader")("jars")("maven")
|
||||
AllLibs.Add(JumpLoaderToken)
|
||||
Next
|
||||
End If
|
||||
|
||||
'转换为 LibToken
|
||||
For Each Library As JObject In AllLibs.Children
|
||||
Dim BasicArray As New List(Of McLibToken)
|
||||
For Each Library As JObject In CType(JsonObject("libraries"), JArray).Children
|
||||
|
||||
'清理 null 项（BakaXL 会把没有的项序列化为 null，但会被 Newtonsoft 转换为 JValue，导致 Is Nothing = false；这导致了 #409）
|
||||
For i = Library.Properties.Count - 1 To 0 Step -1
|
||||
@@ -1865,14 +1858,6 @@ OnLoaded:
|
||||
'检查是否需要（Rules）
|
||||
If Not McJsonRuleCheck(Library("rules")) Then Continue For
|
||||
|
||||
'检查 JumpLoader
|
||||
Dim IsJumpLoader As Boolean = False
|
||||
If Library("mavenPath") IsNot Nothing Then
|
||||
IsJumpLoader = True
|
||||
If Library("name") Is Nothing Then Library.Add("name", Library("mavenPath")) '这里的修改会导致原 Json 内容改变
|
||||
If Library("repoUrl") IsNot Nothing AndAlso Library("url") Is Nothing Then Library.Add("url", Library("repoUrl"))
|
||||
End If
|
||||
|
||||
'获取根节点下的 url
|
||||
Dim RootUrl As String = Library("url")
|
||||
If RootUrl IsNot Nothing Then
|
||||
@@ -1882,15 +1867,10 @@ OnLoaded:
|
||||
'根据是否本地化处理（Natives）
|
||||
If Library("natives") Is Nothing Then '没有 Natives
|
||||
Dim LocalPath As String
|
||||
If IsJumpLoader Then
|
||||
LocalPath = McLibGet(Library("name"), CustomMcFolder:=If(JumpLoaderFolder, CustomMcFolder))
|
||||
Else
|
||||
LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder)
|
||||
End If
|
||||
LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder)
|
||||
Try
|
||||
If Library("downloads") IsNot Nothing AndAlso Library("downloads")("artifact") IsNot Nothing Then
|
||||
BasicArray.Add(New McLibToken With {
|
||||
.IsJumpLoader = IsJumpLoader,
|
||||
.OriginalName = Library("name"),
|
||||
.Url = If(RootUrl, Library("downloads")("artifact")("url")),
|
||||
.LocalPath = If(Library("downloads")("artifact")("path") Is Nothing, McLibGet(Library("name"),
|
||||
@@ -1899,17 +1879,16 @@ OnLoaded:
|
||||
.IsNatives = False,
|
||||
.SHA1 = Library("downloads")("artifact")("sha1")?.ToString})
|
||||
Else
|
||||
BasicArray.Add(New McLibToken With {.IsJumpLoader = IsJumpLoader, .OriginalName = Library("name"), .Url = RootUrl, .LocalPath = LocalPath, .Size = 0, .IsNatives = False, .SHA1 = Nothing})
|
||||
BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = LocalPath, .Size = 0, .IsNatives = False, .SHA1 = Nothing})
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "处理实际支持库列表失败（无 Natives，" & If(Library("name"), "Nothing").ToString & "）")
|
||||
BasicArray.Add(New McLibToken With {.IsJumpLoader = IsJumpLoader, .OriginalName = Library("name"), .Url = RootUrl, .LocalPath = LocalPath, .Size = 0, .IsNatives = False, .SHA1 = Nothing})
|
||||
BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = LocalPath, .Size = 0, .IsNatives = False, .SHA1 = Nothing})
|
||||
End Try
|
||||
ElseIf Library("natives")("windows") IsNot Nothing Then '有 Windows Natives
|
||||
Try
|
||||
If Library("downloads") IsNot Nothing AndAlso Library("downloads")("classifiers") IsNot Nothing AndAlso Library("downloads")("classifiers")("natives-windows") IsNot Nothing Then
|
||||
BasicArray.Add(New McLibToken With {
|
||||
.IsJumpLoader = IsJumpLoader,
|
||||
.OriginalName = Library("name"),
|
||||
.Url = If(RootUrl, Library("downloads")("classifiers")("natives-windows")("url")),
|
||||
.LocalPath = If(Library("downloads")("classifiers")("natives-windows")("path") Is Nothing,
|
||||
@@ -1919,11 +1898,11 @@ OnLoaded:
|
||||
.IsNatives = True,
|
||||
.SHA1 = Library("downloads")("classifiers")("natives-windows")("sha1").ToString})
|
||||
Else
|
||||
BasicArray.Add(New McLibToken With {.IsJumpLoader = IsJumpLoader, .OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing})
|
||||
BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing})
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "处理实际支持库列表失败（有 Natives，" & If(Library("name"), "Nothing").ToString & "）")
|
||||
BasicArray.Add(New McLibToken With {.IsJumpLoader = IsJumpLoader, .OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing})
|
||||
BasicArray.Add(New McLibToken With {.OriginalName = Library("name"), .Url = RootUrl, .LocalPath = McLibGet(Library("name"), CustomMcFolder:=CustomMcFolder).Replace(".jar", "-" & Library("natives")("windows").ToString & ".jar").Replace("${arch}", If(Environment.Is64BitOperatingSystem, "64", "32")), .Size = 0, .IsNatives = True, .SHA1 = Nothing})
|
||||
End Try
|
||||
End If
|
||||
|
||||
@@ -1940,7 +1919,7 @@ OnLoaded:
|
||||
Return GetFolderNameFromPath(GetPathFromFullPath(Token.LocalPath))
|
||||
End Function
|
||||
For i = 0 To BasicArray.Count - 1
|
||||
Dim Key As String = BasicArray(i).Name & BasicArray(i).IsNatives.ToString & BasicArray(i).IsJumpLoader.ToString
|
||||
Dim Key As String = BasicArray(i).Name & BasicArray(i).IsNatives.ToString
|
||||
If ResultArray.ContainsKey(Key) Then
|
||||
Dim BasicArrayVersion As String = GetVersion(BasicArray(i))
|
||||
Dim ResultArrayVersion As String = GetVersion(ResultArray(Key))
|
||||
@@ -1964,7 +1943,7 @@ OnLoaded:
|
||||
''' 获取版本缺失的支持库文件所对应的 NetTaskFile。
|
||||
''' </summary>
|
||||
Public Function McLibFix(Version As McVersion) As List(Of NetFile)
|
||||
If Not Version.IsLoaded Then Version.Load() '确保例如 JumpLoader 等项被合并入 Json
|
||||
If Not Version.IsLoaded Then Version.Load()
|
||||
Dim Result As New List(Of NetFile)
|
||||
|
||||
'更新此方法时需要同步更新 Forge 新版自动安装方法！
|
||||
@@ -1978,7 +1957,7 @@ OnLoaded:
|
||||
End Try
|
||||
|
||||
'Library 文件
|
||||
Result.AddRange(McLibFixFromLibToken(McLibListGet(Version, False), JumpLoaderFolder:=Version.PathIndie & ".jumploader\"))
|
||||
Result.AddRange(McLibFixFromLibToken(McLibListGet(Version, False)))
|
||||
|
||||
'统一通行证文件
|
||||
If Setup.Get("VersionServerLogin", Version:=Version) = 3 Then
|
||||
@@ -1988,8 +1967,7 @@ OnLoaded:
|
||||
Try
|
||||
Log("[Minecraft] 开始获取统一通行证下载信息")
|
||||
'测试链接：https://auth.mc-user.com:233/00000000000000000000000000000000/
|
||||
DownloadInfo = GetJson(NetGetCodeByLoader({
|
||||
"https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)}, IsJson:=True))
|
||||
DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version), RequireJson:=True))
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取统一通行证下载信息失败")
|
||||
End Try
|
||||
@@ -2006,17 +1984,20 @@ OnLoaded:
|
||||
|
||||
'Authlib-Injector 文件
|
||||
If Setup.Get("VersionServerLogin", Version:=Version) = 4 Then
|
||||
Dim TargetFile = PathPure & "\authlib-injector.jar"
|
||||
Dim TargetFile = PathPure & "authlib-injector.jar"
|
||||
Dim DownloadInfo As JObject = Nothing
|
||||
'获取下载信息
|
||||
Try
|
||||
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
|
||||
DownloadInfo = GetJson(NetGetCodeByLoader({
|
||||
DownloadInfo = GetJson(NetRequestByClientRetry(
|
||||
"https://authlib-injector.yushi.moe/artifact/latest.json",
|
||||
"https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"
|
||||
}, IsJson:=True))
|
||||
BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json", RequireJson:=True))
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取 Authlib-Injector 下载信息失败")
|
||||
If File.Exists(TargetFile) Then
|
||||
Log(ex, "获取 Authlib-Injector 下载信息失败")
|
||||
Else
|
||||
Throw New Exception("获取 Authlib-Injector 下载信息失败", ex)
|
||||
End If
|
||||
End Try
|
||||
'校验文件
|
||||
If DownloadInfo IsNot Nothing Then
|
||||
@@ -2053,30 +2034,39 @@ OnLoaded:
|
||||
''' <summary>
|
||||
''' 将 McLibToken 列表转换为 NetFile。无需下载的文件会被自动过滤。
|
||||
''' </summary>
|
||||
Public Function McLibFixFromLibToken(Libs As List(Of McLibToken), Optional CustomMcFolder As String = Nothing, Optional JumpLoaderFolder As String = Nothing) As List(Of NetFile)
|
||||
Public Function McLibFixFromLibToken(Libs As List(Of McLibToken), Optional CustomMcFolder As String = Nothing) As List(Of NetFile)
|
||||
CustomMcFolder = If(CustomMcFolder, PathMcFolder)
|
||||
Dim Result As New List(Of NetFile)
|
||||
'获取
|
||||
For Each Token As McLibToken In Libs
|
||||
'检查文件
|
||||
Dim Checker As New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1)
|
||||
Dim Checker As FileChecker
|
||||
If Token.Name.ContainsF("labymod") Then
|
||||
Checker = New FileChecker '不检查 LabyMod 的文件，它们提供的文件校验信息是错的（#3225）
|
||||
Else
|
||||
Checker = New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.SHA1)
|
||||
End If
|
||||
If Checker.Check(Token.LocalPath) Is Nothing Then Continue For
|
||||
'文件不符合，添加下载
|
||||
Dim Urls As New List(Of String)
|
||||
If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then
|
||||
'特判修复 Forge 部分 universal 文件缺失 URL（#5455）
|
||||
Token.Url = "https://maven.minecraftforge.net" & Token.LocalPath.Replace(If(Token.IsJumpLoader, JumpLoaderFolder, CustomMcFolder) & "libraries", "").Replace("\", "/")
|
||||
If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then '特判修复 Forge 部分 universal 文件缺失 URL（#5455）
|
||||
Token.Url = "https://maven.minecraftforge.net" & Token.LocalPath.Replace(CustomMcFolder & "libraries", "").Replace("\", "/")
|
||||
End If
|
||||
If Token.Url IsNot Nothing Then
|
||||
'获取 URL 的真实地址
|
||||
Urls.Add(Token.Url)
|
||||
If Token.Url.Contains("launcher.mojang.com/v1/objects") OrElse Token.Url.Contains("client.txt") OrElse
|
||||
Token.Url.Contains(".tsrg") Then
|
||||
Urls.AddRange(DlSourceLauncherOrMetaGet(Token.Url).ToList()) 'Mappings（#4425）
|
||||
Urls.AddRange(DlSourceLauncherOrMetaGet(Token.Url)) 'Mappings（#4425）
|
||||
End If
|
||||
If Token.Url.Contains("maven") Then
|
||||
Urls.Insert(0, Token.Url.Replace(Mid(Token.Url, 1, Token.Url.IndexOfF("maven")), "https://bmclapi2.bangbang93.com/").
|
||||
Replace("maven.fabricmc.net", "maven").Replace("maven.minecraftforge.net", "maven").Replace("maven.neoforged.net/releases", "maven"))
|
||||
Dim BmclapiUrl As String =
|
||||
Token.Url.Replace(Mid(Token.Url, 1, Token.Url.IndexOfF("maven")), "https://bmclapi2.bangbang93.com/").Replace("maven.fabricmc.net", "maven").Replace("maven.minecraftforge.net", "maven").Replace("maven.neoforged.net/releases", "maven")
|
||||
If DlSourcePreferMojang Then
|
||||
Urls.Add(BmclapiUrl) '官方源优先
|
||||
Else
|
||||
Urls.Insert(0, BmclapiUrl) '镜像源优先
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
If Token.LocalPath.Contains("transformer-discovery-service") Then
|
||||
@@ -2086,13 +2076,13 @@ OnLoaded:
|
||||
Continue For
|
||||
ElseIf Token.LocalPath.Contains("optifine\OptiFine") Then
|
||||
'OptiFine 主 Jar
|
||||
Dim OptiFineBase As String = Token.LocalPath.Replace(If(Token.IsJumpLoader, JumpLoaderFolder, CustomMcFolder) & "libraries\optifine\OptiFine\", "").Split("_")(0) & "/" & GetFileNameFromPath(Token.LocalPath).Replace("-", "_")
|
||||
Dim OptiFineBase As String = Token.LocalPath.Replace(CustomMcFolder & "libraries\optifine\OptiFine\", "").Split("_")(0) & "/" & GetFileNameFromPath(Token.LocalPath).Replace("-", "_")
|
||||
OptiFineBase = "/maven/com/optifine/" & OptiFineBase
|
||||
If OptiFineBase.Contains("_pre") Then OptiFineBase = OptiFineBase.Replace("com/optifine/", "com/optifine/preview_")
|
||||
Urls.Add("https://bmclapi2.bangbang93.com" & OptiFineBase)
|
||||
ElseIf Urls.Count <= 2 Then
|
||||
'普通文件
|
||||
Urls.AddRange(DlSourceLibraryGet("https://libraries.minecraft.net" & Token.LocalPath.Replace(If(Token.IsJumpLoader, JumpLoaderFolder, CustomMcFolder) & "libraries", "").Replace("\", "/")))
|
||||
Urls.AddRange(DlSourceLibraryGet("https://libraries.minecraft.net" & Token.LocalPath.Replace(CustomMcFolder & "libraries", "").Replace("\", "/")))
|
||||
End If
|
||||
Result.Add(New NetFile(Urls.Distinct, Token.LocalPath, Checker))
|
||||
Next
|
||||
@@ -2231,16 +2221,16 @@ OnLoaded:
|
||||
Dim LocalPath As String
|
||||
If Json("map_to_resources") IsNot Nothing AndAlso Json("map_to_resources").ToObject(Of Boolean) Then
|
||||
'Remap
|
||||
LocalPath = Version.PathIndie & "resources\" & File.Name.Replace("/", "\")
|
||||
LocalPath = $"{Version.PathIndie}resources\{File.Name}"
|
||||
ElseIf Json("virtual") IsNot Nothing AndAlso Json("virtual").ToObject(Of Boolean) Then
|
||||
'Virtual
|
||||
LocalPath = PathMcFolder & "assets\virtual\legacy\" & File.Name.Replace("/", "\")
|
||||
LocalPath = $"{PathMcFolder}assets\virtual\legacy\{File.Name}"
|
||||
Else
|
||||
'正常
|
||||
LocalPath = PathMcFolder & "assets\objects\" & Left(File.Value("hash").ToString, 2) & "\" & File.Value("hash").ToString
|
||||
LocalPath = $"{PathMcFolder}assets\objects\{Left(File.Value("hash").ToString, 2)}\{File.Value("hash")}"
|
||||
End If
|
||||
Result.Add(New McAssetsToken With {
|
||||
.LocalPath = LocalPath,
|
||||
.LocalPath = LocalPath.Replace("/", "\"),
|
||||
.SourcePath = File.Name,
|
||||
.Hash = File.Value("hash").ToString,
|
||||
.Size = File.Value("size").ToString
|
||||
@@ -2275,7 +2265,7 @@ OnLoaded:
|
||||
If File.Exists AndAlso (Token.Size = 0 OrElse Token.Size = File.Length) AndAlso
|
||||
(Not CheckHash OrElse Token.Hash Is Nothing OrElse Token.Hash = GetFileSHA1(Token.LocalPath)) Then Continue For
|
||||
'文件不存在，添加下载
|
||||
Result.Add(New NetFile(DlSourceResourceGet("https://resources.download.minecraft.net/" & Left(Token.Hash, 2) & "/" & Token.Hash), Token.LocalPath, New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.Hash)))
|
||||
Result.Add(New NetFile(DlSourceAssetsGet($"https://resources.download.minecraft.net/{Left(Token.Hash, 2)}/{Token.Hash}"), Token.LocalPath, New FileChecker(ActualSize:=If(Token.Size = 0, -1, Token.Size), Hash:=Token.Hash)))
|
||||
Next
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取版本缺失的资源文件下载列表失败")
|
||||
@@ -2302,7 +2292,7 @@ OnLoaded:
|
||||
End If
|
||||
Next
|
||||
'进行提示
|
||||
If Version Is Nothing Then Exit Sub
|
||||
If Version Is Nothing Then Return
|
||||
Dim Time As Date = Version("releaseTime")
|
||||
Dim MsgBoxText As String = $"新版本：{VersionName}{vbCrLf}" &
|
||||
If((Date.Now - Time).TotalDays > 1, "更新时间：" & Time.ToString, "更新于：" & GetTimeSpanString(Time - Date.Now, False))
|
||||
@@ -2400,26 +2390,45 @@ NextEntry:
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 为邮箱地址或手机号账号进行部分打码。
|
||||
''' 判断版本名是否类似正式版。
|
||||
''' </summary>
|
||||
Public Function AccountFilter(Account As String) As String
|
||||
If Account.Contains("@") Then
|
||||
'是邮箱
|
||||
Dim Splits = Account.Split("@")
|
||||
'If Splits(0).Count >= 6 Then
|
||||
' '前半部分至少 6 位，屏蔽后 4 位
|
||||
' Return Mid(Splits(0), 1, Splits(0).Count - 4) & "****" & "@" & Splits(1)
|
||||
'Else
|
||||
'前半部分不到 6 位，返回全 *
|
||||
Return "".PadLeft(Splits(0).Count, "*") & "@" & Splits(1)
|
||||
'End If
|
||||
ElseIf Account.Count >= 6 Then
|
||||
'至少 6 位，屏蔽后 4 位
|
||||
Return Mid(Account, 1, Account.Count - 4) & "****"
|
||||
Else
|
||||
'不到 6 位，返回全 *
|
||||
Return "".PadLeft(Account.Count, "*")
|
||||
Public Function IsVersionNameLikeRelease(VerName As String) As Boolean
|
||||
Return VerName.StartsWithF("1.") AndAlso Not (VerName.Contains("w") OrElse VerName.Contains("pre") OrElse VerName.Contains("rc") OrElse VerName.Contains("-"))
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 打码字符串中的 AccessToken。
|
||||
''' </summary>
|
||||
Public Function FilterAccessToken(Raw As String, FilterChar As Char) As String
|
||||
'打码 "accessToken " 后的内容
|
||||
If Raw.Contains("accessToken ") Then
|
||||
For Each Token In RegexSearch(Raw, "(?<=accessToken ([^ ]{5}))[^ ]+(?=[^ ]{5})")
|
||||
Raw = Raw.Replace(Token, New String(FilterChar, Token.Count))
|
||||
Next
|
||||
End If
|
||||
'打码当前登录的结果
|
||||
Dim AccessToken As String = McLoginLoader.Output.AccessToken
|
||||
If AccessToken IsNot Nothing AndAlso AccessToken.Length >= 10 AndAlso Raw.ContainsF(AccessToken, True) AndAlso
|
||||
McLoginLoader.Output.Uuid <> McLoginLoader.Output.AccessToken Then 'UUID 和 AccessToken 一样则不打码
|
||||
Raw = Raw.Replace(AccessToken, Left(AccessToken, 5) & New String(FilterChar, AccessToken.Length - 10) & Right(AccessToken, 5))
|
||||
End If
|
||||
Return Raw
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 打码字符串中的 Windows 用户名。
|
||||
''' </summary>
|
||||
Public Function FilterUserName(Raw As String, FilterChar As Char) As String
|
||||
If Raw.Contains(":\Users\") Then
|
||||
For Each Token In RegexSearch(Raw, "(?<=:\\Users\\)[^\\]+")
|
||||
Raw = Raw.Replace("\Users\" & Token, "\Users\" & New String(FilterChar, Token.Count))
|
||||
Next
|
||||
End If
|
||||
If Raw.Contains(":/Users/") Then
|
||||
For Each Token In RegexSearch(Raw, "(?<=:/Users/)[^/]+")
|
||||
Raw = Raw.Replace("/Users/" & Token, "/Users/" & New String(FilterChar, Token.Count))
|
||||
Next
|
||||
End If
|
||||
Return Raw
|
||||
End Function
|
||||
|
||||
End Module
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
Imports System.IO.Compression
|
||||
|
||||
Public Module ModMod
|
||||
Private Const LocalModCacheVersion As Integer = 7
|
||||
Private Const LocalModCacheVersion As Integer = 8
|
||||
|
||||
Public Class McMod
|
||||
|
||||
@@ -73,7 +73,7 @@ Public Module ModMod
|
||||
Get
|
||||
If _Name Is Nothing Then Load()
|
||||
If _Name Is Nothing Then _Name = _ModId
|
||||
If _Name Is Nothing Then _Name = GetFileNameWithoutExtentionFromPath(Path)
|
||||
If _Name Is Nothing Then _Name = IO.Path.GetFileNameWithoutExtension(Path)
|
||||
Return _Name
|
||||
End Get
|
||||
Set(value As String)
|
||||
@@ -188,9 +188,9 @@ Public Module ModMod
|
||||
Private _Dependencies As New Dictionary(Of String, String)
|
||||
Private Sub AddDependency(ModID As String, Optional VersionRequirement As String = Nothing)
|
||||
'确保信息正确
|
||||
If ModID Is Nothing OrElse ModID.Count < 2 Then Exit Sub
|
||||
If ModID Is Nothing OrElse ModID.Count < 2 Then Return
|
||||
ModID = ModID.ToLower
|
||||
If ModID = "name" OrElse Val(ModID).ToString = ModID Then Exit Sub '跳过 name 与纯数字 id
|
||||
If ModID = "name" OrElse Val(ModID).ToString = ModID Then Return '跳过 name 与纯数字 id
|
||||
If VersionRequirement Is Nothing OrElse ((Not VersionRequirement.Contains(".")) AndAlso (Not VersionRequirement.Contains("-"))) OrElse VersionRequirement.Contains("$") Then
|
||||
VersionRequirement = Nothing
|
||||
Else
|
||||
@@ -279,7 +279,7 @@ Public Module ModMod
|
||||
''' 进行文件可用性检查与 .class 以外的信息获取。
|
||||
''' </summary>
|
||||
Public Sub Load(Optional ForceReload As Boolean = False)
|
||||
If IsLoaded AndAlso Not ForceReload Then Exit Sub
|
||||
If IsLoaded AndAlso Not ForceReload Then Return
|
||||
'初始化
|
||||
Init()
|
||||
Dim Jar As ZipArchive = Nothing
|
||||
@@ -688,7 +688,7 @@ Finished:
|
||||
''' </summary>
|
||||
Public ReadOnly Property CanUpdate As Boolean
|
||||
Get
|
||||
Return Not Setup.Get("UiHiddenFunctionModUpdate") AndAlso ChangelogUrls.Any()
|
||||
Return Not Setup.Get("UiHiddenFunctionModUpdate") AndAlso Not Setup.Get("VersionAdvanceDisableModUpdate", Version:=PageVersionLeft.Version) AndAlso ChangelogUrls.Any()
|
||||
End Get
|
||||
End Property
|
||||
|
||||
@@ -819,7 +819,7 @@ Finished:
|
||||
Try
|
||||
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在更新 Mod")
|
||||
Do Until Not PageVersionMod.UpdatingVersions.Contains(Loader.Input)
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
If Loader.IsAborted Then Return
|
||||
Thread.Sleep(100)
|
||||
Loop
|
||||
Finally
|
||||
@@ -837,7 +837,7 @@ Finished:
|
||||
'仅当 Forge 1.13- 且文件夹名与版本号相同时，才加载该子文件夹下的 Mod
|
||||
If Not (PageVersionLeft.Version IsNot Nothing AndAlso PageVersionLeft.Version.Version.HasForge AndAlso
|
||||
PageVersionLeft.Version.Version.McCodeMain < 13 AndAlso
|
||||
File.Directory.Name = "1." & PageVersionLeft.Version.Version.McCodeMain & "." & PageVersionLeft.Version.Version.McCodeSub) Then
|
||||
File.Directory.Name = $"1.{PageVersionLeft.Version.Version.McCodeMain}.{PageVersionLeft.Version.Version.McCodeSub}") Then
|
||||
Continue For
|
||||
End If
|
||||
End If
|
||||
@@ -872,7 +872,7 @@ Finished:
|
||||
Dim ModUpdateList As New List(Of McMod)
|
||||
For Each ModFile As FileInfo In ModFileList
|
||||
Loader.Progress += 0.94 / ModFileList.Count
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
If Loader.IsAborted Then Return
|
||||
'加载 McMod 对象
|
||||
Dim ModEntry As New McMod(ModFile.FullName)
|
||||
ModEntry.Load()
|
||||
@@ -912,7 +912,7 @@ Finished:
|
||||
End Function)
|
||||
|
||||
'回设
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
If Loader.IsAborted Then Return
|
||||
Loader.Output = ModList
|
||||
|
||||
'开始联网加载
|
||||
@@ -939,18 +939,18 @@ Finished:
|
||||
'开始网络获取
|
||||
Log($"[Mod] 目标加载器：{ModLoaders.Join("/")}，版本：{McVersion}")
|
||||
Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False
|
||||
Dim MainThread As Thread = Thread.CurrentThread
|
||||
Dim CurrentTaskThread As Thread = Thread.CurrentThread
|
||||
'从 Modrinth 获取信息
|
||||
RunInNewThread(
|
||||
Sub()
|
||||
Try
|
||||
'步骤 1：获取 Hash 与对应的工程 ID
|
||||
Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList()
|
||||
Dim ModrinthVersion = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files", "POST",
|
||||
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")), JObject)
|
||||
Dim ModrinthVersion As JObject = DlModRequest("https://api.modrinth.com/v2/version_files", HttpMethod.Post,
|
||||
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")
|
||||
Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息")
|
||||
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
|
||||
If ModrinthVersion.Count = 0 Then Exit Sub
|
||||
If ModrinthVersion.Count = 0 Then Return
|
||||
Dim ModrinthMapping As New Dictionary(Of String, List(Of McMod))
|
||||
For Each Entry In Mods
|
||||
If Not ModrinthVersion.ContainsKey(Entry.ModrinthHash) Then Continue For
|
||||
@@ -963,13 +963,12 @@ Finished:
|
||||
Dim File As New CompFile(ModrinthVersion(Entry.ModrinthHash), CompType.Mod)
|
||||
If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
|
||||
Next
|
||||
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
|
||||
If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
|
||||
Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
|
||||
'步骤 3：获取工程信息
|
||||
If Not ModrinthMapping.Any() Then Exit Sub
|
||||
Dim ModrinthProject = CType(GetJson(DlModRequest(
|
||||
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]",
|
||||
"GET", "", "application/json")), JArray)
|
||||
If Not ModrinthMapping.Any() Then Return
|
||||
Dim ModrinthProject As JArray = DlModRequest(
|
||||
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]")
|
||||
For Each ProjectJson In ModrinthProject
|
||||
Dim Project As New CompProject(ProjectJson)
|
||||
For Each Entry In ModrinthMapping(Project.Id)
|
||||
@@ -978,9 +977,9 @@ Finished:
|
||||
Next
|
||||
Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息，继续获取更新信息")
|
||||
'步骤 4：获取更新信息
|
||||
Dim ModrinthUpdate = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files/update", "POST",
|
||||
Dim ModrinthUpdate As JObject = DlModRequest("https://api.modrinth.com/v2/version_files/update", HttpMethod.Post,
|
||||
$"{{""hashes"": [""{ModrinthMapping.SelectMany(Function(l) l.Value.Select(Function(m) m.ModrinthHash)).Join(""",""")}""], ""algorithm"": ""sha1"",
|
||||
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersion}""]}}", "application/json")), JObject)
|
||||
""loaders"": [""{ModLoaders.Join(""",""").ToLower}""],""game_versions"": [""{McVersion}""]}}", "application/json")
|
||||
For Each Entry In Mods
|
||||
If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.CompFile Is Nothing Then Continue For
|
||||
Dim UpdateFile As New CompFile(ModrinthUpdate(Entry.ModrinthHash), CompType.Mod)
|
||||
@@ -1013,13 +1012,13 @@ Finished:
|
||||
Dim CurseForgeHashes As New List(Of UInteger)
|
||||
For Each Entry In Mods
|
||||
CurseForgeHashes.Add(Entry.CurseForgeHash)
|
||||
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
|
||||
If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
|
||||
Next
|
||||
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST",
|
||||
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer)
|
||||
Dim CurseForgeRaw As JContainer = DlModRequest("https://api.curseforge.com/v1/fingerprints/432", HttpMethod.Post,
|
||||
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")("data")("exactMatches")
|
||||
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
|
||||
'步骤 2：尝试读取工程信息缓存，构建其他 Mod 的对应关系
|
||||
If Not CurseForgeRaw.Any() Then Exit Sub
|
||||
If Not CurseForgeRaw.Any() Then Return
|
||||
Dim CurseForgeMapping As New Dictionary(Of Integer, List(Of McMod))
|
||||
For Each Project In CurseForgeRaw
|
||||
Dim ProjectId = Project("id").ToString
|
||||
@@ -1034,12 +1033,12 @@ Finished:
|
||||
If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
|
||||
Next
|
||||
Next
|
||||
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub
|
||||
If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
|
||||
Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
|
||||
'步骤 3：获取工程信息
|
||||
If Not CurseForgeMapping.Any() Then Exit Sub
|
||||
Dim CurseForgeProject = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods", "POST",
|
||||
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data")
|
||||
If Not CurseForgeMapping.Any() Then Return
|
||||
Dim CurseForgeProject = DlModRequest("https://api.curseforge.com/v1/mods", HttpMethod.Post,
|
||||
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")("data")
|
||||
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表
|
||||
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
|
||||
For Each ProjectJson In CurseForgeProject
|
||||
@@ -1078,9 +1077,9 @@ Finished:
|
||||
Next
|
||||
Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息，需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
|
||||
'步骤 4：获取更新文件信息
|
||||
If Not UpdateFileIds.Any() Then Exit Sub
|
||||
Dim CurseForgeFiles = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST",
|
||||
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")), JObject)("data")
|
||||
If Not UpdateFileIds.Any() Then Return
|
||||
Dim CurseForgeFiles = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post,
|
||||
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")("data")
|
||||
Dim UpdateFiles As New Dictionary(Of McMod, CompFile)
|
||||
For Each FileJson In CurseForgeFiles
|
||||
Dim File As New CompFile(FileJson, CompType.Mod)
|
||||
@@ -1114,20 +1113,25 @@ Finished:
|
||||
End Sub, "Mod List Detail Loader CurseForge")
|
||||
'等待线程结束
|
||||
Do Until EndedThreadCount = 2
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
Thread.Sleep(10)
|
||||
If Loader.IsAborted Then Return
|
||||
Loop
|
||||
'保存缓存
|
||||
Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
|
||||
Log($"[Mod] 联网获取本地 Mod 信息完成，为 {Mods.Count} 个 Mod 更新缓存")
|
||||
If Not Mods.Any() Then Exit Sub
|
||||
If Not Mods.Any() Then Return
|
||||
For Each Entry In Mods
|
||||
Entry.CompLoaded = Not IsFailed
|
||||
Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson()
|
||||
Next
|
||||
WriteFile(PathTemp & "Cache\LocalMod.json", Cache.ToString(If(ModeDebug, Newtonsoft.Json.Formatting.Indented, Newtonsoft.Json.Formatting.None)))
|
||||
'刷新边栏
|
||||
RunInUi(Sub() FrmVersionMod?.RefreshBars())
|
||||
If Loader.IsAborted Then Return
|
||||
If FrmVersionMod?.Filter = PageVersionMod.FilterType.CanUpdate Then
|
||||
RunInUi(Sub() FrmVersionMod?.RefreshUI()) '同步 “可更新” 列表 (#4677)
|
||||
Else
|
||||
RunInUi(Sub() FrmVersionMod?.RefreshBars())
|
||||
End If
|
||||
End Sub
|
||||
Public Function GetTargetModLoaders() As List(Of CompModLoaderType)
|
||||
Dim ModLoaders As New List(Of CompModLoaderType)
|
||||
@@ -1209,7 +1213,7 @@ Finished:
|
||||
If ReqVersionHead = ReqVersionTail Then
|
||||
VersionRequire = "应为 " & ReqVersionHead
|
||||
ElseIf ReqVersionHead.Contains(".") AndAlso ReqVersionTail.Contains(".") Then
|
||||
VersionRequire = "应为 " & ReqVersionHead & " 至 " & ReqVersionTail
|
||||
VersionRequire = $"应为 {ReqVersionHead} 至 {ReqVersionTail}"
|
||||
ElseIf ReqVersionHead.Contains(".") Then
|
||||
If ReqVersionHeadCanEqual Then
|
||||
VersionRequire = "最低应为 " & ReqVersionHead
|
||||
@@ -1227,7 +1231,7 @@ Finished:
|
||||
End If
|
||||
'检查前置 Mod 是否存在，并获取其版本
|
||||
If Not CurrentDependencies.ContainsKey(ReqId) Then
|
||||
Result.Add("缺少前置 Mod：" & ReqId & If(VersionRequire = "", "", "，其版本" & VersionRequire) & "。" & vbCrLf & " - " & ModEntity.FileName)
|
||||
Result.Add($"缺少前置 Mod：{ReqId}{If(VersionRequire = "", "", "，其版本" & VersionRequire)}。{vbCrLf} - {ModEntity.FileName}")
|
||||
Continue For
|
||||
End If
|
||||
Dim CurrentVersion As String = If(CurrentDependencies(ReqId)(0), "0.0")
|
||||
@@ -1236,7 +1240,7 @@ Finished:
|
||||
If ReqVersionHead.Contains(".") Then
|
||||
If VersionSortInteger(ReqVersionHead, CurrentVersion) > If(ReqVersionHeadCanEqual, 0, -1) Then
|
||||
Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过低，其版本" & VersionRequire & "，而当前版本为 " & CurrentVersion & "。" & vbCrLf &
|
||||
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置：" & CurrentDependencies(ReqId)(1), ""))
|
||||
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", $"{vbCrLf} - 前置：{CurrentDependencies(ReqId)(1)}", ""))
|
||||
Continue For
|
||||
End If
|
||||
End If
|
||||
@@ -1244,26 +1248,26 @@ Finished:
|
||||
If ReqVersionTail.Contains(".") Then
|
||||
If VersionSortInteger(CurrentVersion, ReqVersionTail) > If(ReqVersionTailCanEqual, 0, -1) Then
|
||||
Result.Add(ReqId.Substring(0, 1).ToUpper & ReqId.Substring(1) & " 版本过高，其版本" & VersionRequire & "，而当前版本为 " & CurrentVersion & "。" & vbCrLf &
|
||||
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", vbCrLf & " - 前置：" & CurrentDependencies(ReqId)(1), ""))
|
||||
" - " & ModEntity.FileName & If(ReqId <> "minecraft" AndAlso ReqId <> "forge", $"{vbCrLf} - 前置：{CurrentDependencies(ReqId)(1)}", ""))
|
||||
Continue For
|
||||
End If
|
||||
End If
|
||||
Else
|
||||
If Not CurrentDependencies.ContainsKey(Dependency.Key) Then
|
||||
Result.Add("缺少前置 Mod：" & Dependency.Key & "。" & vbCrLf & " - " & ModEntity.FileName)
|
||||
Result.Add($"缺少前置 Mod：{Dependency.Key}。{vbCrLf} - {ModEntity.FileName}")
|
||||
Continue For
|
||||
End If
|
||||
End If
|
||||
Next
|
||||
Catch ex As Exception
|
||||
Result.Add("检查 Mod 时出错：" & GetExceptionSummary(ex) & vbCrLf & " - " & ModEntity.FileName)
|
||||
Result.Add($"检查 Mod 时出错：{ex.GetBrief()}{vbCrLf} - {ModEntity.FileName}")
|
||||
Log(ex, "检查 Mod 时出错")
|
||||
End Try
|
||||
Next
|
||||
If Not Result.Any() Then
|
||||
Log("[Minecraft] Mod 检查未发现异常")
|
||||
Else
|
||||
Log("[Minecraft] Mod 检查异常结果：" & vbCrLf & Join(Result, vbCrLf))
|
||||
Log($"[Minecraft] Mod 检查异常结果：{vbCrLf}{Join(Result, vbCrLf)}")
|
||||
End If
|
||||
Return Result
|
||||
End Function
|
||||
|
||||
@@ -8,7 +8,7 @@ Public Module ModModpack
|
||||
''' </summary>
|
||||
Public Sub ModpackInstall()
|
||||
Dim File As String = SelectFile("整合包文件(*.rar;*.zip;*.mrpack)|*.rar;*.zip;*.mrpack", "选择整合包压缩文件") '选择整合包文件
|
||||
If String.IsNullOrEmpty(File) Then Exit Sub
|
||||
If String.IsNullOrEmpty(File) Then Return
|
||||
RunInThread(
|
||||
Sub()
|
||||
Try
|
||||
@@ -72,7 +72,7 @@ Public Module ModModpack
|
||||
If FullNames(1) = "modpack.zip" OrElse FullNames(1) = "modpack.mrpack" Then PackType = 9 : Exit Try '带启动器的压缩包
|
||||
Next
|
||||
Catch ex As Exception
|
||||
If GetExceptionDetail(ex, True).Contains("Error.WinIOError") Then
|
||||
If ex.GetDetail(True).Contains("Error.WinIOError") Then
|
||||
Throw New Exception("打开整合包文件失败", ex)
|
||||
ElseIf File.EndsWithF(".rar", True) Then
|
||||
Throw New Exception("PCL 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", ex)
|
||||
@@ -109,30 +109,71 @@ Public Module ModModpack
|
||||
End Try
|
||||
End Function
|
||||
|
||||
Private Sub ExtractModpackFiles(InstallTemp As String, FileAddress As String, Loader As LoaderBase, LoaderProgressDelta As Double)
|
||||
Private Sub ExtractModpackFiles(InstallTemp As String, FileAddress As String, Loader As LoaderBase, ProgressIncrement As Double)
|
||||
'解压文件
|
||||
Dim RetryCount As Integer = 1
|
||||
Dim Encode = Encoding.GetEncoding("GB18030")
|
||||
Dim InitialProgress = Loader.Progress
|
||||
Try
|
||||
Retry:
|
||||
'完全不知道为啥会出现文件正在被另一进程使用的问题，总之多试试
|
||||
Loader.Progress = InitialProgress
|
||||
DeleteDirectory(InstallTemp)
|
||||
ExtractFile(FileAddress, InstallTemp, Encode, ProgressIncrementHandler:=Sub(Delta) Loader.Progress += Delta * LoaderProgressDelta)
|
||||
ExtractFile(FileAddress, InstallTemp, Encode, ProgressIncrementHandler:=Sub(Delta) Loader.Progress += Delta * ProgressIncrement)
|
||||
Catch ex As Exception
|
||||
Log(ex, "第 " & RetryCount & " 次解压尝试失败")
|
||||
If TypeOf ex Is ArgumentException Then
|
||||
Encode = Encoding.UTF8
|
||||
Log("[ModPack] 已切换压缩包解压编码为 UTF8")
|
||||
End If
|
||||
'完全不知道为啥会出现文件正在被另一进程使用的问题，总之加个重试
|
||||
If RetryCount < 5 Then
|
||||
Thread.Sleep(RetryCount * 2000)
|
||||
If Loader IsNot Nothing AndAlso Loader.LoadingState <> MyLoading.MyLoadingState.Run Then Exit Sub
|
||||
If Loader IsNot Nothing AndAlso Loader.LoadingState <> MyLoading.MyLoadingState.Run Then Return
|
||||
RetryCount += 1
|
||||
GoTo Retry
|
||||
Else
|
||||
Throw New Exception("解压整合包文件失败", ex)
|
||||
End If
|
||||
End Try
|
||||
Loader.Progress = InitialProgress + ProgressIncrement
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 从整合包的 override 目录复制文件，同时设置 PCL 的配置文件与版本隔离。
|
||||
''' 对路径末尾是否为 \ 没有要求。
|
||||
''' </summary>
|
||||
Private Sub CopyOverrideDirectory(OverridesFolder As String, VersionFolder As String, Loader As LoaderBase, ProgressIncrement As Double)
|
||||
If Not OverridesFolder.EndsWithF("\") Then OverridesFolder += "\"
|
||||
If Not VersionFolder.EndsWithF("\") Then VersionFolder += "\"
|
||||
'复制文件
|
||||
If Directory.Exists(OverridesFolder) Then
|
||||
Log($"[ModPack] 处理整合包覆写文件夹：{OverridesFolder} → {VersionFolder}")
|
||||
CopyDirectory(OverridesFolder, VersionFolder, Sub(Delta) Loader.Progress += Delta * ProgressIncrement)
|
||||
Else
|
||||
Log($"[ModPack] 整合包中没有覆写文件夹：{OverridesFolder}")
|
||||
Loader.Progress += ProgressIncrement
|
||||
End If
|
||||
'设置 ini
|
||||
Dim OverridesIni As String = $"{OverridesFolder}PCL\Setup.ini"
|
||||
Dim VersionIni As String = $"{VersionFolder}PCL\Setup.ini"
|
||||
If File.Exists(OverridesIni) Then
|
||||
WriteIni(OverridesIni, "VersionArgumentIndie", 1) '开启版本隔离
|
||||
WriteIni(OverridesIni, "VersionArgumentIndieV2", True)
|
||||
WriteIni(OverridesIni, "IsStar", False)
|
||||
CopyFile(OverridesIni, VersionIni) '覆写已有的 ini
|
||||
Else
|
||||
WriteIni(VersionIni, "VersionArgumentIndie", 1) '开启版本隔离
|
||||
WriteIni(VersionIni, "VersionArgumentIndieV2", True)
|
||||
End If
|
||||
IniClearCache(VersionIni) '重置缓存，避免被安装过程中写入的 ini 覆盖
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 弹窗提示整合包中存在不兼容的加载器。
|
||||
''' 如果取消，则抛出 CancelledException。
|
||||
''' </summary>
|
||||
''' <exception cref="CancelledException" />
|
||||
Private Sub NotifyIncompatibleLoader(LoaderName As String)
|
||||
If MyMsgBox($"整合包中存在不兼容的加载器：{LoaderName}{vbCrLf}如果你知道如何手动安装它，可以先选择跳过，然后在整合包下载结束后手动安装。",
|
||||
"不兼容的加载器", "取消", $"不安装 {LoaderName} 并继续") = 1 Then Throw New CancelledException
|
||||
End Sub
|
||||
|
||||
#Region "不同类型整合包的安装方法"
|
||||
@@ -179,10 +220,11 @@ Retry:
|
||||
Log("[ModPack] 整合包 Fabric 版本：" & Id)
|
||||
FabricVersion = Id.Replace("fabric-", "")
|
||||
Else
|
||||
Log("[ModPack] 未知 Mod 加载器：" & Id)
|
||||
'ElseIf Id.StartsWithF("quilt-") Then
|
||||
NotifyIncompatibleLoader(Id)
|
||||
End If
|
||||
Next
|
||||
'解压与配置文件
|
||||
'解压
|
||||
Dim InstallTemp As String = RequestTaskTempFolder()
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
Dim OverrideHome As String = If(Json("overrides"), "")
|
||||
@@ -190,21 +232,10 @@ Retry:
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
|
||||
Task.Progress = 0.6
|
||||
'复制结果
|
||||
Log("[ModPack] 整合包 override 目标：" & OverrideHome)
|
||||
Dim OverrideRoot = InstallTemp & ArchiveBaseFolder & If(OverrideHome = "." OrElse OverrideHome = "./", "", OverrideHome) '#5613
|
||||
If Directory.Exists(OverrideRoot) Then
|
||||
Dim CopyTarget = $"{PathMcFolder}versions\{VersionName}"
|
||||
CopyDirectory(OverrideRoot, CopyTarget, Sub(Delta) Task.Progress += Delta * 0.35)
|
||||
Log($"[ModPack] 整合包 override 复制：{OverrideRoot} -> {CopyTarget}")
|
||||
Else
|
||||
Log($"[ModPack] 整合包中未找到 override 文件夹：{OverrideRoot}")
|
||||
End If
|
||||
Task.Progress = 0.95
|
||||
'开启版本隔离
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndieV2", True)
|
||||
CopyOverrideDirectory(
|
||||
InstallTemp & ArchiveBaseFolder & If(OverrideHome = "." OrElse OverrideHome = "./", "", OverrideHome), '#5613
|
||||
$"{PathMcFolder}versions\{VersionName}",
|
||||
Task, 0.4)
|
||||
End Sub) With {
|
||||
.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
End If
|
||||
@@ -224,7 +255,7 @@ Retry:
|
||||
'获取 Mod 下载信息
|
||||
ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
|
||||
Sub(Task As LoaderTask(Of Integer, JArray))
|
||||
Task.Output = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json"))("data")
|
||||
Task.Output = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & Join(ModList, ",") & "]}", "application/json")("data")
|
||||
'如果文件已被删除，则 API 会跳过那一项
|
||||
If ModList.Count > Task.Output.Count Then Throw New Exception("整合包中的部分 Mod 版本已被 Mod 作者删除，所以没法继续安装了，请向整合包作者反馈该问题")
|
||||
End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s
|
||||
@@ -238,29 +269,28 @@ Retry:
|
||||
If FileList.ContainsKey(Id) Then Continue For
|
||||
'可选 Mod 提示
|
||||
If ModOptionalList.Contains(Id) Then
|
||||
If MyMsgBox("是否要下载整合包中的可选文件 " & ModJson("displayName").ToString & "？",
|
||||
"下载可选文件", "是", "否") = 2 Then
|
||||
If MyMsgBox("是否要下载整合包中的可选文件 " & ModJson("displayName").ToString & "？", "下载可选文件", "是", "否") = 2 Then
|
||||
Continue For
|
||||
End If
|
||||
End If
|
||||
'建立 CompFile
|
||||
Dim File As New CompFile(ModJson, CompType.Mod)
|
||||
If Not File.Available Then Continue For
|
||||
'根据 modules 和文件名后缀判断资源类型
|
||||
Dim TargetFolder As String
|
||||
Dim TargetFolder As String, Type As CompType
|
||||
If ModJson("modules").Any Then 'modules 可能返回 null（#1006）
|
||||
Dim ModuleNames = CType(ModJson("modules"), JArray).Select(Function(l) l("name").ToString).ToList
|
||||
If ModuleNames.Contains("META-INF") OrElse ModuleNames.Contains("mcmod.info") OrElse
|
||||
File.FileName.EndsWithF(".jar", True) Then
|
||||
TargetFolder = "mods"
|
||||
ModJson?("FileName")?.ToString?.EndsWithF(".jar", True) Then
|
||||
TargetFolder = "mods" : Type = CompType.Mod
|
||||
ElseIf ModuleNames.Contains("pack.mcmeta") Then
|
||||
TargetFolder = "resourcepacks"
|
||||
TargetFolder = "resourcepacks" : Type = CompType.ResourcePack
|
||||
Else
|
||||
TargetFolder = "shaderpacks"
|
||||
TargetFolder = "shaderpacks" : Type = CompType.Shader
|
||||
End If
|
||||
Else
|
||||
TargetFolder = "mods"
|
||||
TargetFolder = "mods" : Type = CompType.Mod
|
||||
End If
|
||||
'建立 CompFile
|
||||
Dim File As New CompFile(ModJson, Type)
|
||||
If Not File.Available Then Continue For
|
||||
'实际的添加
|
||||
FileList.Add(Id, File.ToNetFile($"{PathMcFolder}versions\{VersionName}\{TargetFolder}\"))
|
||||
Task.Progress += 1 / (1 + ModList.Count)
|
||||
@@ -283,16 +313,11 @@ Retry:
|
||||
.NeoForgeVersion = NeoForgeVersion,
|
||||
.FabricVersion = FabricVersion
|
||||
}
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
'构造 Libraries 加载器
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
|
||||
Loaders.Add(New LoaderTask(Of String, String)("最终整理文件",
|
||||
Sub(Task As LoaderTask(Of String, String))
|
||||
'设置图标
|
||||
@@ -310,7 +335,7 @@ Retry:
|
||||
File.Delete(Target)
|
||||
End If
|
||||
Next
|
||||
If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then
|
||||
If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
|
||||
Log("[ModPack] 删除安装整合包文件：" & FileAddress)
|
||||
File.Delete(FileAddress)
|
||||
End If
|
||||
@@ -361,12 +386,9 @@ Retry:
|
||||
Case "fabric-loader" 'eg. 0.14.14
|
||||
FabricVersion = Entry.Value.ToString
|
||||
Log("[ModPack] 整合包 Fabric 版本：" & FabricVersion)
|
||||
Case "quilt-loader" 'eg. 1.0.0
|
||||
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
|
||||
Throw New CancelledException
|
||||
Case Else
|
||||
Hint($"无法安装整合包，其中出现了未知的 Mod 加载器 {Entry.Value}！", HintType.Critical)
|
||||
Throw New CancelledException
|
||||
'Case "quilt-loader" 'eg. 1.0.0
|
||||
NotifyIncompatibleLoader(Entry.Name)
|
||||
End Select
|
||||
Next
|
||||
'获取版本名
|
||||
@@ -377,29 +399,20 @@ Retry:
|
||||
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
|
||||
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
|
||||
End If
|
||||
'解压和配置文件
|
||||
'解压
|
||||
Dim InstallTemp As String = RequestTaskTempFolder()
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
|
||||
Task.Progress = 0.6
|
||||
'复制 overrides 文件夹和 client-overrides 文件夹
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
|
||||
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName,
|
||||
Sub(Delta) Task.Progress += Delta * 0.25)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 override 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.85
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "client-overrides") Then
|
||||
CopyDirectory(InstallTemp & ArchiveBaseFolder & "client-overrides", PathMcFolder & "versions\" & VersionName,
|
||||
Sub(Delta) Task.Progress += Delta * 0.1)
|
||||
End If
|
||||
Task.Progress = 0.95
|
||||
'开启版本隔离
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndieV2", True)
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.5)
|
||||
CopyOverrideDirectory(
|
||||
InstallTemp & ArchiveBaseFolder & "overrides",
|
||||
PathMcFolder & "versions\" & VersionName,
|
||||
Task, 0.4)
|
||||
CopyOverrideDirectory(
|
||||
InstallTemp & ArchiveBaseFolder & "client-overrides",
|
||||
PathMcFolder & "versions\" & VersionName,
|
||||
Task, 0.1)
|
||||
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
'获取下载文件列表
|
||||
Dim FileList As New List(Of NetFile)
|
||||
@@ -417,10 +430,15 @@ Retry:
|
||||
End Select
|
||||
End If
|
||||
'添加下载文件
|
||||
Dim Urls = File("downloads").Select(Function(t) t.ToString.Replace("://edge.forgecdn", "://media.forgecdn")).ToList
|
||||
Dim Urls = File("downloads").SelectMany(Function(t) CompFile.HandleCurseForgeDownloadUrls(t.ToString)).ToList
|
||||
Urls.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList)
|
||||
Urls = Urls.Distinct.ToList()
|
||||
FileList.Add(New NetFile(Urls, PathMcFolder & "versions\" & VersionName & "\" & File("path").ToString,
|
||||
Dim TargetPath As String = $"{PathMcFolder}versions\{VersionName}\{File("path")}"
|
||||
If Not IO.Path.GetFullPath(TargetPath).StartsWithF($"{PathMcFolder}versions\{VersionName}\", True) Then
|
||||
MyMsgBox($"整合包的文件路径超出了版本文件夹，请向整合包作者反馈此问题！" & vbCrLf & "错误的文件：" & TargetPath, "文件路径校验失败", IsWarn:=True)
|
||||
Throw New CancelledException
|
||||
End If
|
||||
FileList.Add(New NetFile(Urls, TargetPath,
|
||||
New FileChecker(ActualSize:=File("fileSize").ToObject(Of Long), Hash:=File("hashes")("sha1").ToString), True))
|
||||
Next
|
||||
If FileList.Any Then
|
||||
@@ -436,20 +454,15 @@ Retry:
|
||||
.NeoForgeVersion = NeoForgeVersion,
|
||||
.FabricVersion = FabricVersion
|
||||
}
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
'构造 Libraries 加载器
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
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 VersionFolder As String = PathMcFolder & "versions\" & VersionName & "\"
|
||||
Dim VersionFolder As String = $"{PathMcFolder}versions\{VersionName}\"
|
||||
If Logo IsNot Nothing AndAlso File.Exists(Logo) Then
|
||||
File.Copy(Logo, VersionFolder & "PCL\Logo.png", True)
|
||||
WriteIni(VersionFolder & "PCL\Setup.ini", "Logo", "PCL\Logo.png")
|
||||
@@ -463,7 +476,7 @@ Retry:
|
||||
File.Delete(Target)
|
||||
End If
|
||||
Next
|
||||
If File.Exists(FileAddress) AndAlso GetFileNameWithoutExtentionFromPath(FileAddress) = "modpack" Then
|
||||
If File.Exists(FileAddress) AndAlso IO.Path.GetFileNameWithoutExtension(FileAddress) = "modpack" Then
|
||||
Log("[ModPack] 删除安装整合包文件：" & FileAddress)
|
||||
File.Delete(FileAddress)
|
||||
End If
|
||||
@@ -500,67 +513,38 @@ Retry:
|
||||
If Validate.Validate(VersionName) <> "" Then VersionName = ""
|
||||
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
|
||||
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
|
||||
'解压与配置文件
|
||||
'解压
|
||||
Dim InstallTemp As String = RequestTaskTempFolder()
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
|
||||
Task.Progress = 0.6
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "minecraft") Then
|
||||
CopyDirectory(InstallTemp & ArchiveBaseFolder & "minecraft", PathMcFolder & "versions\" & VersionName, Sub(Delta) Task.Progress += Delta * 0.35)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 minecraft override 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.95
|
||||
'开启版本隔离
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndieV2", True)
|
||||
CopyOverrideDirectory(
|
||||
InstallTemp & ArchiveBaseFolder & "minecraft",
|
||||
PathMcFolder & "versions\" & VersionName,
|
||||
Task, 0.4)
|
||||
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
'构造加载器
|
||||
'构造游戏本体安装加载器
|
||||
If Json("gameVersion") Is Nothing Then Throw New Exception("该 HMCL 整合包未提供游戏版本信息，无法安装！")
|
||||
Dim Request As New McInstallRequest With {
|
||||
.TargetVersionName = VersionName,
|
||||
.TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\",
|
||||
.MinecraftName = Json("gameVersion").ToString
|
||||
}
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, String)("重命名版本 Json（副加载器）",
|
||||
Sub()
|
||||
Dim RealFileName As String = PathMcFolder & "versions\" & VersionName & "\" & VersionName & ".json"
|
||||
Dim OldFileName As String = PathMcFolder & "versions\" & VersionName & "\pack.json"
|
||||
If File.Exists(OldFileName) Then
|
||||
'修改 id
|
||||
Dim FileJson = GetJson(ReadFile(OldFileName))
|
||||
FileJson("id") = VersionName
|
||||
'替换文件
|
||||
File.Delete(OldFileName)
|
||||
WriteFile(RealFileName, FileJson.ToString)
|
||||
Log("[ModPack] 已重命名版本 Json：" & RealFileName)
|
||||
End If
|
||||
End Sub) With {.ProgressWeight = 0.1, .Show = False})
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase) From {
|
||||
New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)},
|
||||
New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)},
|
||||
New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8}
|
||||
New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)},
|
||||
New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)}
|
||||
}
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "HMCL 整合包安装：" & VersionName & " "
|
||||
If LoaderTaskbar.Any(Function(l) l.Name = LoaderName) Then
|
||||
Hint("该整合包正在安装中！", HintType.Critical)
|
||||
Throw New CancelledException
|
||||
End If
|
||||
|
||||
'启动
|
||||
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
|
||||
'If Archive IsNot Nothing Then Archive.Dispose() '解除占用，以免在加载器中触发 “正由另一进程使用，因此该进程无法访问此文件”
|
||||
Loader.Start(Request.TargetVersionFolder)
|
||||
LoaderTaskbarAdd(Loader)
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
@@ -584,24 +568,17 @@ Retry:
|
||||
If Validate.Validate(VersionName) <> "" Then VersionName = ""
|
||||
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
|
||||
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
|
||||
'解压、配置设置文件
|
||||
'解压
|
||||
Dim InstallTemp As String = RequestTaskTempFolder()
|
||||
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
|
||||
Task.Progress = 0.6
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & ".minecraft") Then
|
||||
CopyDirectory(InstallTemp & ArchiveBaseFolder & ".minecraft", PathMcFolder & "versions\" & VersionName, Sub(Delta) Task.Progress += Delta * 0.35)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 override .minecraft 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.95
|
||||
'开启版本隔离
|
||||
WriteIni(SetupFile, "VersionArgumentIndie", 1)
|
||||
WriteIni(SetupFile, "VersionArgumentIndieV2", True)
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.55)
|
||||
CopyOverrideDirectory(
|
||||
InstallTemp & ArchiveBaseFolder & ".minecraft",
|
||||
PathMcFolder & "versions\" & VersionName,
|
||||
Task, 0.4)
|
||||
'读取 MMC 设置文件（#2655）
|
||||
Try
|
||||
Dim MMCSetupFile As String = InstallTemp & ArchiveBaseFolder & "instance.cfg"
|
||||
@@ -663,7 +640,8 @@ Retry:
|
||||
If PackJson("components") Is Nothing Then Throw New Exception("该 MMC 整合包未提供游戏版本信息，无法安装！")
|
||||
Dim Request As New McInstallRequest With {.TargetVersionName = VersionName, .TargetVersionFolder = $"{PathMcFolder}versions\{VersionName}\"}
|
||||
For Each Component In PackJson("components")
|
||||
Select Case If(Component("uid"), "").ToString
|
||||
If Not Component.Contains("uid") Then Continue For
|
||||
Select Case Component("uid").ToString
|
||||
Case "org.lwjgl"
|
||||
Log("[ModPack] 已跳过 LWJGL 项")
|
||||
Case "net.minecraft"
|
||||
@@ -674,22 +652,17 @@ Retry:
|
||||
Request.NeoForgeVersion = Component("version")
|
||||
Case "net.fabricmc.fabric-loader"
|
||||
Request.FabricVersion = Component("version")
|
||||
Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
|
||||
Hint("PCL 暂不支持安装需要 Quilt 的整合包！", HintType.Critical)
|
||||
Throw New CancelledException
|
||||
Case Else
|
||||
'Case "org.quiltmc.quilt-loader" 'eg. 1.0.0
|
||||
NotifyIncompatibleLoader(Component("uid"))
|
||||
End Select
|
||||
Next
|
||||
'构造加载器
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
'构造 Libraries 加载器
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "MMC 整合包安装：" & VersionName & " "
|
||||
@@ -726,24 +699,23 @@ Retry:
|
||||
If VersionName = "" Then VersionName = MyMsgBoxInput("输入版本名称", "", "", New ObjectModel.Collection(Of Validate) From {Validate})
|
||||
If String.IsNullOrEmpty(VersionName) Then Throw New CancelledException
|
||||
End If
|
||||
'解压与配置文件
|
||||
'解压
|
||||
Dim InstallTemp As String = RequestTaskTempFolder()
|
||||
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
ExtractModpackFiles(InstallTemp, FileAddress, Task, 0.6)
|
||||
Task.Progress = 0.6
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
|
||||
CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName,
|
||||
Sub(Delta) Task.Progress += 0.35 * Delta)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 overrides 目录，已跳过")
|
||||
CopyOverrideDirectory(
|
||||
InstallTemp & ArchiveBaseFolder & "overrides",
|
||||
PathMcFolder & "versions\" & VersionName,
|
||||
Task, 0.4)
|
||||
'JVM 参数
|
||||
If Json("launchInfo") IsNot Nothing Then
|
||||
Dim LaunchInfo As JObject = Json("launchInfo")
|
||||
If LaunchInfo.ContainsKey("javaArgument") Then WriteIni(SetupFile, "VersionAdvanceJvm", String.Join(" ", LaunchInfo("javaArgument")))
|
||||
If LaunchInfo.ContainsKey("launchArgument") Then WriteIni(SetupFile, "VersionAdvanceGame", String.Join(" ", LaunchInfo("launchArgument")))
|
||||
End If
|
||||
Task.Progress = 0.95
|
||||
'开启版本隔离
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
WriteIni($"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini", "VersionArgumentIndieV2", True)
|
||||
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
'构造加载器
|
||||
If Json("addons") Is Nothing Then Throw New Exception("该 MCBBS 整合包未提供游戏版本附加信息，无法安装！")
|
||||
@@ -765,16 +737,11 @@ Retry:
|
||||
.NeoForgeVersion = If(Addons.ContainsKey("neoforge"), Addons("neoforge"), Nothing),
|
||||
.FabricVersion = If(Addons.ContainsKey("fabric"), Addons("fabric"), Nothing)
|
||||
}
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
'构造 Libraries 加载器
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request)
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeLoaders.Sum(Function(l) l.ProgressWeight)})
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "MCBBS 整合包安装：" & VersionName & " "
|
||||
@@ -828,7 +795,7 @@ Retry:
|
||||
Log("[Modpack] 找到压缩包中附带的启动器：" & Launcher)
|
||||
If MyMsgBox($"整合包里似乎自带了启动器，是否换用它继续安装？{vbCrLf}即将打开：{Launcher}", "换用整合包启动器？", "换用", "不换用") = 1 Then
|
||||
OpenExplorer(TargetFolder)
|
||||
ShellOnly(Launcher, "--wait") '要求等待已有的 PCL 退出
|
||||
StartProcess(Launcher, "--wait") '要求等待已有的 PCL 退出
|
||||
Log("[Modpack] 为换用整合包中的启动器启动，强制结束程序")
|
||||
FrmMain.EndProgram(False)
|
||||
Return
|
||||
|
||||
@@ -15,7 +15,7 @@
|
||||
TriggerLauncherShutdown = False
|
||||
End If
|
||||
Next
|
||||
If IsWatcherRunning = IsRunning Then Exit Sub
|
||||
If IsWatcherRunning = IsRunning Then Return
|
||||
IsWatcherRunning = IsRunning
|
||||
If IsWatcherRunning Then
|
||||
MinecraftStart()
|
||||
@@ -81,7 +81,7 @@
|
||||
WatcherStateChanged()
|
||||
|
||||
'初始化进程与日志读取
|
||||
Me.GameProcess = Loader.Input
|
||||
GameProcess = Loader.Input
|
||||
GameProcess.BeginOutputReadLine()
|
||||
GameProcess.BeginErrorReadLine()
|
||||
AddHandler GameProcess.OutputDataReceived, AddressOf LogReceived
|
||||
@@ -118,7 +118,7 @@
|
||||
Return _State
|
||||
End Get
|
||||
Set(value As MinecraftState)
|
||||
If _State = value Then Exit Property
|
||||
If _State = value Then Return
|
||||
_State = value
|
||||
WatcherStateChanged()
|
||||
End Set
|
||||
@@ -144,7 +144,7 @@
|
||||
'输出文本
|
||||
Dim Copyed As New List(Of String)
|
||||
SyncLock WaitingLogLock
|
||||
If Not WaitingLog.Any() Then Exit Sub
|
||||
If Not WaitingLog.Any() Then Return
|
||||
Copyed = WaitingLog
|
||||
WaitingLog = New List(Of String)(1000)
|
||||
End SyncLock
|
||||
@@ -180,8 +180,9 @@
|
||||
Public LatestLog As New Queue(Of String)
|
||||
Private Sub GameLog(Text As String)
|
||||
'预处理
|
||||
If Text Is Nothing Then Exit Sub
|
||||
If Text Is Nothing Then Return
|
||||
Text = Text.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf)
|
||||
'If Text.Contains("�����") Then Hint("检测到错误的日志编码：" & Text)
|
||||
'加入预存储
|
||||
LatestLog.Enqueue(Text)
|
||||
If LatestLog.Count >= 501 Then LatestLog.Dequeue()
|
||||
@@ -256,8 +257,8 @@
|
||||
Private WindowHandle As IntPtr
|
||||
Private Sub TimerWindow()
|
||||
Try
|
||||
If GameProcess.HasExited Then Exit Sub
|
||||
If IsWindowFinished Then Exit Sub
|
||||
If GameProcess.HasExited Then Return
|
||||
If IsWindowFinished Then Return
|
||||
'获取全部窗口，检查是否有新增的
|
||||
Dim MinecraftWindow As KeyValuePair(Of IntPtr, String)? = Nothing
|
||||
Try
|
||||
@@ -267,10 +268,10 @@
|
||||
Log(ex, "由于反作弊或安全软件拦截，PCL 无法操作游戏窗口", LogLevel.Hint)
|
||||
IsWindowFinished = True
|
||||
End Try
|
||||
If MinecraftWindow Is Nothing Then Exit Sub
|
||||
If MinecraftWindow Is Nothing Then Return
|
||||
Dim MinecraftWindowName = MinecraftWindow.Value.Value, MinecraftWindowHandle = MinecraftWindow.Value.Key
|
||||
'已找到窗口
|
||||
If Not MinecraftWindowName.StartsWithF("FML") Then
|
||||
If Not MinecraftWindowName.StartsWithF("FML") AndAlso Not MinecraftWindowName.StartsWithF("Quilt Loader") Then
|
||||
'已找到 Minecraft 窗口
|
||||
WindowHandle = MinecraftWindowHandle
|
||||
WatcherLog($"Minecraft 窗口已加载：{MinecraftWindowName}（{MinecraftWindowHandle.ToInt64}）")
|
||||
@@ -291,8 +292,8 @@
|
||||
End Sub, "MinecraftWindowMaximize")
|
||||
End If
|
||||
ElseIf Not IsWindowAppeared Then
|
||||
'已找到 FML 窗口
|
||||
WatcherLog("FML 窗口已加载：" & MinecraftWindowName & "（" & MinecraftWindowHandle.ToInt64 & "）")
|
||||
'已找到 Mod Loader 窗口
|
||||
WatcherLog("Mod Loader 窗口已加载：" & MinecraftWindowName & "（" & MinecraftWindowHandle.ToInt64 & "）")
|
||||
End If
|
||||
IsWindowAppeared = True
|
||||
Catch ex As Exception
|
||||
@@ -307,27 +308,27 @@
|
||||
TryGetMinecraftWindow = Nothing
|
||||
EnumWindows(
|
||||
Sub(hwnd As IntPtr, lParam As Integer)
|
||||
If TryGetMinecraftWindow IsNot Nothing Then Exit Sub
|
||||
If TryGetMinecraftWindow IsNot Nothing Then Return
|
||||
'检查类名
|
||||
Dim str As New StringBuilder(512)
|
||||
GetClassName(hwnd, str, str.Capacity)
|
||||
Dim ClassName As String = str.ToString
|
||||
If Not (ClassName = "GLFW30" OrElse ClassName = "LWJGL" OrElse ClassName = "SunAwtFrame") Then Exit Sub
|
||||
If Not (ClassName = "GLFW30" OrElse ClassName = "LWJGL" OrElse ClassName = "SunAwtFrame") Then Return
|
||||
'获取窗口标题名
|
||||
str = New StringBuilder(512)
|
||||
GetWindowText(hwnd, str, str.Capacity)
|
||||
Dim WindowText As String = str.ToString
|
||||
'有的 Mod 可以修改窗口标题，所以不能检测是否为 Minecraft 打头，这并不准确
|
||||
'部分版本会搞个 GLFW message window 出来所以得反选
|
||||
If Not (WindowText.StartsWithF("FML") OrElse (WindowText <> "PopupMessageWindow") AndAlso Not WindowText.StartsWithF("GLFW")) Then Exit Sub
|
||||
If Not (WindowText.StartsWithF("FML") OrElse (WindowText <> "PopupMessageWindow") AndAlso Not WindowText.StartsWithF("GLFW")) Then Return
|
||||
'获取窗口关联的进程
|
||||
Dim ProcessId As Integer
|
||||
GetWindowThreadProcessId(hwnd, ProcessId)
|
||||
Try
|
||||
If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Exit Sub '需要是此后启动的进程
|
||||
If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Return '需要是此后启动的进程
|
||||
Catch ex As Exception
|
||||
Log(ex, "枚举 Minecraft 窗口进程失败")
|
||||
Exit Sub
|
||||
Return
|
||||
End Try
|
||||
'返回
|
||||
TryGetMinecraftWindow = New KeyValuePair(Of IntPtr, String)(hwnd, WindowText)
|
||||
@@ -344,18 +345,18 @@
|
||||
|
||||
'崩溃处理
|
||||
Private Sub Crashed()
|
||||
If State = MinecraftState.Crashed OrElse State = MinecraftState.Ended Then Exit Sub
|
||||
If State = MinecraftState.Crashed OrElse State = MinecraftState.Ended Then Return
|
||||
State = MinecraftState.Crashed
|
||||
'崩溃分析
|
||||
WatcherLog("Minecraft 已崩溃，将在 2 秒后开始崩溃分析")
|
||||
Hint("检测到 Minecraft 出现错误，错误分析已开始……")
|
||||
Hint("检测到 Minecraft 出现错误，错误分析已开始……", HintType.Critical)
|
||||
FeedbackInfo()
|
||||
RunInNewThread(
|
||||
Sub()
|
||||
Try
|
||||
Thread.Sleep(2000)
|
||||
WatcherLog("崩溃分析开始")
|
||||
Dim Analyzer As New CrashAnalyzer(PID)
|
||||
Dim Analyzer As New CrashAnalyzer(Version)
|
||||
Analyzer.Collect(Version.PathIndie, LatestLog.ToList)
|
||||
Analyzer.Prepare()
|
||||
Analyzer.Analyze(Version)
|
||||
|
||||
@@ -1,84 +0,0 @@
|
||||
<Grid x:Class="MyCompItem"
|
||||
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
|
||||
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
|
||||
xmlns:local="clr-namespace:PCL"
|
||||
x:Name="PanBack" Height="64"
|
||||
RenderTransformOrigin="0.5,0.5" Background="{StaticResource ColorBrushSemiTransparent}" SnapsToDevicePixels="True">
|
||||
<Grid.ColumnDefinitions>
|
||||
<ColumnDefinition Width="7" />
|
||||
<ColumnDefinition Width="50" />
|
||||
<ColumnDefinition Width="8" />
|
||||
<ColumnDefinition Width="Auto" />
|
||||
<ColumnDefinition Width="1*" />
|
||||
</Grid.ColumnDefinitions>
|
||||
<Grid.RowDefinitions>
|
||||
<RowDefinition Height="1*" />
|
||||
<RowDefinition Height="17" />
|
||||
<RowDefinition Height="18" />
|
||||
<RowDefinition Height="16" />
|
||||
<RowDefinition Height="1.1*" />
|
||||
</Grid.RowDefinitions>
|
||||
<!-- Logo -->
|
||||
<Border Grid.Column="1" Grid.Row="1" Grid.RowSpan="3" IsHitTestVisible="False" SnapsToDevicePixels="True" UseLayoutRounding="True"
|
||||
HorizontalAlignment="Right" VerticalAlignment="Center" Width="50" Height="50">
|
||||
<Border.Clip>
|
||||
<RectangleGeometry Rect="0,0,50,50" RadiusX="6" RadiusY="6" />
|
||||
</Border.Clip>
|
||||
<local:MyImage x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" FallbackSource="pack://application:,,,/images/Icons/NoIcon.png" />
|
||||
</Border>
|
||||
<!-- 标题 -->
|
||||
<StackPanel Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0" Orientation="Horizontal"
|
||||
IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False">
|
||||
<TextBlock x:Name="LabTitle" TextTrimming="WordEllipsis" FontSize="14" Foreground="{DynamicResource ColorBrush1}" />
|
||||
<TextBlock x:Name="LabTitleRaw" TextTrimming="WordEllipsis" FontSize="12" Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
|
||||
</StackPanel>
|
||||
<!-- Tag 与 详情 -->
|
||||
<StackPanel x:Name="PanTags" Grid.Row="2" Grid.Column="3" Orientation="Horizontal" VerticalAlignment="Bottom" Margin="-1,0,1,0" Visibility="Collapsed">
|
||||
<!--<Border Background="{DynamicResource ColorBrush6}" Padding="3,1" CornerRadius="3" Margin="0,0,4,0" SnapsToDevicePixels="True" UseLayoutRounding="False">
|
||||
<TextBlock Text="科技" Foreground="{DynamicResource ColorBrush2}" FontSize="11" />
|
||||
</Border>-->
|
||||
</StackPanel>
|
||||
<TextBlock x:Name="LabInfo" Grid.Row="2" Grid.Column="4" VerticalAlignment="Bottom" Margin="0,0,3,0.5"
|
||||
TextTrimming="CharacterEllipsis" FontSize="12" Foreground="{StaticResource ColorBrushGray3}"
|
||||
IsHitTestVisible="True" SnapsToDevicePixels="False" UseLayoutRounding="False"
|
||||
ToolTipService.InitialShowDelay="100" ToolTipService.BetweenShowDelay="100"
|
||||
ToolTipService.Placement="Relative" ToolTipService.PlacementRectangle="-16,-10,500,10000">
|
||||
<TextBlock.ToolTip>
|
||||
<ToolTip x:Name="ToolTipInfo" Style="{StaticResource ExtendTextToolTip}" />
|
||||
</TextBlock.ToolTip>
|
||||
</TextBlock>
|
||||
<!-- 下边栏 -->
|
||||
<Grid Grid.Row="3" Grid.Column="3" Grid.ColumnSpan="2" VerticalAlignment="Bottom"
|
||||
IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False">
|
||||
<Grid.ColumnDefinitions>
|
||||
<ColumnDefinition x:Name="ColumnVersion1" Width="Auto" />
|
||||
<ColumnDefinition x:Name="ColumnVersion2" Width="Auto" SharedSizeGroup="CompItemVersion" />
|
||||
<ColumnDefinition x:Name="ColumnVersion3" Width="0.7*" />
|
||||
|
||||
<ColumnDefinition Width="Auto" />
|
||||
<ColumnDefinition Width="55" />
|
||||
<ColumnDefinition Width="1*" />
|
||||
|
||||
<ColumnDefinition x:Name="ColumnTime1" Width="Auto" />
|
||||
<ColumnDefinition x:Name="ColumnTime2" Width="Auto" MinWidth="57" SharedSizeGroup="CompItemTime" />
|
||||
<ColumnDefinition x:Name="ColumnTime3" Width="1*" />
|
||||
|
||||
<ColumnDefinition Width="Auto" />
|
||||
<ColumnDefinition Width="Auto" SharedSizeGroup="CompItemSource" />
|
||||
<ColumnDefinition Width="1.7*" />
|
||||
</Grid.ColumnDefinitions>
|
||||
<Path x:Name="PathVersion" Grid.Column="0" Fill="{StaticResource ColorBrushGray3}" Stretch="Uniform" Height="11"
|
||||
Data="M940.4 463.7L773.3 174.2c-17.3-30-49.2-48.4-83.8-48.4H340.2c-34.6 0-66.5 18.5-83.8 48.4L89.2 463.7c-17.3 30-17.3 66.9 0 96.8L256.4 850c17.3 30 49.2 48.4 83.8 48.4h349.2c34.6 0 66.5-18.5 83.8-48.4l167.2-289.5c17.3-29.9 17.3-66.8 0-96.8z m-94.6 96.8L725.9 768.1c-17.3 30-49.2 48.4-83.8 48.4H387.5c-34.6 0-66.5-18.5-83.8-48.4L183.9 560.5c-17.3-30-17.3-66.9 0-96.8l119.8-207.5c17.3-30 49.2-48.4 83.8-48.4h254.6c34.6 0 66.5 18.5 83.8 48.4l119.8 207.5c17.3 30 17.3 66.9 0.1 96.8z M522.3 321.2c-2.5-0.1-5-0.2-7.5-0.2-119.9 0-214 110.3-186.3 235 15.8 70.9 71.5 126.6 142.4 142.4 17.5 3.9 34.7 5.4 51.4 4.7 102.1-3.9 183.6-87.9 183.6-191 0.1-103-81.5-187-183.6-190.9z m68.6 269.1c-18.5 18-43 28.9-68.6 30.7l-6 0.3c-30.2 0.4-58.6-11.4-79.7-33-19.5-20.1-30.7-47-30.9-75-0.3-29.6 11.1-57.4 32-78.3 20.6-20.6 48-32 77.2-32 2.5 0 5 0.1 7.5 0.3 26.7 1.8 51.5 13.2 70.5 32.5 19.6 20 30.8 46.9 31.2 74.9 0.2 30.2-11.5 58.6-33.2 79.6z" />
|
||||
<TextBlock x:Name="LabVersion" Grid.Column="1" Margin="4,0,2,0" VerticalAlignment="Center" Foreground="{StaticResource ColorBrushGray3}" FontSize="12"
|
||||
TextTrimming="WordEllipsis" />
|
||||
<Path x:Name="PathDownload" Grid.Column="3" Fill="{StaticResource ColorBrushGray4}" Stretch="Uniform" Height="10.5"
|
||||
Data="M955 610h-59c-15 0-29 13-29 29v196c0 15-13 29-29 29h-649c-15 0-29-13-29-29v-196c0-15-13-29-29-29h-59c-15 0-29 13-29 29V905c0 43 35 78 78 78h787c43 0 78-35 78-78V640c0-15-13-29-29-29zM492 740c11 11 29 11 41 0l265-265c11-11 11-29 0-41l-41-41c-11-11-29-11-41 0l-110 110c-11 11-33 3-33-13V68C571 53 555 39 541 39h-59c-15 0-29 13-29 29v417c0 17-21 25-33 13l-110-110c-11-11-29-11-41 0L226 433c-11 11-11 29 0 41L492 740z" />
|
||||
<TextBlock x:Name="LabDownload" Grid.Column="4" Margin="5,0,2,0" VerticalAlignment="Center" Foreground="{StaticResource ColorBrushGray4}" FontSize="12" />
|
||||
<Path x:Name="PathTime" Grid.Column="6" Fill="{StaticResource ColorBrushGray4}" Stretch="Uniform" Height="11.5" Margin="0,0,1,0"
|
||||
Data="M810 403l-39 39c-10 10-28 10-39 0l-162-162v412c0 15-12 28-28 28h-56c-15 0-28-12-28-28v-412l-162 162c-10 10-28 10-39 0l-39-39c-10-10-10-28 0-39l278-278c10-10 28-10 39 0l278 278c10 10 10 28-0 39zM568 946h-112v-112h112v112z" />
|
||||
<TextBlock x:Name="LabTime" Grid.Column="7" Margin="5,0,2,0" VerticalAlignment="Center" Foreground="{StaticResource ColorBrushGray4}" FontSize="12" />
|
||||
<Path x:Name="PathSource" Grid.Column="9" Fill="{StaticResource ColorBrushGray4}" Stretch="Uniform" Height="11.5"
|
||||
Data="M511 143c-203 0-369 165-369 369 0 203 165 369 369 369s369-165 369-369c0-203-165-369-369-369z m0 673c-29 0-68-59-89-159l178 0c-20 100-59 159-89 159z m-98-224c-2-24-3-51-3-79 0-29 1-57 4-83l197 0c2 25 4 53 4 83 0 28-1 54-3 79l-198-0z m98-383c29 0 67 58 88 156l-177-0c20-98 59-155 88-155z m164 221l128 0c7 26 11 54 11 82 0 27-3 54-10 80l-129-0c2-26 3-52 3-79 0-28-1-56-4-83z m101-64l-110-0c-7-37-16-72-28-102-4-11-9-22-15-33 66 25 121 74 155 135z m-376-135c-5 10-10 21-15 33-12 30-21 64-28 102l-110-0c34-60 89-109 154-134z m-181 199l128 0c-2 27-3 54-3 83 0 27 1 53 3 79l-127-0v6c-8-27-12-55-12-85-0-29 3-57 11-83z m24 227l112 0c7 38 16 74 29 105 4 11 9 22 15 33-67-26-122-76-156-139zM621 795c5-10 10-21 15-33 12-30 22-66 29-105l111 0c-34 62-89 111-156 137z" />
|
||||
<TextBlock x:Name="LabSource" Grid.Column="10" Margin="5,0,2,0" VerticalAlignment="Center" Foreground="{StaticResource ColorBrushGray4}" FontSize="12" />
|
||||
</Grid>
|
||||
</Grid>
|
||||
@@ -1,224 +0,0 @@
|
||||
Public Class MyCompItem
|
||||
|
||||
#Region "基础属性"
|
||||
Public Uuid As Integer = GetUuid()
|
||||
|
||||
'Logo
|
||||
Public Property Logo As String
|
||||
Get
|
||||
Return PathLogo.Source
|
||||
End Get
|
||||
Set(value As String)
|
||||
PathLogo.Source = value
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'标题
|
||||
Public Property Title As String
|
||||
Get
|
||||
Return LabTitle.Text
|
||||
End Get
|
||||
Set(value As String)
|
||||
If LabTitle.Text = value Then Exit Property
|
||||
LabTitle.Text = value
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'副标题
|
||||
Public Property SubTitle As String
|
||||
Get
|
||||
Return If(LabTitleRaw?.Text, "")
|
||||
End Get
|
||||
Set(value As String)
|
||||
If LabTitleRaw.Text = value Then Exit Property
|
||||
LabTitleRaw.Text = value
|
||||
LabTitleRaw.Visibility = If(value = "", Visibility.Collapsed, Visibility.Visible)
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'描述
|
||||
Public Property Description As String
|
||||
Get
|
||||
Return LabInfo.Text
|
||||
End Get
|
||||
Set(value As String)
|
||||
If LabInfo.Text = value Then Exit Property
|
||||
LabInfo.Text = value
|
||||
End Set
|
||||
End Property
|
||||
'指向时扩展描述
|
||||
Private Sub LabInfo_MouseEnter(sender As Object, e As MouseEventArgs) Handles LabInfo.MouseEnter
|
||||
If IsTextTrimmed(LabInfo) Then
|
||||
ToolTipInfo.Content = LabInfo.Text
|
||||
ToolTipInfo.Width = LabInfo.ActualWidth + 25
|
||||
LabInfo.ToolTip = ToolTipInfo
|
||||
Else
|
||||
LabInfo.ToolTip = Nothing
|
||||
End If
|
||||
End Sub
|
||||
Private Function IsTextTrimmed(textBlock As TextBlock) As Boolean
|
||||
Dim typeface As New Typeface(textBlock.FontFamily, textBlock.FontStyle, textBlock.FontWeight, textBlock.FontStretch)
|
||||
Dim formattedText As New FormattedText(textBlock.Text, Thread.CurrentThread.CurrentCulture, textBlock.FlowDirection, typeface, textBlock.FontSize, textBlock.Foreground, DPI)
|
||||
Return formattedText.Width > textBlock.ActualWidth
|
||||
End Function
|
||||
|
||||
'Tag
|
||||
Public WriteOnly Property Tags As List(Of String)
|
||||
Set(value As List(Of String))
|
||||
PanTags.Children.Clear()
|
||||
PanTags.Visibility = If(value.Any(), Visibility.Visible, Visibility.Collapsed)
|
||||
For Each TagText In value
|
||||
Dim NewTag = GetObjectFromXML(
|
||||
"<Border xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation""
|
||||
Background=""#11000000"" Padding=""3,1"" CornerRadius=""3"" Margin=""0,0,3,0""
|
||||
SnapsToDevicePixels=""True"" UseLayoutRounding=""False"">
|
||||
<TextBlock Text=""" & TagText & """ Foreground=""#868686"" FontSize=""11"" />
|
||||
</Border>")
|
||||
PanTags.Children.Add(NewTag)
|
||||
Next
|
||||
End Set
|
||||
End Property
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "点击"
|
||||
|
||||
'触发点击事件
|
||||
Public Event Click(sender As Object, e As MouseButtonEventArgs)
|
||||
Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp
|
||||
If IsMouseDown Then
|
||||
RaiseEvent Click(sender, e)
|
||||
If e.Handled Then Exit Sub
|
||||
Log("[Control] 按下资源工程列表项：" & LabTitle.Text)
|
||||
End If
|
||||
End Sub
|
||||
Private Sub ProjectClick(sender As MyCompItem, e As EventArgs) Handles Me.Click
|
||||
'记录当前展开的卡片标题（#2712）
|
||||
Dim Titles As New List(Of String)
|
||||
If FrmMain.PageCurrent.Page = FormMain.PageType.CompDetail Then
|
||||
For Each Card As MyCard In FrmDownloadCompDetail.PanResults.Children
|
||||
If Card.Title <> "" AndAlso Not Card.IsSwaped Then Titles.Add(Card.Title)
|
||||
Next
|
||||
Log("[Comp] 记录当前已展开的卡片：" & String.Join("、", Titles))
|
||||
FrmMain.PageCurrent.Additional(1) = Titles
|
||||
End If
|
||||
'打开详情页
|
||||
Dim TargetVersion As String
|
||||
Dim TargetLoader As CompModLoaderType
|
||||
If FrmMain.PageCurrent.Page = FormMain.PageType.CompDetail Then
|
||||
TargetVersion = FrmMain.PageCurrent.Additional(2)
|
||||
TargetLoader = FrmMain.PageCurrent.Additional(3)
|
||||
Else
|
||||
Select Case CType(sender.Tag, CompProject).Type
|
||||
Case CompType.Mod
|
||||
TargetVersion = If(PageDownloadMod.Loader.Input.GameVersion, "")
|
||||
TargetLoader = PageDownloadMod.Loader.Input.ModLoader
|
||||
Case CompType.ModPack
|
||||
TargetVersion = If(PageDownloadPack.Loader.Input.GameVersion, "")
|
||||
Case Else 'CompType.ResourcePack
|
||||
'FUTURE: Res
|
||||
TargetVersion = "" 'If(PageDownloadResource.Loader.Input.GameVersion, "")
|
||||
End Select
|
||||
End If
|
||||
If CType(sender.Tag, CompProject).Type <> CompType.Mod Then TargetLoader = CompModLoaderType.Any
|
||||
FrmMain.PageChange(New FormMain.PageStackData With {.Page = FormMain.PageType.CompDetail,
|
||||
.Additional = {sender.Tag, New List(Of String), TargetVersion, TargetLoader}})
|
||||
End Sub
|
||||
|
||||
'鼠标点击判定
|
||||
Private IsMouseDown As Boolean = False
|
||||
Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonDown
|
||||
If IsMouseOver AndAlso CanInteraction Then IsMouseDown = True
|
||||
End Sub
|
||||
Private Sub Button_MouseLeave(sender As Object, e As Object) Handles Me.MouseLeave, Me.PreviewMouseLeftButtonUp
|
||||
IsMouseDown = False
|
||||
End Sub
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "后加载指向背景"
|
||||
|
||||
Private _RectBack As Border = Nothing
|
||||
Public ReadOnly Property RectBack As Border
|
||||
Get
|
||||
If _RectBack Is Nothing Then
|
||||
Dim Rect As New Border With {
|
||||
.Name = "RectBack",
|
||||
.CornerRadius = New CornerRadius(3),
|
||||
.RenderTransform = New ScaleTransform(0.8, 0.8),
|
||||
.RenderTransformOrigin = New Point(0.5, 0.5),
|
||||
.BorderThickness = New Thickness(GetWPFSize(1)),
|
||||
.SnapsToDevicePixels = True,
|
||||
.IsHitTestVisible = False,
|
||||
.Opacity = 0
|
||||
}
|
||||
Rect.SetResourceReference(Border.BackgroundProperty, "ColorBrush7")
|
||||
Rect.SetResourceReference(Border.BorderBrushProperty, "ColorBrush6")
|
||||
SetColumnSpan(Rect, 999)
|
||||
SetRowSpan(Rect, 999)
|
||||
Children.Insert(0, Rect)
|
||||
_RectBack = Rect
|
||||
'<!--<Border x:Name = "RectBack" CornerRadius="3" RenderTransformOrigin="0.5,0.5" SnapsToDevicePixels="True"
|
||||
'IsHitTestVisible = "False" Opacity="0" BorderThickness="1"
|
||||
'Grid.ColumnSpan = "4" Background="{DynamicResource ColorBrush7}" BorderBrush="{DynamicResource ColorBrush6}"/>-->
|
||||
End If
|
||||
Return _RectBack
|
||||
End Get
|
||||
End Property
|
||||
|
||||
#End Region
|
||||
|
||||
Private StateLast As String
|
||||
''' <summary>
|
||||
''' 是否允许交互。目前仅用于 PageDownloadCompDetail 的顶部栏展示：若关闭碰撞检测，则无法展开 Tooltip。
|
||||
''' </summary>
|
||||
Public Property CanInteraction As Boolean = True
|
||||
Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp
|
||||
If Not CanInteraction Then Exit Sub
|
||||
'判断当前颜色
|
||||
Dim StateNew As String, Time As Integer
|
||||
If IsMouseOver Then
|
||||
If IsMouseDown Then
|
||||
StateNew = "MouseDown"
|
||||
Time = 120
|
||||
Else
|
||||
StateNew = "MouseOver"
|
||||
Time = 120
|
||||
End If
|
||||
Else
|
||||
StateNew = "Idle"
|
||||
Time = 180
|
||||
End If
|
||||
If StateLast = StateNew Then Exit Sub
|
||||
StateLast = StateNew
|
||||
'触发颜色动画
|
||||
If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画
|
||||
'有动画
|
||||
Dim Ani As New List(Of AniData)
|
||||
If IsMouseOver Then
|
||||
Ani.AddRange({
|
||||
AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrushBg1"), Time),
|
||||
AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent)
|
||||
})
|
||||
If IsMouseDown Then
|
||||
Ani.Add(AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent))
|
||||
Else
|
||||
Ani.Add(AaScaleTransform(RectBack, 1 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent))
|
||||
End If
|
||||
Else
|
||||
Ani.AddRange({
|
||||
AaOpacity(RectBack, -RectBack.Opacity, Time),
|
||||
AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrush7"), Time),
|
||||
AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent),
|
||||
AaScaleTransform(RectBack, -0.196, 1,,, True)
|
||||
})
|
||||
End If
|
||||
AniStart(Ani, "CompItem Color " & Uuid)
|
||||
Else
|
||||
'无动画
|
||||
AniStop("CompItem Color " & Uuid)
|
||||
If _RectBack IsNot Nothing Then RectBack.Opacity = 0
|
||||
End If
|
||||
End Sub
|
||||
|
||||
End Class
|
||||
@@ -1,57 +0,0 @@
|
||||
<Grid x:Class="MyLocalModItem"
|
||||
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
|
||||
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
|
||||
xmlns:local="clr-namespace:PCL;assembly="
|
||||
x:Name="PanBack" Height="44"
|
||||
RenderTransformOrigin="0.5,0.5" Background="{StaticResource ColorBrushSemiTransparent}" SnapsToDevicePixels="True">
|
||||
<Grid.ColumnDefinitions>
|
||||
<ColumnDefinition Width="6" />
|
||||
<ColumnDefinition Width="34" />
|
||||
<ColumnDefinition Width="7" />
|
||||
<ColumnDefinition Width="Auto" />
|
||||
<ColumnDefinition Width="1*" />
|
||||
<ColumnDefinition Width="4" x:Name="ColumnPaddingRight" />
|
||||
</Grid.ColumnDefinitions>
|
||||
<Grid.RowDefinitions>
|
||||
<RowDefinition Height="1*" />
|
||||
<RowDefinition Height="17" />
|
||||
<RowDefinition Height="18" />
|
||||
<RowDefinition Height="1*" />
|
||||
</Grid.RowDefinitions>
|
||||
<!-- Logo -->
|
||||
<Border Grid.Column="1" Grid.Row="1" Grid.RowSpan="2" IsHitTestVisible="False" SnapsToDevicePixels="True" UseLayoutRounding="True"
|
||||
HorizontalAlignment="Right" VerticalAlignment="Center" Width="34" Height="34">
|
||||
<Border.Clip>
|
||||
<RectangleGeometry Rect="0,0,34,34" RadiusX="6" RadiusY="6" />
|
||||
</Border.Clip>
|
||||
<local:MyImage x:Name="PathLogo" RenderOptions.BitmapScalingMode="HighQuality" FallbackSource="pack://application:,,,/images/Icons/NoIcon.png" />
|
||||
</Border>
|
||||
<!-- 标题 -->
|
||||
<Grid Grid.Column="3" Grid.ColumnSpan="2" Grid.Row="1" VerticalAlignment="Bottom" Margin="0,1,0,0"
|
||||
SnapsToDevicePixels="False" UseLayoutRounding="False" x:Name="PanTitle">
|
||||
<Grid.ColumnDefinitions>
|
||||
<ColumnDefinition Width="Auto" x:Name="ColumnTitle" />
|
||||
<ColumnDefinition Width="Auto" x:Name="ColumnSubtitle" />
|
||||
<ColumnDefinition Width="Auto" />
|
||||
<ColumnDefinition Width="1*" x:Name="ColumnExtend" />
|
||||
</Grid.ColumnDefinitions>
|
||||
<TextBlock x:Name="LabTitle" TextTrimming="CharacterEllipsis" FontSize="14" IsHitTestVisible="False" />
|
||||
<TextBlock x:Name="LabSubtitle" Grid.Column="1" HorizontalAlignment="Left"
|
||||
TextTrimming="CharacterEllipsis" FontSize="12" IsHitTestVisible="False"
|
||||
Foreground="{StaticResource ColorBrushGray1}" Opacity="0.4" VerticalAlignment="Bottom" Visibility="Collapsed" />
|
||||
<!-- 更新按钮 -->
|
||||
<local:MyIconButton Grid.Column="2"
|
||||
Width="21" Height="21" Margin="-2,-1.6,0,0" x:Name="BtnUpdate" Theme="Black" Opacity="0.4" Visibility="Collapsed"
|
||||
ToolTipService.Placement="Right" ToolTipService.InitialShowDelay="100" ToolTipService.VerticalOffset="-9"
|
||||
Logo="M640 768H384l-32-32V509H213L190 454l298-298h45l298 298L810 509h-138v226z m-224-64h192V477l32-32h93L512 223 290 445H384l32 32zM352 831h320v64h-320z" />
|
||||
</Grid>
|
||||
<!-- Tag 与 详情 -->
|
||||
<StackPanel x:Name="PanTags" Grid.Row="2" Grid.Column="3" Orientation="Horizontal" VerticalAlignment="Bottom" Margin="-1,0,1,0" Visibility="Collapsed" IsHitTestVisible="False">
|
||||
<!--<Border Background="{DynamicResource ColorBrush6}" Padding="3,1" CornerRadius="3" Margin="0,0,4,0" SnapsToDevicePixels="True" UseLayoutRounding="False">
|
||||
<TextBlock Text="科技" Foreground="{DynamicResource ColorBrush2}" FontSize="11" />
|
||||
</Border>-->
|
||||
</StackPanel>
|
||||
<TextBlock x:Name="LabInfo" Grid.Row="2" Grid.Column="4" VerticalAlignment="Bottom" Margin="0,0,3,1"
|
||||
TextTrimming="CharacterEllipsis" FontSize="12" Foreground="{StaticResource ColorBrushGray4}"
|
||||
IsHitTestVisible="False" SnapsToDevicePixels="False" UseLayoutRounding="False" />
|
||||
</Grid>
|
||||
@@ -1,544 +0,0 @@
|
||||
Imports System.Windows.Forms
|
||||
|
||||
Public Class MyLocalModItem
|
||||
|
||||
#Region "基础属性"
|
||||
Public Uuid As Integer = GetUuid()
|
||||
|
||||
'Logo
|
||||
Public Property Logo As String
|
||||
Get
|
||||
Return PathLogo.Source
|
||||
End Get
|
||||
Set(value As String)
|
||||
PathLogo.Source = value
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'标题
|
||||
Private _Title As String
|
||||
Public Property Title As String
|
||||
Get
|
||||
Return _Title
|
||||
End Get
|
||||
Set(value As String)
|
||||
Dim RawValue = value
|
||||
Select Case Entry.State
|
||||
Case McMod.McModState.Fine
|
||||
LabTitle.TextDecorations = Nothing
|
||||
Case McMod.McModState.Disabled
|
||||
LabTitle.TextDecorations = TextDecorations.Strikethrough
|
||||
Case McMod.McModState.Unavailable
|
||||
LabTitle.TextDecorations = TextDecorations.Strikethrough
|
||||
value &= " [错误]"
|
||||
End Select
|
||||
If LabTitle.Text = value Then Exit Property
|
||||
LabTitle.Text = value
|
||||
_Title = RawValue
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'副标题
|
||||
Public Property SubTitle As String
|
||||
Get
|
||||
Return If(LabSubtitle?.Text, "")
|
||||
End Get
|
||||
Set(value As String)
|
||||
If LabSubtitle.Text = value Then Exit Property
|
||||
LabSubtitle.Text = value
|
||||
LabSubtitle.Visibility = If(value = "", Visibility.Collapsed, Visibility.Visible)
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'描述
|
||||
Public Property Description As String
|
||||
Get
|
||||
Return LabInfo.Text
|
||||
End Get
|
||||
Set(value As String)
|
||||
If LabInfo.Text = value Then Exit Property
|
||||
LabInfo.Text = value
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'Tag
|
||||
Public WriteOnly Property Tags As List(Of String)
|
||||
Set(value As List(Of String))
|
||||
PanTags.Children.Clear()
|
||||
PanTags.Visibility = If(value.Any(), Visibility.Visible, Visibility.Collapsed)
|
||||
For Each TagText In value
|
||||
Dim NewTag = GetObjectFromXML(
|
||||
"<Border xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation""
|
||||
Background=""#0C000000"" Padding=""3,1"" CornerRadius=""3"" Margin=""0,0,3,0""
|
||||
SnapsToDevicePixels=""True"" UseLayoutRounding=""False"">
|
||||
<TextBlock Text=""" & TagText & """ Foreground=""#88000000"" FontSize=""11"" />
|
||||
</Border>")
|
||||
PanTags.Children.Add(NewTag)
|
||||
Next
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'相关联的 Mod
|
||||
Public Property Entry As McMod
|
||||
Get
|
||||
Return Tag
|
||||
End Get
|
||||
Set(value As McMod)
|
||||
Tag = value
|
||||
End Set
|
||||
End Property
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "点击与勾选"
|
||||
|
||||
'触发点击事件
|
||||
Public Event Click(sender As Object, e As MouseButtonEventArgs)
|
||||
Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp
|
||||
If IsMouseDown Then
|
||||
RaiseEvent Click(sender, e)
|
||||
If e.Handled Then Exit Sub
|
||||
Log("[Control] 按下本地 Mod 列表项：" & LabTitle.Text)
|
||||
End If
|
||||
End Sub
|
||||
|
||||
'鼠标点击判定
|
||||
Private IsMouseDown As Boolean = False
|
||||
Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonDown
|
||||
If Not IsMouseDirectlyOver Then Exit Sub
|
||||
IsMouseDown = True
|
||||
If ButtonStack IsNot Nothing Then ButtonStack.IsHitTestVisible = False
|
||||
End Sub
|
||||
Private Sub Button_MouseLeave(sender As Object, e As Object) Handles Me.MouseLeave, Me.PreviewMouseLeftButtonUp
|
||||
IsMouseDown = False
|
||||
If ButtonStack IsNot Nothing Then ButtonStack.IsHitTestVisible = True
|
||||
End Sub
|
||||
|
||||
'滑动选中
|
||||
Private Shared SwipeStart As Integer, SwipeEnd As Integer
|
||||
Private Shared Swiping As Boolean = False
|
||||
Private Shared SwipToState As Boolean '被滑动到的目标应将 Checked 改为此值
|
||||
Private Sub Button_MouseSwipeStart(sender As Object, e As Object) Handles Me.MouseLeftButtonDown
|
||||
If Parent Is Nothing Then Exit Sub 'Mod 可能已被删除（#3824）
|
||||
'开始滑动
|
||||
Dim Index = CType(Parent, StackPanel).Children.IndexOf(Me)
|
||||
SwipeStart = Index
|
||||
SwipeEnd = Index
|
||||
Swiping = True
|
||||
SwipToState = Not Checked
|
||||
FrmVersionMod.CardSelect.IsHitTestVisible = False '暂时禁用下边栏
|
||||
End Sub
|
||||
Private Sub Button_MouseSwipe(sender As Object, e As Object) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonUp
|
||||
If Parent Is Nothing Then Exit Sub 'Mod 可能已被删除（#3824）
|
||||
'结束滑动
|
||||
If Mouse.LeftButton <> MouseButtonState.Pressed OrElse Not Swiping Then
|
||||
Swiping = False
|
||||
FrmVersionMod.CardSelect.IsHitTestVisible = True
|
||||
Exit Sub
|
||||
End If
|
||||
'计算滑动范围
|
||||
Dim Elements = CType(Parent, StackPanel).Children
|
||||
Dim Index As Integer = Elements.IndexOf(Me)
|
||||
SwipeStart = MathClamp(Math.Min(SwipeStart, Index), 0, Elements.Count - 1)
|
||||
SwipeEnd = MathClamp(Math.Max(SwipeEnd, Index), 0, Elements.Count - 1)
|
||||
'勾选所有范围中的项
|
||||
If SwipeStart = SwipeEnd Then Exit Sub
|
||||
For i = SwipeStart To SwipeEnd
|
||||
Dim Item As MyLocalModItem = Elements(i)
|
||||
Item.InitLate(Item, e)
|
||||
Item.Checked = SwipToState
|
||||
Next
|
||||
End Sub
|
||||
|
||||
'勾选状态
|
||||
Public Event Check(sender As Object, e As RouteEventArgs)
|
||||
Public Event Changed(sender As Object, e As RouteEventArgs)
|
||||
Private _Checked As Boolean = False
|
||||
Public Property Checked As Boolean
|
||||
Get
|
||||
Return _Checked
|
||||
End Get
|
||||
Set(value As Boolean)
|
||||
Try
|
||||
'触发属性值修改
|
||||
Dim RawValue = _Checked
|
||||
If value = _Checked Then Exit Property
|
||||
_Checked = value
|
||||
Dim ChangedEventArgs As New RouteEventArgs(False)
|
||||
If IsInitialized Then
|
||||
RaiseEvent Changed(Me, ChangedEventArgs)
|
||||
If ChangedEventArgs.Handled Then
|
||||
_Checked = RawValue
|
||||
Exit Property
|
||||
End If
|
||||
End If
|
||||
If value Then
|
||||
Dim CheckEventArgs As New RouteEventArgs(False)
|
||||
RaiseEvent Check(Me, CheckEventArgs)
|
||||
If CheckEventArgs.Handled Then Exit Property
|
||||
End If
|
||||
'更改动画
|
||||
If IsVisibleInForm() Then
|
||||
Dim Anim As New List(Of AniData)
|
||||
If Checked Then
|
||||
'由无变有
|
||||
Dim Delta = 32 - RectCheck.ActualHeight
|
||||
Anim.Add(AaHeight(RectCheck, Delta * 0.4, 200,, New AniEaseOutFluent(AniEasePower.Weak)))
|
||||
Anim.Add(AaHeight(RectCheck, Delta * 0.6, 300,, New AniEaseOutBack(AniEasePower.Weak)))
|
||||
Anim.Add(AaOpacity(RectCheck, 1 - RectCheck.Opacity, 30))
|
||||
RectCheck.VerticalAlignment = VerticalAlignment.Center
|
||||
RectCheck.Margin = New Thickness(-3, 0, 0, 0)
|
||||
Anim.Add(AaColor(LabTitle, TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5"), 200))
|
||||
Else
|
||||
'由有变无
|
||||
Anim.Add(AaHeight(RectCheck, -RectCheck.ActualHeight, 120,, New AniEaseInFluent(AniEasePower.Weak)))
|
||||
Anim.Add(AaOpacity(RectCheck, -RectCheck.Opacity, 70, 40))
|
||||
RectCheck.VerticalAlignment = VerticalAlignment.Center
|
||||
Anim.Add(AaColor(LabTitle, TextBlock.ForegroundProperty, If(LabTitle.TextDecorations Is Nothing, "ColorBrush1", "ColorBrushGray4"), 120))
|
||||
End If
|
||||
AniStart(Anim, "MyLocalModItem Checked " & Uuid)
|
||||
Else
|
||||
'不在窗口上时直接设置
|
||||
RectCheck.VerticalAlignment = VerticalAlignment.Center
|
||||
RectCheck.Margin = New Thickness(-3, 0, 0, 0)
|
||||
If Checked Then
|
||||
RectCheck.Height = 32
|
||||
RectCheck.Opacity = 1
|
||||
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5"))
|
||||
Else
|
||||
RectCheck.Height = 0
|
||||
RectCheck.Opacity = 0
|
||||
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush1", "ColorBrushGray4"))
|
||||
End If
|
||||
AniStop("MyLocalModItem Checked " & Uuid)
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "设置 Checked 失败")
|
||||
End Try
|
||||
End Set
|
||||
End Property
|
||||
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "后加载内容"
|
||||
|
||||
'右下角状态指示图标
|
||||
Private ImgState As Image
|
||||
|
||||
'指向背景
|
||||
Private _RectBack As Border = Nothing
|
||||
Public ReadOnly Property RectBack As Border
|
||||
Get
|
||||
If _RectBack Is Nothing Then
|
||||
Dim Rect As New Border With {
|
||||
.Name = "RectBack",
|
||||
.CornerRadius = New CornerRadius(3),
|
||||
.RenderTransform = New ScaleTransform(0.8, 0.8),
|
||||
.RenderTransformOrigin = New Point(0.5, 0.5),
|
||||
.BorderThickness = New Thickness(GetWPFSize(1)),
|
||||
.SnapsToDevicePixels = True,
|
||||
.IsHitTestVisible = False,
|
||||
.Opacity = 0
|
||||
}
|
||||
Rect.SetResourceReference(Border.BackgroundProperty, "ColorBrush7")
|
||||
Rect.SetResourceReference(Border.BorderBrushProperty, "ColorBrush6")
|
||||
SetColumnSpan(Rect, 999)
|
||||
SetRowSpan(Rect, 999)
|
||||
Children.Insert(0, Rect)
|
||||
_RectBack = Rect
|
||||
'<!--<Border x:Name = "RectBack" CornerRadius="3" RenderTransformOrigin="0.5,0.5" SnapsToDevicePixels="True"
|
||||
'IsHitTestVisible = "False" Opacity="0" BorderThickness="1"
|
||||
'Grid.ColumnSpan = "4" Background="{DynamicResource ColorBrush7}" BorderBrush="{DynamicResource ColorBrush6}"/>-->
|
||||
End If
|
||||
Return _RectBack
|
||||
End Get
|
||||
End Property
|
||||
|
||||
'按钮
|
||||
Public ButtonHandler As Action(Of MyLocalModItem, EventArgs)
|
||||
Public ButtonStack As FrameworkElement
|
||||
Private _Buttons As IEnumerable(Of MyIconButton)
|
||||
Public Property Buttons As IEnumerable(Of MyIconButton)
|
||||
Get
|
||||
Return _Buttons
|
||||
End Get
|
||||
Set(value As IEnumerable(Of MyIconButton))
|
||||
_Buttons = value
|
||||
'移除原 Stack
|
||||
If ButtonStack IsNot Nothing Then
|
||||
Children.Remove(ButtonStack)
|
||||
ButtonStack = Nothing
|
||||
End If
|
||||
If Not value.Any() Then Exit Property
|
||||
'添加新 Stack
|
||||
ButtonStack = New StackPanel With {.Opacity = 0, .Margin = New Thickness(0, 0, 5, 0), .SnapsToDevicePixels = False, .Orientation = Orientation.Horizontal,
|
||||
.HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Center, .UseLayoutRounding = False}
|
||||
SetColumnSpan(ButtonStack, 10) : SetRowSpan(ButtonStack, 10)
|
||||
'构造按钮
|
||||
For Each Btn As MyIconButton In value
|
||||
If Btn.Height.Equals(Double.NaN) Then Btn.Height = 25
|
||||
If Btn.Width.Equals(Double.NaN) Then Btn.Width = 25
|
||||
CType(ButtonStack, StackPanel).Children.Add(Btn)
|
||||
Next
|
||||
Children.Add(ButtonStack)
|
||||
End Set
|
||||
End Property
|
||||
|
||||
'勾选条
|
||||
Private _RectCheck As Border
|
||||
Public ReadOnly Property RectCheck As Border
|
||||
Get
|
||||
If _RectCheck Is Nothing Then
|
||||
_RectCheck = New Border With {.Width = 5, .Height = If(Checked, Double.NaN, 0), .CornerRadius = New CornerRadius(2, 2, 2, 2),
|
||||
.VerticalAlignment = If(Checked, VerticalAlignment.Stretch, VerticalAlignment.Center),
|
||||
.HorizontalAlignment = HorizontalAlignment.Left, .UseLayoutRounding = False, .SnapsToDevicePixels = False,
|
||||
.Margin = If(Checked, New Thickness(-3, 6, 0, 6), New Thickness(-3, 0, 0, 0))}
|
||||
_RectCheck.SetResourceReference(Border.BackgroundProperty, "ColorBrush3")
|
||||
SetRowSpan(_RectCheck, 10)
|
||||
Children.Add(_RectCheck)
|
||||
End If
|
||||
Return _RectCheck
|
||||
End Get
|
||||
End Property
|
||||
|
||||
#End Region
|
||||
|
||||
Private Function GetUpdateCompareDescription() As String
|
||||
Dim CurrentName = Entry.CompFile.FileName.Replace(".jar", "")
|
||||
Dim NewestName = Entry.UpdateFile.FileName.Replace(".jar", "")
|
||||
'简化名称对比
|
||||
Dim CurrentSegs = CurrentName.Split("-"c).ToList()
|
||||
Dim NewestSegs = NewestName.Split("-"c).ToList()
|
||||
Dim Shortened As Boolean = False
|
||||
For Each Seg In CurrentSegs.ToList()
|
||||
If Not NewestSegs.Contains(Seg) Then Continue For
|
||||
CurrentSegs.Remove(Seg)
|
||||
NewestSegs.Remove(Seg)
|
||||
Shortened = True
|
||||
Next
|
||||
If Shortened AndAlso CurrentSegs.Any() AndAlso NewestSegs.Any() Then
|
||||
CurrentName = Join(CurrentSegs, "-")
|
||||
NewestName = Join(NewestSegs, "-")
|
||||
Entry._Version = CurrentName '使用网络信息作为显示的版本号
|
||||
End If
|
||||
Return $"当前版本：{CurrentName}（{GetTimeSpanString(Entry.CompFile.ReleaseDate - Date.Now, False)}）{vbCrLf}最新版本：{NewestName}（{GetTimeSpanString(Entry.UpdateFile.ReleaseDate - Date.Now, False)}）"
|
||||
End Function
|
||||
Public Sub Refresh() Handles Me.Loaded
|
||||
RunInUi(
|
||||
Sub()
|
||||
'更新
|
||||
If Entry.CanUpdate Then
|
||||
BtnUpdate.Visibility = Visibility.Visible
|
||||
BtnUpdate.ToolTip = $"{GetUpdateCompareDescription()}{vbCrLf}点击以更新，右键查看更新日志。"
|
||||
Else
|
||||
BtnUpdate.Visibility = Visibility.Collapsed
|
||||
End If
|
||||
'标题与描述
|
||||
Dim DescFileName As String
|
||||
Select Case Entry.State
|
||||
Case McMod.McModState.Fine
|
||||
DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path)
|
||||
Case McMod.McModState.Disabled
|
||||
DescFileName = GetFileNameWithoutExtentionFromPath(Entry.Path.Replace(".disabled", "").Replace(".old", ""))
|
||||
Case Else 'McMod.McModState.Unavailable
|
||||
DescFileName = GetFileNameFromPath(Entry.Path)
|
||||
End Select
|
||||
Dim NewDescription As String
|
||||
If Setup.Get("ToolModLocalNameStyle") = 1 Then
|
||||
'标题显示文件名，详情显示译名
|
||||
'标题
|
||||
Title = DescFileName
|
||||
SubTitle = ""
|
||||
'描述
|
||||
If Entry.Comp Is Nothing Then
|
||||
NewDescription = Entry.Name
|
||||
Else
|
||||
Dim Titles = Entry.Comp.GetControlTitle(False)
|
||||
NewDescription = Titles.Key & Titles.Value
|
||||
End If
|
||||
NewDescription = NewDescription.Replace(" | ", " / ")
|
||||
If Entry.Version IsNot Nothing Then NewDescription &= $" ({Entry.Version})"
|
||||
Else
|
||||
'标题显示译名，详情显示文件名
|
||||
'标题
|
||||
If Entry.Comp Is Nothing Then
|
||||
Title = Entry.Name
|
||||
SubTitle = If(Entry.Version Is Nothing, "", " | " & Entry.Version)
|
||||
Else
|
||||
Dim Titles = Entry.Comp.GetControlTitle(False)
|
||||
Title = Titles.Key
|
||||
SubTitle = Titles.Value & If(Entry.Version Is Nothing, "", " | " & Entry.Version)
|
||||
End If
|
||||
'描述
|
||||
NewDescription = DescFileName
|
||||
End If
|
||||
If Entry.Comp IsNot Nothing Then
|
||||
NewDescription += ": " & Entry.Comp.Description.Replace(vbCr, "").Replace(vbLf, "")
|
||||
ElseIf Entry.Description IsNot Nothing Then
|
||||
NewDescription += ": " & Entry.Description.Replace(vbCr, "").Replace(vbLf, "")
|
||||
ElseIf Not Entry.IsFileAvailable Then
|
||||
NewDescription += ": " & "存在错误，无法获取信息"
|
||||
End If
|
||||
Description = NewDescription
|
||||
If Checked Then
|
||||
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush2", "ColorBrush5"))
|
||||
Else
|
||||
LabTitle.SetResourceReference(TextBlock.ForegroundProperty, If(Entry.State = McMod.McModState.Fine, "ColorBrush1", "ColorBrushGray4"))
|
||||
End If
|
||||
'主 Logo
|
||||
Logo = If(Entry.Comp Is Nothing, PathImage & "Icons/NoIcon.png", Entry.Comp.GetControlLogo())
|
||||
'图标右下角的 Logo
|
||||
If Entry.State = McMod.McModState.Fine Then
|
||||
If ImgState IsNot Nothing Then
|
||||
Children.Remove(ImgState)
|
||||
ImgState = Nothing
|
||||
End If
|
||||
Else
|
||||
If ImgState Is Nothing Then
|
||||
ImgState = New Image With {
|
||||
.Width = 20, .Height = 20, .Margin = New Thickness(0, 0, -5, -3), .IsHitTestVisible = False,
|
||||
.HorizontalAlignment = HorizontalAlignment.Right, .VerticalAlignment = VerticalAlignment.Bottom
|
||||
}
|
||||
RenderOptions.SetBitmapScalingMode(ImgState, BitmapScalingMode.HighQuality)
|
||||
SetColumn(ImgState, 1) : SetRow(ImgState, 1) : SetRowSpan(ImgState, 2)
|
||||
Children.Add(ImgState)
|
||||
'<Image x:Name="ImgState" RenderOptions.BitmapScalingMode="HighQuality" Width="16" Height="16" Margin="0,0,-3,-1"
|
||||
' Grid.Column="1" Grid.Row="1" Grid.RowSpan="2" IsHitTestVisible="False"
|
||||
' HorizontalAlignment="Right" VerticalAlignment="Bottom"
|
||||
' Source="/Images/Icons/Unavailable.png" />
|
||||
End If
|
||||
ImgState.Source = New MyBitmap(PathImage & $"Icons/{Entry.State}.png")
|
||||
End If
|
||||
'标签
|
||||
If Entry.Comp IsNot Nothing Then Tags = Entry.Comp.Tags
|
||||
End Sub)
|
||||
End Sub
|
||||
|
||||
Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp, Me.Changed
|
||||
InitLate(sender, e)
|
||||
'触发颜色动画
|
||||
Dim Time As Integer = If(IsMouseOver, 120, 180)
|
||||
Dim Ani As New List(Of AniData)
|
||||
'ButtonStack
|
||||
If ButtonStack IsNot Nothing Then
|
||||
If IsMouseOver Then
|
||||
Ani.Add(AaOpacity(ButtonStack, 1 - ButtonStack.Opacity, Time * 0.7, Time * 0.3))
|
||||
Ani.Add(AaDouble(Sub(i) ColumnPaddingRight.Width = New GridLength(Math.Max(0, ColumnPaddingRight.Width.Value + i)),
|
||||
5 + Buttons.Count * 25 - ColumnPaddingRight.Width.Value, Time * 0.3, Time * 0.7))
|
||||
Else
|
||||
Ani.Add(AaOpacity(ButtonStack, -ButtonStack.Opacity, Time * 0.4))
|
||||
Ani.Add(AaDouble(Sub(i) ColumnPaddingRight.Width = New GridLength(Math.Max(0, ColumnPaddingRight.Width.Value + i)),
|
||||
4 - ColumnPaddingRight.Width.Value, Time * 0.4))
|
||||
End If
|
||||
End If
|
||||
'RectBack
|
||||
If IsMouseOver OrElse Checked Then
|
||||
Ani.AddRange({
|
||||
AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrushBg1"), Time),
|
||||
AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent)
|
||||
})
|
||||
If IsMouseDown Then
|
||||
Ani.Add(AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent))
|
||||
Else
|
||||
Ani.Add(AaScaleTransform(RectBack, 1 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent))
|
||||
End If
|
||||
Else
|
||||
Ani.AddRange({
|
||||
AaOpacity(RectBack, -RectBack.Opacity, Time),
|
||||
AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent),
|
||||
AaScaleTransform(RectBack, -0.196, 1,,, True)
|
||||
})
|
||||
End If
|
||||
AniStart(Ani, "LocalModItem Color " & Uuid)
|
||||
End Sub
|
||||
|
||||
'触发虚拟化内容
|
||||
Private Sub InitLate(sender As Object, e As EventArgs)
|
||||
If ButtonHandler IsNot Nothing Then
|
||||
ButtonHandler(sender, e)
|
||||
ButtonHandler = Nothing
|
||||
End If
|
||||
End Sub
|
||||
|
||||
'显示更新日志
|
||||
Private Sub BtnUpdate_PreviewMouseRightButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnUpdate.PreviewMouseRightButtonUp
|
||||
e.Handled = True
|
||||
ShowUpdateLog()
|
||||
End Sub
|
||||
Private Sub ShowUpdateLog()
|
||||
Dim CurseForgeUrl As String = Entry.ChangelogUrls.FirstOrDefault(Function(x) x.Contains("curseforge.com"))
|
||||
Dim ModrinthUrl As String = Entry.ChangelogUrls.FirstOrDefault(Function(x) x.Contains("modrinth.com"))
|
||||
If CurseForgeUrl Is Nothing OrElse ModrinthUrl Is Nothing Then
|
||||
OpenWebsite(Entry.ChangelogUrls.First)
|
||||
Else
|
||||
Select Case MyMsgBox("要在哪个网站上查看更新日志？", "查看更新日志", "Modrinth", "CurseForge", "取消")
|
||||
Case 1
|
||||
OpenWebsite(ModrinthUrl)
|
||||
Case 2
|
||||
OpenWebsite(CurseForgeUrl)
|
||||
End Select
|
||||
End If
|
||||
End Sub
|
||||
|
||||
'触发更新
|
||||
Private Sub BtnUpdate_Click(sender As Object, e As EventArgs) Handles BtnUpdate.Click
|
||||
Select Case MyMsgBox($"是否要更新 {Entry.Name}？{vbCrLf}{vbCrLf}{GetUpdateCompareDescription()}", "Mod 更新确认", "更新", "查看更新日志", "取消")
|
||||
Case 1 '更新
|
||||
FrmVersionMod.UpdateMods({Entry})
|
||||
Case 2 '查看更新日志
|
||||
ShowUpdateLog()
|
||||
Case 3 '取消
|
||||
End Select
|
||||
End Sub
|
||||
|
||||
'自适应（#4465）
|
||||
Private Sub PanTitle_SizeChanged() Handles PanTitle.SizeChanged
|
||||
'0：全部舒展：Auto - Auto - (Auto) - 1*
|
||||
'1：压缩 Subtitle：Auto - 1* - (Auto) - 0
|
||||
'2：继续压缩 Title：1* - 0 - (Auto) - 0
|
||||
Dim CurrentCompressLevel As Integer =
|
||||
If(ColumnExtend.Width.IsStar, 0, If(ColumnTitle.Width.IsStar, 2, 1)) 'Subtitle 可能是 Collapsed
|
||||
Dim NewCompressLevel As Integer
|
||||
Select Case CurrentCompressLevel
|
||||
Case 0
|
||||
If ColumnExtend.ActualWidth < 0.5 Then
|
||||
NewCompressLevel = If(LabSubtitle.Visibility = Visibility.Collapsed, 2, 1)
|
||||
Else
|
||||
Return
|
||||
End If
|
||||
Case 1
|
||||
If ColumnSubtitle.ActualWidth < 0.5 Then
|
||||
NewCompressLevel = 2
|
||||
ElseIf Not LabSubtitle.IsTextTrimmed Then
|
||||
NewCompressLevel = 0
|
||||
Else
|
||||
Return
|
||||
End If
|
||||
Case 2
|
||||
If Not LabTitle.IsTextTrimmed Then
|
||||
NewCompressLevel = If(LabSubtitle.Visibility = Visibility.Collapsed, 0, 1)
|
||||
Else
|
||||
Return
|
||||
End If
|
||||
End Select
|
||||
Select Case NewCompressLevel
|
||||
Case 0
|
||||
'全部舒展：Auto - Auto - (Auto) - 1*
|
||||
ColumnTitle.Width = GridLength.Auto
|
||||
ColumnSubtitle.Width = GridLength.Auto
|
||||
ColumnExtend.Width = New GridLength(1, GridUnitType.Star)
|
||||
Case 1
|
||||
'压缩 Subtitle：Auto - 1* - (Auto) - 0
|
||||
ColumnTitle.Width = GridLength.Auto
|
||||
ColumnSubtitle.Width = New GridLength(1, GridUnitType.Star)
|
||||
ColumnExtend.Width = New GridLength(0, GridUnitType.Pixel)
|
||||
Case 2
|
||||
'继续压缩 Title：1* - 0 - (Auto) - 0
|
||||
ColumnTitle.Width = New GridLength(1, GridUnitType.Star)
|
||||
ColumnSubtitle.Width = New GridLength(0, GridUnitType.Pixel)
|
||||
ColumnExtend.Width = New GridLength(0, GridUnitType.Pixel)
|
||||
End Select
|
||||
End Sub
|
||||
|
||||
End Class
|
||||
@@ -1,4 +1,4 @@
|
||||
Imports System.Collections.ObjectModel
|
||||
Imports System.Collections.ObjectModel
|
||||
|
||||
Public Module ModEvent
|
||||
#Region "事件执行方法"
|
||||
|
||||
@@ -34,12 +34,12 @@ Public Module ModMain
|
||||
''' <summary>
|
||||
''' 等待弹出的提示列表。以 {String, HintType, Log As Boolean} 形式存储为数组。
|
||||
''' </summary>
|
||||
Private HintWaiting As List(Of HintMessage) = If(HintWaiting, New List(Of HintMessage))
|
||||
Private HintWaiting As SafeList(Of HintMessage) = If(HintWaiting, New SafeList(Of HintMessage))
|
||||
''' <summary>
|
||||
''' 在窗口左下角弹出提示文本。
|
||||
''' </summary>
|
||||
Public Sub Hint(Text As String, Optional Type As HintType = HintType.Info, Optional Log As Boolean = True)
|
||||
If HintWaiting Is Nothing Then HintWaiting = New List(Of HintMessage)
|
||||
If HintWaiting Is Nothing Then HintWaiting = New SafeList(Of HintMessage)
|
||||
HintWaiting.Add(New HintMessage With {.Text = If(Text, ""), .Type = Type, .Log = Log})
|
||||
End Sub
|
||||
|
||||
@@ -47,7 +47,7 @@ Public Module ModMain
|
||||
Try
|
||||
|
||||
'Tag 存储了：{ 是否可以重用, Uuid }
|
||||
If Not HintWaiting.Any() Then Exit Sub
|
||||
If Not HintWaiting.Any() Then Return
|
||||
Do While HintWaiting.Any
|
||||
''清除空提示
|
||||
'If IsNothing(HintWaiting(0)) OrElse IsNothing(HintWaiting(0)(0)) Then
|
||||
@@ -343,7 +343,7 @@ EndHint:
|
||||
Public WaitingMyMsgBox As List(Of MyMsgBoxConverter) = If(WaitingMyMsgBox, New List(Of MyMsgBoxConverter))
|
||||
Public Sub MyMsgBoxTick()
|
||||
Try
|
||||
If FrmMain Is Nothing OrElse FrmMain.PanMsg Is Nothing OrElse FrmMain.WindowState = WindowState.Minimized Then Exit Sub
|
||||
If FrmMain Is Nothing OrElse FrmMain.PanMsg Is Nothing OrElse FrmMain.WindowState = WindowState.Minimized Then Return
|
||||
If FrmMain.PanMsg.Children.Count > 0 Then
|
||||
'弹窗中
|
||||
FrmMain.PanMsg.Visibility = Visibility.Visible
|
||||
@@ -397,14 +397,11 @@ EndHint:
|
||||
'下载页面声明
|
||||
Public FrmDownloadLeft As PageDownloadLeft
|
||||
Public FrmDownloadInstall As PageDownloadInstall
|
||||
Public FrmDownloadClient As PageDownloadClient
|
||||
Public FrmDownloadOptiFine As PageDownloadOptiFine
|
||||
Public FrmDownloadLiteLoader As PageDownloadLiteLoader
|
||||
Public FrmDownloadForge As PageDownloadForge
|
||||
Public FrmDownloadNeoForge As PageDownloadNeoForge
|
||||
Public FrmDownloadFabric As PageDownloadFabric
|
||||
Public FrmDownloadMod As PageDownloadMod
|
||||
Public FrmDownloadPack As PageDownloadPack
|
||||
Public FrmDownloadDataPack As PageDownloadDataPack
|
||||
Public FrmDownloadShader As PageDownloadShader
|
||||
Public FrmDownloadResourcePack As PageDownloadResourcePack
|
||||
|
||||
'设置页面声明
|
||||
Public FrmSetupLeft As PageSetupLeft
|
||||
@@ -634,7 +631,7 @@ NextFile:
|
||||
Catch ex As Exception
|
||||
Log(ex, "检查帮助文件夹失败", LogLevel.Msgbox)
|
||||
End Try
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
If Loader.IsAborted Then Return
|
||||
|
||||
'将文件实例化
|
||||
Dim Dict As New List(Of HelpEntry)
|
||||
@@ -650,7 +647,7 @@ NextFile:
|
||||
|
||||
'回设
|
||||
If Not Dict.Any() Then Throw New Exception("未找到可用的帮助；若不需要帮助页面，可以在 设置 → 个性化 → 功能隐藏 中将其隐藏")
|
||||
If Loader.IsAborted Then Exit Sub
|
||||
If Loader.IsAborted Then Return
|
||||
Loader.Output = Dict
|
||||
|
||||
Catch ex As Exception
|
||||
@@ -693,8 +690,8 @@ NextFile:
|
||||
Private AprilDistance As Integer = 0
|
||||
Private Sub TimerFool()
|
||||
Try
|
||||
If FrmLaunchLeft Is Nothing OrElse FrmLaunchLeft.AprilPosTrans Is Nothing OrElse FrmMain.lastMouseArg Is Nothing Then Exit Sub
|
||||
If IsAprilGiveup OrElse FrmMain.PageCurrent <> FormMain.PageType.Launch OrElse AniControlEnabled <> 0 OrElse Not FrmLaunchLeft.BtnLaunch.IsLoaded Then Exit Sub
|
||||
If FrmLaunchLeft Is Nothing OrElse FrmLaunchLeft.AprilPosTrans Is Nothing OrElse FrmMain.lastMouseArg Is Nothing Then Return
|
||||
If IsAprilGiveup OrElse FrmMain.PageCurrent <> FormMain.PageType.Launch OrElse AniControlEnabled <> 0 OrElse Not FrmLaunchLeft.BtnLaunch.IsLoaded Then Return
|
||||
|
||||
'计算是否空闲
|
||||
Dim MousePos = FrmMain.lastMouseArg.GetPosition(FrmMain)
|
||||
@@ -763,7 +760,7 @@ NextFile:
|
||||
'移动
|
||||
AprilSpeed = AprilSpeed * 0.8 + Acc
|
||||
Dim SpeedValue = Math.Min(60, AprilSpeed.Length)
|
||||
If SpeedValue < 0.01 Then Exit Sub
|
||||
If SpeedValue < 0.01 Then Return
|
||||
AprilSpeed.Normalize()
|
||||
AprilSpeed *= SpeedValue
|
||||
AprilDistance += SpeedValue
|
||||
@@ -910,7 +907,7 @@ NextFile:
|
||||
If ThemeDontClick = 2 Then ThemeRefresh()
|
||||
#End Region
|
||||
Catch ex As Exception
|
||||
Log(ex, "短程主时钟执行异常", LogLevel.Assert)
|
||||
Log(ex, "短程主时钟执行异常", LogLevel.Critical)
|
||||
End Try
|
||||
Timer4Count += 1
|
||||
If Timer4Count = 4 Then
|
||||
@@ -930,15 +927,16 @@ NextFile:
|
||||
#Region "每 7.5s 执行一次的代码"
|
||||
If FrmMain.BtnExtraApril_ShowCheck AndAlso AprilDistance <> 0 Then FrmMain.BtnExtraApril.Ribble()
|
||||
'以未知原因窗口被丢到一边去的修复（Top、Left = -25600），还有 #745
|
||||
RunInUi(Sub()
|
||||
If Not FrmMain.Hidden Then
|
||||
If FrmMain.Top < -9000 Then FrmMain.Top = 100
|
||||
If FrmMain.Left < -9000 Then FrmMain.Left = 100 '窗口拉至最大时 Left = -18.8
|
||||
End If
|
||||
End Sub)
|
||||
RunInUi(
|
||||
Sub()
|
||||
If Not FrmMain.Hidden Then
|
||||
If FrmMain.Top < -9000 Then FrmMain.Top = 100
|
||||
If FrmMain.Left < -9000 Then FrmMain.Left = 100 '窗口拉至最大时 Left = -18.8
|
||||
End If
|
||||
End Sub)
|
||||
#End Region
|
||||
Catch ex As Exception
|
||||
Log(ex, "长程主时钟执行异常", LogLevel.Assert)
|
||||
Log(ex, "长程主时钟执行异常", LogLevel.Critical)
|
||||
End Try
|
||||
End If
|
||||
End Sub
|
||||
@@ -954,7 +952,7 @@ NextFile:
|
||||
Log(ex, "程序主时钟出错", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub, "Timer Main")
|
||||
If Not IsAprilEnabled Then Exit Sub
|
||||
If Not IsAprilEnabled Then Return
|
||||
RunInNewThread(
|
||||
Sub()
|
||||
Try
|
||||
|
||||
@@ -79,7 +79,7 @@
|
||||
If MusicState = MusicStates.Pause Then
|
||||
FrmMain.BtnExtraMusic.Logo = Logo.IconPlay
|
||||
FrmMain.BtnExtraMusic.LogoScale = 0.8
|
||||
ToolTipText = "已暂停：" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
|
||||
ToolTipText = "已暂停：" & IO.Path.GetFileNameWithoutExtension(MusicCurrent)
|
||||
If MusicAllList.Count > 1 Then
|
||||
ToolTipText += vbCrLf & "左键恢复播放，右键播放下一曲。"
|
||||
Else
|
||||
@@ -88,7 +88,7 @@
|
||||
Else
|
||||
FrmMain.BtnExtraMusic.Logo = Logo.IconMusic
|
||||
FrmMain.BtnExtraMusic.LogoScale = 1
|
||||
ToolTipText = "正在播放：" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
|
||||
ToolTipText = "正在播放：" & IO.Path.GetFileNameWithoutExtension(MusicCurrent)
|
||||
If MusicAllList.Count > 1 Then
|
||||
ToolTipText += vbCrLf & "左键暂停，右键播放下一曲。"
|
||||
Else
|
||||
@@ -247,7 +247,7 @@
|
||||
Log("[Music] 已恢复播放")
|
||||
Try
|
||||
MusicNAudio?.Play()
|
||||
Catch 'https://github.com/Hex-Dragon/PCL2/pull/5415#issuecomment-2751135223
|
||||
Catch 'https://github.com/Meloong-Git/PCL/pull/5415#issuecomment-2751135223
|
||||
MusicNAudio?.Stop()
|
||||
MusicNAudio?.Play()
|
||||
End Try
|
||||
|
||||
@@ -9,9 +9,11 @@ Friend Module ModSecret
|
||||
'在开源版的注册表与常规版的注册表隔离，以防数据冲突
|
||||
Public Const RegFolder As String = "PCLDebug"
|
||||
'用于微软登录的 ClientId
|
||||
Public Const OAuthClientId As String = ""
|
||||
Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "")
|
||||
'CurseForge API Key
|
||||
Public Const CurseForgeAPIKey As String = ""
|
||||
Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "")
|
||||
'用于匿名数据收集的腾讯云日志服务上报 URL，形如 https://{region}.cls.tencentcs.com/track?topic_id={topic_id}
|
||||
Public Const ClsBaseUrl As String = ""
|
||||
|
||||
Friend Sub SecretOnApplicationStart()
|
||||
'提升 UI 线程优先级
|
||||
@@ -67,61 +69,29 @@ Friend Module ModSecret
|
||||
If Not DataList.Any(Function(d) d.Contains("-Dlog4j2.formatMsgNoLookups=true")) Then DataList.Add("-Dlog4j2.formatMsgNoLookups=true")
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 打码字符串中的 AccessToken。
|
||||
''' </summary>
|
||||
Friend Function SecretFilter(Raw As String, FilterChar As Char) As String
|
||||
'打码 "accessToken " 后的内容
|
||||
If Raw.Contains("accessToken ") Then
|
||||
For Each Token In RegexSearch(Raw, "(?<=accessToken ([^ ]{5}))[^ ]+(?=[^ ]{5})")
|
||||
Raw = Raw.Replace(Token, New String(FilterChar, Token.Count))
|
||||
Next
|
||||
End If
|
||||
'打码当前登录的结果
|
||||
Dim AccessToken As String = McLoginLoader.Output.AccessToken
|
||||
If AccessToken Is Nothing OrElse AccessToken.Length < 10 OrElse Not Raw.ContainsF(AccessToken, True) OrElse
|
||||
McLoginLoader.Output.Uuid = McLoginLoader.Output.AccessToken Then 'UUID 和 AccessToken 一样则不打码
|
||||
Return Raw
|
||||
Else
|
||||
Return Raw.Replace(AccessToken, Left(AccessToken, 5) & New String(FilterChar, AccessToken.Length - 10) & Right(AccessToken, 5))
|
||||
End If
|
||||
End Function
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "网络鉴权"
|
||||
|
||||
Friend Function SecretCdnSign(UrlWithMark As String)
|
||||
Friend Function SecretCdnSign(UrlWithMark As String) As String
|
||||
If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark
|
||||
Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20")
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 设置 Headers 的 UA、Referer。
|
||||
''' </summary>
|
||||
Friend Sub SecretHeadersSign(Url As String, ByRef Client As WebClient, Optional UseBrowserUserAgent As Boolean = False)
|
||||
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
|
||||
Client.Headers("User-Agent") = "LogStatistic" '#4951
|
||||
ElseIf UseBrowserUserAgent Then
|
||||
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
|
||||
Else
|
||||
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode
|
||||
Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional SimulateBrowserHeaders As Boolean = False)
|
||||
If Not Req.Headers.UserAgent.Any Then
|
||||
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
|
||||
Req.Headers.Add("User-Agent", "LogStatistic") '#4951
|
||||
ElseIf SimulateBrowserHeaders Then
|
||||
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36")
|
||||
Else
|
||||
Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}")
|
||||
End If
|
||||
End If
|
||||
Client.Headers("Referer") = "http://" & VersionCode & ".open.pcl2.server/"
|
||||
If Url.Contains("api.curseforge.com") Then Client.Headers("x-api-key") = CurseForgeAPIKey
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 设置 Headers 的 UA、Referer。
|
||||
''' </summary>
|
||||
Friend Sub SecretHeadersSign(Url As String, ByRef Request As HttpWebRequest, Optional UseBrowserUserAgent As Boolean = False)
|
||||
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
|
||||
Request.UserAgent = "LogStatistic" '#4951
|
||||
ElseIf UseBrowserUserAgent Then
|
||||
Request.UserAgent = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36"
|
||||
Else
|
||||
Request.UserAgent = "PCL2/" & VersionStandardCode
|
||||
End If
|
||||
Request.Referer = "http://" & VersionCode & ".open.pcl2.server/"
|
||||
If Url.Contains("api.curseforge.com") Then Request.Headers("x-api-key") = CurseForgeAPIKey
|
||||
If Not SimulateBrowserHeaders Then Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/")
|
||||
If Url.Contains("api.curseforge.com") Then Req.Headers.Add("x-api-key", CurseForgeAPIKey)
|
||||
End Sub
|
||||
|
||||
#End Region
|
||||
@@ -198,45 +168,70 @@ Friend Module ModSecret
|
||||
Public ThemeDontClick As Integer = 0
|
||||
|
||||
Public Sub ThemeRefresh(Optional NewTheme As Integer = -1)
|
||||
Hint("该版本中不包含主题功能……")
|
||||
Try
|
||||
If ThemeNow = NewTheme AndAlso NewTheme >= 0 Then Return
|
||||
If NewTheme >= 0 Then ThemeNow = NewTheme
|
||||
|
||||
Color1 = New MyColor().FromHSL2(ColorHue, ColorSat * 0.2, 25 + ColorLightAdjust * 0.3)
|
||||
Color2 = New MyColor().FromHSL2(ColorHue, ColorSat, 45 + ColorLightAdjust)
|
||||
Color3 = New MyColor().FromHSL2(ColorHue, ColorSat, 55 + ColorLightAdjust)
|
||||
Color4 = New MyColor().FromHSL2(ColorHue, ColorSat, 65 + ColorLightAdjust)
|
||||
Color5 = New MyColor().FromHSL2(ColorHue, ColorSat, 80 + ColorLightAdjust * 0.4)
|
||||
Color6 = New MyColor().FromHSL2(ColorHue, ColorSat, 91 + ColorLightAdjust * 0.1)
|
||||
Color7 = New MyColor().FromHSL2(ColorHue, ColorSat, 95)
|
||||
Color8 = New MyColor().FromHSL2(ColorHue, ColorSat, 97)
|
||||
ColorBg0 = Color4 * 0.4 + Color5 * 0.4 + ColorGray4 * 0.2
|
||||
ColorBg1 = New MyColor(190, Color7)
|
||||
|
||||
ColorSemiTransparent = New MyColor(1, Color8)
|
||||
Application.Current.Resources("ColorBrush1") = New SolidColorBrush(Color1)
|
||||
Application.Current.Resources("ColorBrush2") = New SolidColorBrush(Color2)
|
||||
Application.Current.Resources("ColorBrush3") = New SolidColorBrush(Color3)
|
||||
Application.Current.Resources("ColorBrush4") = New SolidColorBrush(Color4)
|
||||
Application.Current.Resources("ColorBrush5") = New SolidColorBrush(Color5)
|
||||
Application.Current.Resources("ColorBrush6") = New SolidColorBrush(Color6)
|
||||
Application.Current.Resources("ColorBrush7") = New SolidColorBrush(Color7)
|
||||
Application.Current.Resources("ColorBrush8") = New SolidColorBrush(Color8)
|
||||
Application.Current.Resources("ColorBrushBg0") = New SolidColorBrush(ColorBg0)
|
||||
Application.Current.Resources("ColorBrushBg1") = New SolidColorBrush(ColorBg1)
|
||||
Application.Current.Resources("ColorObject1") = CType(Color1, Color)
|
||||
Application.Current.Resources("ColorObject2") = CType(Color2, Color)
|
||||
Application.Current.Resources("ColorObject3") = CType(Color3, Color)
|
||||
Application.Current.Resources("ColorObject4") = CType(Color4, Color)
|
||||
Application.Current.Resources("ColorObject5") = CType(Color5, Color)
|
||||
Application.Current.Resources("ColorObject6") = CType(Color6, Color)
|
||||
Application.Current.Resources("ColorObject7") = CType(Color7, Color)
|
||||
Application.Current.Resources("ColorObject8") = CType(Color8, Color)
|
||||
Application.Current.Resources("ColorObjectBg0") = CType(ColorBg0, Color)
|
||||
Application.Current.Resources("ColorObjectBg1") = CType(ColorBg1, Color)
|
||||
ThemeRefreshMain()
|
||||
Catch ex As Exception
|
||||
Log(ex, "刷新主题颜色失败", LogLevel.Hint)
|
||||
End Try
|
||||
End Sub
|
||||
Public Sub ThemeRefreshMain()
|
||||
RunInUi(
|
||||
Sub()
|
||||
If Not FrmMain.IsLoaded Then Exit Sub
|
||||
If Not FrmMain.IsLoaded Then Return
|
||||
'顶部条背景
|
||||
Dim Brush = New LinearGradientBrush With {.EndPoint = New Point(1, 0), .StartPoint = New Point(0, 0)}
|
||||
If ThemeNow = 5 Then
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 25)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 15)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 25)})
|
||||
FrmMain.PanTitle.Background = Brush
|
||||
FrmMain.PanTitle.Background.Freeze()
|
||||
ElseIf Not (ThemeNow = 12 OrElse ThemeDontClick = 2) Then
|
||||
If TypeOf ColorHueTopbarDelta Is Integer Then
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 54 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
|
||||
Else
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(0), ColorSat, 48 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(1), ColorSat, 54 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(2), ColorSat, 48 + ColorLightAdjust)})
|
||||
End If
|
||||
FrmMain.PanTitle.Background = Brush
|
||||
FrmMain.PanTitle.Background.Freeze()
|
||||
If TypeOf ColorHueTopbarDelta Is Integer Then
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 54 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
|
||||
Else
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue - 21, ColorSat, 53 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.33, .Color = New MyColor().FromHSL2(ColorHue - 7, ColorSat, 47 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.67, .Color = New MyColor().FromHSL2(ColorHue + 7, ColorSat, 47 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + 21, ColorSat, 53 + ColorLightAdjust)})
|
||||
FrmMain.PanTitle.Background = Brush
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(0), ColorSat, 48 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.5, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(1), ColorSat, 54 + ColorLightAdjust)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(2), ColorSat, 48 + ColorLightAdjust)})
|
||||
End If
|
||||
FrmMain.PanTitle.Background = Brush
|
||||
FrmMain.PanTitle.Background.Freeze()
|
||||
'主页面背景
|
||||
If Setup.Get("UiBackgroundColorful") Then
|
||||
Brush = New LinearGradientBrush With {.EndPoint = New Point(0.1, 1), .StartPoint = New Point(0.9, 0)}
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = -0.1, .Color = New MyColor().FromHSL2(ColorHue - 20, Math.Min(60, ColorSat) * 0.5, 80)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.4, .Color = New MyColor().FromHSL2(ColorHue, ColorSat * 0.9, 90)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1.1, .Color = New MyColor().FromHSL2(ColorHue + 20, Math.Min(60, ColorSat) * 0.5, 80)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = -0.1, .Color = New MyColor().FromHSL2(ColorHue - 15, ColorSat * 0.8, 91)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 0.4, .Color = New MyColor().FromHSL2(ColorHue, ColorSat * 0.8, 91)})
|
||||
Brush.GradientStops.Add(New GradientStop With {.Offset = 1.1, .Color = New MyColor().FromHSL2(ColorHue + 15, ColorSat * 0.8, 91)})
|
||||
FrmMain.PanForm.Background = Brush
|
||||
Else
|
||||
FrmMain.PanForm.Background = New MyColor(245, 245, 245)
|
||||
|
||||
@@ -1,59 +0,0 @@
|
||||
Imports System.Net
|
||||
|
||||
Public Class CookieWebClient
|
||||
Inherits WebClient
|
||||
|
||||
Public Sub New(container As CookieContainer, Headers As Dictionary(Of String, String))
|
||||
Me.New(container)
|
||||
For Each keyVal In Headers
|
||||
Me.Headers(keyVal.Key) = keyVal.Value
|
||||
Next
|
||||
End Sub
|
||||
|
||||
Public Sub New()
|
||||
Me.New(New CookieContainer())
|
||||
End Sub
|
||||
|
||||
Public Sub New(container As CookieContainer)
|
||||
Me.container = container
|
||||
End Sub
|
||||
|
||||
Private Shadows ReadOnly container As New CookieContainer()
|
||||
|
||||
''' <summary>
|
||||
''' 以毫秒为单位的超时。
|
||||
''' </summary>
|
||||
Public Timeout As Integer = 600000
|
||||
|
||||
Protected Overrides Function GetWebRequest(address As Uri) As WebRequest
|
||||
Dim r As WebRequest = MyBase.GetWebRequest(address)
|
||||
Dim request = TryCast(r, HttpWebRequest)
|
||||
|
||||
If request IsNot Nothing Then
|
||||
request.CookieContainer = container
|
||||
request.Timeout = Timeout
|
||||
End If
|
||||
|
||||
Return r
|
||||
End Function
|
||||
|
||||
Protected Overrides Function GetWebResponse(request As WebRequest, result As IAsyncResult) As WebResponse
|
||||
Dim response As WebResponse = MyBase.GetWebResponse(request, result)
|
||||
ReadCookies(response)
|
||||
Return response
|
||||
End Function
|
||||
|
||||
Protected Overrides Function GetWebResponse(request As WebRequest) As WebResponse
|
||||
Dim response As WebResponse = MyBase.GetWebResponse(request)
|
||||
ReadCookies(response)
|
||||
Return response
|
||||
End Function
|
||||
|
||||
Private Sub ReadCookies(r As WebResponse)
|
||||
Dim response = TryCast(r, HttpWebResponse)
|
||||
If response IsNot Nothing Then
|
||||
Dim cookies As CookieCollection = response.Cookies
|
||||
container.Add(cookies)
|
||||
End If
|
||||
End Sub
|
||||
End Class
|
||||
@@ -1,299 +0,0 @@
|
||||
Public NotInheritable Class SystemDropShadowChrome
|
||||
Inherits Decorator
|
||||
|
||||
'源码来源于：https://referencesource.microsoft.com/#PresentationFramework.Aero/parent/Shared/Microsoft/Windows/Themes/SystemDropShadowChrome.cs,6d9c27d92a8128c1
|
||||
|
||||
Public Shared ReadOnly ColorProperty As DependencyProperty = DependencyProperty.Register("Color", GetType(Color), GetType(SystemDropShadowChrome), New FrameworkPropertyMetadata(Color.FromArgb(&H71, &H0, &H0, &H0), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)))
|
||||
Public Property Color As Color
|
||||
Get
|
||||
Return CType(GetValue(ColorProperty), Color)
|
||||
End Get
|
||||
Set(value As Color)
|
||||
SetValue(ColorProperty, value)
|
||||
End Set
|
||||
End Property
|
||||
|
||||
Public Shared ReadOnly CornerRadiusProperty As DependencyProperty = DependencyProperty.Register("CornerRadius", GetType(CornerRadius), GetType(SystemDropShadowChrome), New FrameworkPropertyMetadata(New CornerRadius(), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)), New ValidateValueCallback(AddressOf IsCornerRadiusValid))
|
||||
Public Property CornerRadius As CornerRadius
|
||||
Get
|
||||
Return CType(GetValue(CornerRadiusProperty), CornerRadius)
|
||||
End Get
|
||||
Set(value As CornerRadius)
|
||||
SetValue(CornerRadiusProperty, value)
|
||||
End Set
|
||||
End Property
|
||||
Private Shared Function IsCornerRadiusValid(value As Object) As Boolean
|
||||
Dim cr As CornerRadius = CType(value, CornerRadius)
|
||||
Return Not (cr.TopLeft < 0.0 OrElse cr.TopRight < 0.0 OrElse cr.BottomLeft < 0.0 OrElse cr.BottomRight < 0.0 OrElse Double.IsNaN(cr.TopLeft) OrElse Double.IsNaN(cr.TopRight) OrElse Double.IsNaN(cr.BottomLeft) OrElse Double.IsNaN(cr.BottomRight) OrElse Double.IsInfinity(cr.TopLeft) OrElse Double.IsInfinity(cr.TopRight) OrElse Double.IsInfinity(cr.BottomLeft) OrElse Double.IsInfinity(cr.BottomRight))
|
||||
End Function
|
||||
|
||||
Private Const ShadowDepth As Double = 5
|
||||
|
||||
Protected Overrides Sub OnRender(drawingContext As DrawingContext)
|
||||
Dim cornerRadius As CornerRadius = Me.CornerRadius
|
||||
Dim shadowBounds As New Rect(New Point(ShadowDepth, ShadowDepth), New Size(RenderSize.Width, RenderSize.Height))
|
||||
Dim color As Color = Me.Color
|
||||
|
||||
If shadowBounds.Width > 0 AndAlso shadowBounds.Height > 0 AndAlso color.A > 0 Then
|
||||
Dim centerWidth As Double = shadowBounds.Right - shadowBounds.Left - 2 * ShadowDepth
|
||||
Dim centerHeight As Double = shadowBounds.Bottom - shadowBounds.Top - 2 * ShadowDepth
|
||||
Dim maxRadius As Double = Math.Min(centerWidth * 0.5, centerHeight * 0.5)
|
||||
cornerRadius.TopLeft = Math.Min(cornerRadius.TopLeft, maxRadius)
|
||||
cornerRadius.TopRight = Math.Min(cornerRadius.TopRight, maxRadius)
|
||||
cornerRadius.BottomLeft = Math.Min(cornerRadius.BottomLeft, maxRadius)
|
||||
cornerRadius.BottomRight = Math.Min(cornerRadius.BottomRight, maxRadius)
|
||||
Dim brushes As Brush() = GetBrushes(color, cornerRadius)
|
||||
Dim centerTop As Double = shadowBounds.Top + ShadowDepth
|
||||
Dim centerLeft As Double = shadowBounds.Left + ShadowDepth
|
||||
Dim centerRight As Double = shadowBounds.Right - ShadowDepth
|
||||
Dim centerBottom As Double = shadowBounds.Bottom - ShadowDepth
|
||||
Dim guidelineSetX As Double() = New Double() {centerLeft, centerLeft + cornerRadius.TopLeft, centerRight - cornerRadius.TopRight, centerLeft + cornerRadius.BottomLeft, centerRight - cornerRadius.BottomRight, centerRight}
|
||||
Dim guidelineSetY As Double() = New Double() {centerTop, centerTop + cornerRadius.TopLeft, centerTop + cornerRadius.TopRight, centerBottom - cornerRadius.BottomLeft, centerBottom - cornerRadius.BottomRight, centerBottom}
|
||||
drawingContext.PushGuidelineSet(New GuidelineSet(guidelineSetX, guidelineSetY))
|
||||
cornerRadius.TopLeft += ShadowDepth
|
||||
cornerRadius.TopRight += ShadowDepth
|
||||
cornerRadius.BottomLeft += ShadowDepth
|
||||
cornerRadius.BottomRight += ShadowDepth
|
||||
Dim topLeft As New Rect(shadowBounds.Left, shadowBounds.Top, cornerRadius.TopLeft, cornerRadius.TopLeft)
|
||||
drawingContext.DrawRectangle(brushes(Placement.TopLeft), Nothing, topLeft)
|
||||
Dim topWidth As Double = guidelineSetX(2) - guidelineSetX(1)
|
||||
|
||||
If topWidth > 0 Then
|
||||
Dim top As New Rect(guidelineSetX(1), shadowBounds.Top, topWidth, ShadowDepth)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Top), Nothing, top)
|
||||
End If
|
||||
|
||||
Dim topRight As New Rect(guidelineSetX(2), shadowBounds.Top, cornerRadius.TopRight, cornerRadius.TopRight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.TopRight), Nothing, topRight)
|
||||
Dim leftHeight As Double = guidelineSetY(3) - guidelineSetY(1)
|
||||
|
||||
If leftHeight > 0 Then
|
||||
Dim left As New Rect(shadowBounds.Left, guidelineSetY(1), ShadowDepth, leftHeight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Left), Nothing, left)
|
||||
End If
|
||||
|
||||
Dim rightHeight As Double = guidelineSetY(4) - guidelineSetY(2)
|
||||
|
||||
If rightHeight > 0 Then
|
||||
Dim right As New Rect(guidelineSetX(5), guidelineSetY(2), ShadowDepth, rightHeight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Right), Nothing, right)
|
||||
End If
|
||||
|
||||
Dim bottomLeft As New Rect(shadowBounds.Left, guidelineSetY(3), cornerRadius.BottomLeft, cornerRadius.BottomLeft)
|
||||
drawingContext.DrawRectangle(brushes(Placement.BottomLeft), Nothing, bottomLeft)
|
||||
Dim bottomWidth As Double = guidelineSetX(4) - guidelineSetX(3)
|
||||
|
||||
If bottomWidth > 0 Then
|
||||
Dim bottom As New Rect(guidelineSetX(3), guidelineSetY(5), bottomWidth, ShadowDepth)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Bottom), Nothing, bottom)
|
||||
End If
|
||||
|
||||
Dim bottomRight As New Rect(guidelineSetX(4), guidelineSetY(4), cornerRadius.BottomRight, cornerRadius.BottomRight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.BottomRight), Nothing, bottomRight)
|
||||
|
||||
If cornerRadius.TopLeft = ShadowDepth AndAlso cornerRadius.TopLeft = cornerRadius.TopRight AndAlso cornerRadius.TopLeft = cornerRadius.BottomLeft AndAlso cornerRadius.TopLeft = cornerRadius.BottomRight Then
|
||||
Dim center As New Rect(guidelineSetX(0), guidelineSetY(0), centerWidth, centerHeight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Center), Nothing, center)
|
||||
Else
|
||||
Dim figure As New PathFigure()
|
||||
|
||||
If cornerRadius.TopLeft > ShadowDepth Then
|
||||
figure.StartPoint = New Point(guidelineSetX(1), guidelineSetY(0))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(1), guidelineSetY(1)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(1)), True))
|
||||
Else
|
||||
figure.StartPoint = New Point(guidelineSetX(0), guidelineSetY(0))
|
||||
End If
|
||||
|
||||
If cornerRadius.BottomLeft > ShadowDepth Then
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(3)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(3)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(5)), True))
|
||||
Else
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(5)), True))
|
||||
End If
|
||||
|
||||
If cornerRadius.BottomRight > ShadowDepth Then
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(5)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(4)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(4)), True))
|
||||
Else
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(5)), True))
|
||||
End If
|
||||
|
||||
If cornerRadius.TopRight > ShadowDepth Then
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(2)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(2)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(0)), True))
|
||||
Else
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(0)), True))
|
||||
End If
|
||||
|
||||
figure.IsClosed = True
|
||||
figure.Freeze()
|
||||
Dim geometry As New PathGeometry()
|
||||
geometry.Figures.Add(figure)
|
||||
geometry.Freeze()
|
||||
drawingContext.DrawGeometry(brushes(Placement.Center), Nothing, geometry)
|
||||
End If
|
||||
|
||||
drawingContext.Pop()
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Enum Placement
|
||||
TopLeft = 0
|
||||
Top = 1
|
||||
TopRight = 2
|
||||
Left = 3
|
||||
Center = 4
|
||||
Right = 5
|
||||
BottomLeft = 6
|
||||
Bottom = 7
|
||||
BottomRight = 8
|
||||
End Enum
|
||||
Private Shared _commonBrushes As Brush()
|
||||
Private Shared _commonCornerRadius As CornerRadius
|
||||
Private Shared ReadOnly _resourceAccess As New Object()
|
||||
Private _brushes As Brush()
|
||||
|
||||
Private Shared Sub ClearBrushes(o As DependencyObject, e As DependencyPropertyChangedEventArgs)
|
||||
CType(o, SystemDropShadowChrome)._brushes = Nothing
|
||||
End Sub
|
||||
Private Shared Function CreateStops(c As Color, cornerRadius As Double) As GradientStopCollection
|
||||
Dim gradientScale As Double = 1 / (cornerRadius + ShadowDepth)
|
||||
Dim gsc As New GradientStopCollection From {
|
||||
New GradientStop(c, (0.5 + cornerRadius) * gradientScale)
|
||||
}
|
||||
Dim stopColor As Color = c
|
||||
stopColor.A = CByte(0.74336 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (1.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = CByte(0.38053 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (2.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = CByte(0.12389 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (3.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = CByte(0.02654 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (4.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = 0
|
||||
gsc.Add(New GradientStop(stopColor, (5 + cornerRadius) * gradientScale))
|
||||
gsc.Freeze()
|
||||
Return gsc
|
||||
End Function
|
||||
Private Shared Function CreateBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
|
||||
Dim brushes As Brush() = New Brush(8) {}
|
||||
brushes(Placement.Center) = New SolidColorBrush(c)
|
||||
brushes(Placement.Center).Freeze()
|
||||
Dim sideStops As GradientStopCollection = CreateStops(c, 0)
|
||||
Dim top As New LinearGradientBrush(sideStops, New Point(0, 1), New Point(0, 0))
|
||||
top.Freeze()
|
||||
brushes(Placement.Top) = top
|
||||
Dim left As New LinearGradientBrush(sideStops, New Point(1, 0), New Point(0, 0))
|
||||
left.Freeze()
|
||||
brushes(Placement.Left) = left
|
||||
Dim right As New LinearGradientBrush(sideStops, New Point(0, 0), New Point(1, 0))
|
||||
right.Freeze()
|
||||
brushes(Placement.Right) = right
|
||||
Dim bottom As New LinearGradientBrush(sideStops, New Point(0, 0), New Point(0, 1))
|
||||
bottom.Freeze()
|
||||
brushes(Placement.Bottom) = bottom
|
||||
Dim topLeftStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.TopLeft = 0 Then
|
||||
topLeftStops = sideStops
|
||||
Else
|
||||
topLeftStops = CreateStops(c, cornerRadius.TopLeft)
|
||||
End If
|
||||
|
||||
Dim topLeft As New RadialGradientBrush(topLeftStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(1, 1),
|
||||
.GradientOrigin = New Point(1, 1)
|
||||
}
|
||||
topLeft.Freeze()
|
||||
brushes(Placement.TopLeft) = topLeft
|
||||
Dim topRightStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.TopRight = 0 Then
|
||||
topRightStops = sideStops
|
||||
ElseIf cornerRadius.TopRight = cornerRadius.TopLeft Then
|
||||
topRightStops = topLeftStops
|
||||
Else
|
||||
topRightStops = CreateStops(c, cornerRadius.TopRight)
|
||||
End If
|
||||
|
||||
Dim topRight As New RadialGradientBrush(topRightStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(0, 1),
|
||||
.GradientOrigin = New Point(0, 1)
|
||||
}
|
||||
topRight.Freeze()
|
||||
brushes(Placement.TopRight) = topRight
|
||||
Dim bottomLeftStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.BottomLeft = 0 Then
|
||||
bottomLeftStops = sideStops
|
||||
ElseIf cornerRadius.BottomLeft = cornerRadius.TopLeft Then
|
||||
bottomLeftStops = topLeftStops
|
||||
ElseIf cornerRadius.BottomLeft = cornerRadius.TopRight Then
|
||||
bottomLeftStops = topRightStops
|
||||
Else
|
||||
bottomLeftStops = CreateStops(c, cornerRadius.BottomLeft)
|
||||
End If
|
||||
|
||||
Dim bottomLeft As New RadialGradientBrush(bottomLeftStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(1, 0),
|
||||
.GradientOrigin = New Point(1, 0)
|
||||
}
|
||||
bottomLeft.Freeze()
|
||||
brushes(Placement.BottomLeft) = bottomLeft
|
||||
Dim bottomRightStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.BottomRight = 0 Then
|
||||
bottomRightStops = sideStops
|
||||
ElseIf cornerRadius.BottomRight = cornerRadius.TopLeft Then
|
||||
bottomRightStops = topLeftStops
|
||||
ElseIf cornerRadius.BottomRight = cornerRadius.TopRight Then
|
||||
bottomRightStops = topRightStops
|
||||
ElseIf cornerRadius.BottomRight = cornerRadius.BottomLeft Then
|
||||
bottomRightStops = bottomLeftStops
|
||||
Else
|
||||
bottomRightStops = CreateStops(c, cornerRadius.BottomRight)
|
||||
End If
|
||||
|
||||
Dim bottomRight As New RadialGradientBrush(bottomRightStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(0, 0),
|
||||
.GradientOrigin = New Point(0, 0)
|
||||
}
|
||||
bottomRight.Freeze()
|
||||
brushes(Placement.BottomRight) = bottomRight
|
||||
Return brushes
|
||||
End Function
|
||||
Private Function GetBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
|
||||
If _commonBrushes Is Nothing Then
|
||||
|
||||
SyncLock _resourceAccess
|
||||
|
||||
If _commonBrushes Is Nothing Then
|
||||
_commonBrushes = CreateBrushes(c, cornerRadius)
|
||||
_commonCornerRadius = cornerRadius
|
||||
End If
|
||||
End SyncLock
|
||||
End If
|
||||
|
||||
If c = CType(_commonBrushes(Placement.Center), SolidColorBrush).Color AndAlso cornerRadius = _commonCornerRadius Then
|
||||
_brushes = Nothing
|
||||
Return _commonBrushes
|
||||
ElseIf _brushes Is Nothing Then
|
||||
_brushes = CreateBrushes(c, cornerRadius)
|
||||
End If
|
||||
|
||||
Return _brushes
|
||||
End Function
|
||||
|
||||
End Class
|
||||
@@ -0,0 +1,151 @@
|
||||
'来源：https://blog.csdn.net/simpleman2000/article/details/140952294
|
||||
|
||||
Imports System.ComponentModel
|
||||
Imports System.Runtime.InteropServices
|
||||
Imports System.Windows.Interop
|
||||
|
||||
Public Class DragHelper
|
||||
|
||||
Public Event DragDrop As EventHandler
|
||||
|
||||
Public Property DropFilePaths As String()
|
||||
Get
|
||||
Return _DropFilePathsBackingField
|
||||
End Get
|
||||
Private Set(value As String())
|
||||
_DropFilePathsBackingField = value
|
||||
End Set
|
||||
End Property
|
||||
Private _DropFilePathsBackingField As String()
|
||||
|
||||
Public Property DropPoint As POINT
|
||||
Get
|
||||
Return _DropPointBackingField
|
||||
End Get
|
||||
Private Set(value As POINT)
|
||||
_DropPointBackingField = value
|
||||
End Set
|
||||
End Property
|
||||
Private _DropPointBackingField As POINT
|
||||
|
||||
Public Property HwndIntPtrSource As HwndSource
|
||||
|
||||
Public Sub AddHook()
|
||||
RemoveDragHook()
|
||||
HwndIntPtrSource.AddHook(AddressOf WndProc)
|
||||
Dim handle As IntPtr = HwndIntPtrSource.Handle
|
||||
If IsUserAnAdmin() Then RevokeDragDrop(handle)
|
||||
DragAcceptFiles(handle, True)
|
||||
ChangeMessageFilter(handle)
|
||||
End Sub
|
||||
|
||||
Public Sub RemoveDragHook()
|
||||
HwndIntPtrSource.RemoveHook(AddressOf WndProc)
|
||||
DragAcceptFiles(HwndIntPtrSource.Handle, False)
|
||||
End Sub
|
||||
|
||||
Private Function WndProc(hwnd As IntPtr, msg As Integer, wParam As IntPtr, lParam As IntPtr, ByRef handled As Boolean) As IntPtr
|
||||
Dim filePaths As String() = Nothing
|
||||
Dim point As New POINT()
|
||||
|
||||
If TryGetDropInfo(msg, wParam, filePaths, point) Then
|
||||
DropPoint = point
|
||||
DropFilePaths = filePaths
|
||||
RaiseEvent DragDrop(Me, EventArgs.Empty)
|
||||
handled = True
|
||||
End If
|
||||
Return IntPtr.Zero
|
||||
End Function
|
||||
|
||||
<DllImport("user32.dll", SetLastError:=True)>
|
||||
Private Shared Function ChangeWindowMessageFilterEx(hWnd As IntPtr, msg As UInteger, action As UInteger, ByRef pChangeFilterStruct As CHANGEFILTERSTRUCT) As Boolean
|
||||
End Function
|
||||
|
||||
<DllImport("user32.dll", SetLastError:=True)>
|
||||
Private Shared Function ChangeWindowMessageFilter(msg As UInteger, flags As UInteger) As Boolean
|
||||
End Function
|
||||
|
||||
<DllImport("shell32.dll")>
|
||||
Private Shared Sub DragAcceptFiles(hWnd As IntPtr, fAccept As Boolean)
|
||||
End Sub
|
||||
|
||||
<DllImport("shell32.dll", CharSet:=CharSet.Unicode)>
|
||||
Private Shared Function DragQueryFile(hWnd As IntPtr, iFile As UInteger, lpszFile As StringBuilder, cch As Integer) As UInteger
|
||||
End Function
|
||||
|
||||
<DllImport("shell32.dll")>
|
||||
Private Shared Function DragQueryPoint(hDrop As IntPtr, ByRef lppt As POINT) As Boolean
|
||||
End Function
|
||||
|
||||
<DllImport("shell32.dll")>
|
||||
Private Shared Sub DragFinish(hDrop As IntPtr)
|
||||
End Sub
|
||||
|
||||
<DllImport("ole32.dll")>
|
||||
Private Shared Function RevokeDragDrop(hWnd As IntPtr) As Integer
|
||||
End Function
|
||||
|
||||
<DllImport("shell32.dll")>
|
||||
Private Shared Function IsUserAnAdmin() As Boolean
|
||||
End Function
|
||||
|
||||
<StructLayout(LayoutKind.Sequential)>
|
||||
Public Structure POINT
|
||||
Public X As Integer
|
||||
Public Y As Integer
|
||||
End Structure
|
||||
|
||||
<StructLayout(LayoutKind.Sequential)>
|
||||
Private Structure CHANGEFILTERSTRUCT
|
||||
Public cbSize As UInteger
|
||||
Public ExtStatus As UInteger
|
||||
End Structure
|
||||
|
||||
Private Const WM_COPYGLOBALDATA As UInteger = &H49
|
||||
Private Const WM_COPYDATA As UInteger = &H4A
|
||||
Private Const WM_DROPFILES As UInteger = &H233
|
||||
Private Const MSGFLT_ALLOW As UInteger = 1
|
||||
Private Const MSGFLT_ADD As UInteger = 1
|
||||
Private Const MAX_PATH As Integer = 260
|
||||
|
||||
Private Shared Sub ChangeMessageFilter(handle As IntPtr)
|
||||
Dim ver As Version = Environment.OSVersion.Version
|
||||
Dim isVistaOrHigher As Boolean = ver >= New Version(6, 0)
|
||||
Dim isNt61OrHiger As Boolean = ver >= New Version(6, 1)
|
||||
|
||||
If isVistaOrHigher Then
|
||||
Dim status As New CHANGEFILTERSTRUCT With {.cbSize = 8}
|
||||
For Each msg As UInteger In New UInteger() {WM_DROPFILES, WM_COPYGLOBALDATA, WM_COPYDATA}
|
||||
Dim [error] As Boolean = False
|
||||
If isNt61OrHiger Then
|
||||
[error] = Not ChangeWindowMessageFilterEx(handle, msg, MSGFLT_ALLOW, status)
|
||||
Else
|
||||
[error] = Not ChangeWindowMessageFilter(msg, MSGFLT_ADD)
|
||||
End If
|
||||
|
||||
If [error] Then Throw New Win32Exception(Marshal.GetLastWin32Error())
|
||||
Next
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Shared Function TryGetDropInfo(msg As Integer, wParam As IntPtr, ByRef dropFilePaths As String(), ByRef dropPoint As POINT) As Boolean
|
||||
dropFilePaths = Nothing
|
||||
dropPoint = New POINT()
|
||||
|
||||
If msg <> WM_DROPFILES Then Return False
|
||||
|
||||
Dim fileCount As UInteger = DragQueryFile(wParam, UInteger.MaxValue, Nothing, 0)
|
||||
ReDim dropFilePaths(CInt(fileCount) - 1)
|
||||
|
||||
For i As UInteger = 0 To CInt(fileCount) - 1
|
||||
Dim sb As New StringBuilder(MAX_PATH)
|
||||
Dim result As UInteger = DragQueryFile(wParam, i, sb, sb.Capacity)
|
||||
If result > 0 Then dropFilePaths(i) = sb.ToString()
|
||||
Next
|
||||
|
||||
DragQueryPoint(wParam, dropPoint)
|
||||
DragFinish(wParam)
|
||||
Return True
|
||||
End Function
|
||||
|
||||
End Class
|
||||
Reference in New Issue
Block a user