Merge branch 'main' into fix#6230

This commit is contained in:
wyc-26
2025-08-15 16:22:47 +08:00
committed by GitHub
131 changed files with 5586 additions and 3367 deletions
+1 -1
View File
@@ -12,7 +12,7 @@ body:
required: false required: false
- label: "**我已尝试使用 HMCL 启动,HMCL 没有出现问题。** 如果 HMCL 也无法启动就不是 PCL 导致的问题,请 **不要** 提交反馈。[下载 HMCL](https://hmcl.huangyuhui.net/download)" - label: "**我已尝试使用 HMCL 启动,HMCL 没有出现问题。** 如果 HMCL 也无法启动就不是 PCL 导致的问题,请 **不要** 提交反馈。[下载 HMCL](https://hmcl.huangyuhui.net/download)"
required: true required: true
- label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索,确认了这一 Bug 未被提交过。" - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索,确认了这一 Bug 未被提交过。"
required: true required: true
- type: textarea - type: textarea
id: "yml-2" id: "yml-2"
+1 -1
View File
@@ -12,7 +12,7 @@ body:
required: false required: false
- label: "我知晓大多数此类问题都是网络环境不佳导致的,但我确实认为我的问题可能是 PCL 导致的,和网络环境无关。" - label: "我知晓大多数此类问题都是网络环境不佳导致的,但我确实认为我的问题可能是 PCL 导致的,和网络环境无关。"
required: true required: true
- label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索,确认了这一 Bug 未被提交过。" - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索,确认了这一 Bug 未被提交过。"
required: true required: true
- type: textarea - type: textarea
id: "yml-2" id: "yml-2"
+1 -1
View File
@@ -8,7 +8,7 @@ body:
label: "检查项" label: "检查项"
description: "请逐个检查下列项目,并勾选确认。" description: "请逐个检查下列项目,并勾选确认。"
options: options:
- label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索,确认了这一 Bug 未被提交过。" - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索,确认了这一 Bug 未被提交过。"
required: true required: true
- type: textarea - type: textarea
id: "yml-2" id: "yml-2"
+2 -2
View File
@@ -8,9 +8,9 @@ body:
label: "检查项" label: "检查项"
description: "请逐个检查下列项目,并勾选确认。" description: "请逐个检查下列项目,并勾选确认。"
options: options:
- label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索,确认了这一建议未被提交过。" - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索,确认了这一建议未被提交过。"
required: true required: true
- label: "我已查看 [功能投票页面](https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/),确认了这一建议未在投票列表中。" - label: "我已查看 [功能投票页面](https://github.com/Meloong-Git/PCL/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/),确认了这一建议未在投票列表中。"
required: true required: true
- type: textarea - type: textarea
id: "yml-2" id: "yml-2"
+3 -3
View File
@@ -1,14 +1,14 @@
blank_issues_enabled: false blank_issues_enabled: false
contact_links: contact_links:
- name: 主页预设反馈 - name: 主页预设反馈
url: https://github.com/Hex-Dragon/PCL2/discussions/categories/自定义主页 url: https://github.com/Meloong-Git/PCL/discussions/categories/自定义主页
about: 提交与预设的主页(设置 → 个性化 → 主页预设)中的具体内容相关的反馈 about: 提交与预设的主页(设置 → 个性化 → 主页预设)中的具体内容相关的反馈
- name: 帮助文档反馈 - name: 帮助文档反馈
url: https://github.com/LTCatt/PCL2Help/issues url: https://github.com/LTCatt/PCL2Help/issues
about: 提交与 PCL 帮助文档(更多 → 帮助)中的具体内容相关的反馈 about: 提交与 PCL 帮助文档(更多 → 帮助)中的具体内容相关的反馈
- name: 提问 - name: 提问
url: https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E6%8F%90%E9%97%AE url: https://github.com/Meloong-Git/PCL/discussions/new?category=%E6%8F%90%E9%97%AE
about: 我想问一些 PCL 相关的问题…… about: 我想问一些 PCL 相关的问题……
- name: 讨论 - name: 讨论
url: https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E8%AE%A8%E8%AE%BA url: https://github.com/Meloong-Git/PCL/discussions/new?category=%E8%AE%A8%E8%AE%BA
about: 我想讨论一些 PCL 相关的事情…… about: 我想讨论一些 PCL 相关的事情……
+2 -2
View File
@@ -8,9 +8,9 @@ body:
label: "检查项" label: "检查项"
description: "请逐个检查下列项目,并勾选确认。" description: "请逐个检查下列项目,并勾选确认。"
options: options:
- label: "我已在 [Issues 页面](https://github.com/Hex-Dragon/PCL2/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Hex-Dragon/PCL2/discussions/1930) 中搜索,确认了这一提案未被提交过。" - label: "我已在 [Issues 页面](https://github.com/Meloong-Git/PCL/issues?q=is%3Aissue+) 和 [常见&难检反馈及问题列表](https://github.com/Meloong-Git/PCL/discussions/1930) 中搜索,确认了这一提案未被提交过。"
required: true required: true
- label: "我已查看 [功能投票页面](https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/),确认了这一提案未在投票列表中。" - label: "我已查看 [功能投票页面](https://github.com/Meloong-Git/PCL/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8/),确认了这一提案未在投票列表中。"
required: true required: true
- label: "我知晓还没做的新功能真的太多了,忙不过来,所以新功能提案几乎不会被处理,也不建议再提交新功能提案 qwq……" - label: "我知晓还没做的新功能真的太多了,忙不过来,所以新功能提案几乎不会被处理,也不建议再提交新功能提案 qwq……"
required: true required: true
+2 -3
View File
@@ -38,7 +38,6 @@ jobs:
- name: Update Help - name: Update Help
run: | run: |
$workpath = [System.Environment]::CurrentDirectory
Set-Location .. Set-Location ..
git clone https://github.com/LTCatt/PCL2Help.git -b master --single-branch --depth 1 git clone https://github.com/LTCatt/PCL2Help.git -b master --single-branch --depth 1
Set-Location PCL2Help Set-Location PCL2Help
@@ -52,8 +51,8 @@ jobs:
- name: Replace - name: Replace
run: | run: |
(gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public Const OAuthClientId As String = ""', 'Public Const OAuthClientId As String = "${{ secrets.CLIENT_ID }}"' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb" (gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "")', 'Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "${{ secrets.CLIENT_ID }}")' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb"
(gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public Const CurseForgeAPIKey As String = ""', 'Public Const CurseForgeAPIKey As String = "${{ secrets.CURSEFORGE_API_KEY }}"' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb" (gc "Plain Craft Launcher 2\Modules\ModSecret.vb") -replace 'Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "")', 'Public CurseForgeAPIKey As String = If(Environment.GetEnvironmentVariable("PCL_CURSEFORGE_API_KEY"), "${{ secrets.CURSEFORGE_API_KEY }}")' | Out-File "Plain Craft Launcher 2\Modules\ModSecret.vb"
(gc "Plain Craft Launcher 2\Modules\Base\ModBase.vb") -replace 'Public Const CommitHash As String = ""', 'Public Const CommitHash As String = "${{ github.sha }}"' | Out-File "Plain Craft Launcher 2\Modules\Base\ModBase.vb" (gc "Plain Craft Launcher 2\Modules\Base\ModBase.vb") -replace 'Public Const CommitHash As String = ""', 'Public Const CommitHash As String = "${{ github.sha }}"' | Out-File "Plain Craft Launcher 2\Modules\Base\ModBase.vb"
- name: Build - name: Build
+1 -1
View File
@@ -44,6 +44,6 @@
这些规则主要是为了阻止恶意的使用和 “山寨版” 的出现,常规、善意的使用都没啥问题的,放心吧! 这些规则主要是为了阻止恶意的使用和 “山寨版” 的出现,常规、善意的使用都没啥问题的,放心吧!
如果你只是参考了一小段代码,署个名就行啦,不用担心。 如果你只是参考了一小段代码,署个名就行啦,不用担心。
如果对具体细节有疑问,欢迎在 https://github.com/Hex-Dragon/PCL2/discussions/new?category=%E6%8F%90%E9%97%AE 发帖询问! 如果对具体细节有疑问,欢迎在 https://github.com/Meloong-Git/PCL/discussions/new?category=%E6%8F%90%E9%97%AE 发帖询问!
多谢大家啦! 多谢大家啦!
+4
View File
@@ -30,6 +30,10 @@
<assemblyIdentity name="System.ValueTuple" publicKeyToken="cc7b13ffcd2ddd51" culture="neutral"/> <assemblyIdentity name="System.ValueTuple" publicKeyToken="cc7b13ffcd2ddd51" culture="neutral"/>
<bindingRedirect oldVersion="0.0.0.0-4.0.3.0" newVersion="4.0.3.0"/> <bindingRedirect oldVersion="0.0.0.0-4.0.3.0" newVersion="4.0.3.0"/>
</dependentAssembly> </dependentAssembly>
<dependentAssembly>
<assemblyIdentity name="Newtonsoft.Json" publicKeyToken="30ad4fe6b2a6aeed" culture="neutral"/>
<bindingRedirect oldVersion="0.0.0.0-6.0.0.0" newVersion="13.0.0.0"/>
</dependentAssembly>
</assemblyBinding> </assemblyBinding>
</runtime> </runtime>
</configuration> </configuration>
+4 -7
View File
@@ -1,6 +1,7 @@
<Application x:Class="Application" <Application x:Class="Application"
xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation" xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
xmlns:behaviors="clr-namespace:PCL.Controls.Behaviors"
xmlns:local="clr-namespace:PCL" xmlns:local="clr-namespace:PCL"
xmlns:sys="clr-namespace:System;assembly=mscorlib" xmlns:sys="clr-namespace:System;assembly=mscorlib"
StartupUri="FormMain.xaml" StartupUri="FormMain.xaml"
@@ -8,12 +9,6 @@
<Application.Resources> <Application.Resources>
<ResourceDictionary> <ResourceDictionary>
<!-- 本地化 -->
<ResourceDictionary.MergedDictionaries>
<ResourceDictionary Source="pack://application:,,,/Resources/Language/zh_CN.xaml" />
<ResourceDictionary Source="pack://application:,,,/Resources/Language/zh_CN.xaml" />
</ResourceDictionary.MergedDictionaries>
<!-- Converter --> <!-- Converter -->
<local:AdditionConverter x:Key="AdditionConverter"/> <local:AdditionConverter x:Key="AdditionConverter"/>
<local:MultiplicationConverter x:Key="MultiplicationConverter"/> <local:MultiplicationConverter x:Key="MultiplicationConverter"/>
@@ -66,7 +61,7 @@
<SolidColorBrush x:Key="ColorBrushWhite" Color="#ffffff" /> <SolidColorBrush x:Key="ColorBrushWhite" Color="#ffffff" />
<SolidColorBrush x:Key="ColorBrushTransparent" Color="Transparent" /> <SolidColorBrush x:Key="ColorBrushTransparent" Color="Transparent" />
<SolidColorBrush x:Key="ColorBrushSemiTransparent">#01eaf2fe</SolidColorBrush> <SolidColorBrush x:Key="ColorBrushSemiTransparent">#01eaf2fe</SolidColorBrush>
<SolidColorBrush x:Key="ColorBrushBackgroundTransparentSidebar" Color="#D2FFFFFF" /> <SolidColorBrush x:Key="ColorBrushBackgroundTransparentSidebar" Color="#F1FFFFFF" />
<!-- Window --> <!-- Window -->
<Style TargetType="{x:Type Window}" x:Key="MyWindow"> <Style TargetType="{x:Type Window}" x:Key="MyWindow">
@@ -308,6 +303,7 @@
</ControlTemplate> </ControlTemplate>
</Setter.Value> </Setter.Value>
</Setter> </Setter>
<Setter Property="behaviors:ClipboardInterceptor.EnableSafeClipboard" Value="True" />
</Style> </Style>
<Style TargetType="PasswordBox"> <Style TargetType="PasswordBox">
<Setter Property="FontSize" Value="13" /> <Setter Property="FontSize" Value="13" />
@@ -349,6 +345,7 @@
</ControlTemplate> </ControlTemplate>
</Setter.Value> </Setter.Value>
</Setter> </Setter>
<Setter Property="behaviors:ClipboardInterceptor.EnableSafeClipboard" Value="True" />
</Style> </Style>
<!-- ComboBox --> <!-- ComboBox -->
+28 -61
View File
@@ -140,6 +140,7 @@ WaitRetry:
ServicePointManager.Expect100Continue = True ServicePointManager.Expect100Continue = True
ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12 ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12
ServicePointManager.DefaultConnectionLimit = 1024 ServicePointManager.DefaultConnectionLimit = 1024
ServicePointManager.UseNagleAlgorithm = False
'计时 '计时
Log("[Start] 第一阶段加载用时:" & GetTimeTick() - ApplicationStartTick & " ms") Log("[Start] 第一阶段加载用时:" & GetTimeTick() - ApplicationStartTick & " ms")
ApplicationStartTick = GetTimeTick() ApplicationStartTick = GetTimeTick()
@@ -165,79 +166,45 @@ WaitRetry:
End Sub End Sub
'异常 '异常
Private IsCritErrored As Boolean = False
Private Sub Application_DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Handles Me.DispatcherUnhandledException Private Sub Application_DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Handles Me.DispatcherUnhandledException
On Error Resume Next On Error Resume Next
e.Handled = True e.Handled = True
If IsProgramEnded Then Exit Sub If IsProgramEnded Then Return
If IsCritErrored Then FeedbackInfo()
'在汇报错误后继续引发错误,知道这次压不住了 Dim Detail As String = GetExceptionDetail(e.Exception, True)
FormMain.EndProgramForce(ProcessReturnValues.Exception) If Detail.Contains("System.Windows.Threading.Dispatcher.Invoke") OrElse Detail.Contains("MS.Internal.AppModel.ITaskbarList.HrInit") OrElse Detail.Contains("未能加载文件或程序集") OrElse
Exit Sub Detail.Contains(".NET Framework") Then ' “自动错误判断” 的结果分析
End If
IsCritErrored = True
Dim ExceptionString As String = GetExceptionDetail(e.Exception, True)
If ExceptionString.Contains("System.Windows.Threading.Dispatcher.Invoke") OrElse
ExceptionString.Contains("MS.Internal.AppModel.ITaskbarList.HrInit") OrElse
ExceptionString.Contains(".NET Framework") OrElse ' “自动错误判断” 的结果分析
ExceptionString.Contains("未能加载文件或程序集") Then
OpenWebsite("https://dotnet.microsoft.com/zh-cn/download/dotnet-framework/thank-you/net462-offline-installer") OpenWebsite("https://dotnet.microsoft.com/zh-cn/download/dotnet-framework/thank-you/net462-offline-installer")
MsgBox("你的 .NET Framework 版本过低或损坏,请下载并重新安装 .NET Framework 4.6.2!", MsgBoxStyle.Information, "运行环境错误") Log(e.Exception, "你的 .NET Framework 版本过低或损坏,请下载并重新安装 .NET Framework 4.6.2!" & vbCrLf & "若无法安装,可在卸载高版本的 .NET Framework 后再试。", LogLevel.Critical, "运行环境错误")
FormMain.EndProgramForce(ProcessReturnValues.Cancel)
Else Else
FeedbackInfo() Log(e.Exception, "程序出现未知错误", LogLevel.Critical, "锟斤拷烫烫烫")
Log(e.Exception, "程序出现未知错误", LogLevel.Assert, "锟斤拷烫烫烫")
End If End If
End Sub End Sub
'动态 DLL 调用 '动态 DLL 调用
Private Shared AssemblyNAudio As Assembly
Private Shared AssemblyJson As Assembly
Private Shared AssemblyDialog As Assembly
Private Shared AssemblyImazenWebp As Assembly
Private Shared ReadOnly AssemblyNAudioLock As New Object
Private Shared ReadOnly AssemblyJsonLock As New Object
Private Shared ReadOnly AssemblyDialogLock As New Object
Private Shared ReadOnly AssemblyImazenWebpLock As New Object
Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean
Public Shared Function AssemblyResolve(sender As Object, args As ResolveEventArgs) As Assembly Public Shared Function AssemblyResolve(sender As Object, Args As ResolveEventArgs) As Assembly
If args.Name.StartsWithF("NAudio") Then '缓存
SyncLock AssemblyNAudioLock Static Prefixes As String() = {"NAudio", "Newtonsoft.Json", "Ookii.Dialogs.Wpf", "Imazen.WebP", "CacheCow.Common", "CacheCow.Client.FileStore", "CacheCow.Client", "System.Net.Http.Formatting"}
If AssemblyNAudio Is Nothing Then Static Locks As New Dictionary(Of String, Object)(StringComparer.Ordinal)
Log("[Start] 加载 DLL:NAudio") Static LoadedAssembly As New Dictionary(Of String, Assembly)(StringComparer.Ordinal)
AssemblyNAudio = Assembly.Load(GetResources("NAudio")) '查找对应的 DLL
End If Dim Prefix As String = Prefixes.FirstOrDefault(Function(p) Args.Name.StartsWithF(p))
Return AssemblyNAudio If Prefix Is Nothing Then Return Nothing
End SyncLock '加载 DLL
ElseIf args.Name.StartsWithF("Newtonsoft.Json") Then If Not Locks.ContainsKey(Prefix) Then Locks(Prefix) = New Object()
SyncLock AssemblyJsonLock SyncLock Locks(Prefix)
If AssemblyJson Is Nothing Then If Not LoadedAssembly.ContainsKey(Prefix) Then
Log("[Start] 加载 DLL:Json") Log($"[Start] 加载 DLL:{Prefix}")
AssemblyJson = Assembly.Load(GetResources("Json")) LoadedAssembly(Prefix) = Assembly.Load(GetResources(Prefix))
End If 'WebP 特判
Return AssemblyJson If Prefix = "Imazen.WebP" Then
End SyncLock SetDllDirectory(PathPure.TrimEnd("\"c))
ElseIf args.Name.StartsWithF("Ookii.Dialogs.Wpf") Then
SyncLock AssemblyDialogLock
If AssemblyDialog Is Nothing Then
Log("[Start] 加载 DLL:Dialogs")
AssemblyDialog = Assembly.Load(GetResources("Dialogs"))
End If
Return AssemblyDialog
End SyncLock
ElseIf args.Name.StartsWithF("Imazen.WebP") Then
SyncLock AssemblyImazenWebpLock
If AssemblyImazenWebp Is Nothing Then
Log("[Start] 加载 DLL:Imazen.WebP")
AssemblyImazenWebp = Assembly.Load(GetResources("Imazen_WebP"))
SetDllDirectory(PathPure.TrimEnd("\"))
WriteFile(PathPure & "libwebp.dll", GetResources("libwebp64")) WriteFile(PathPure & "libwebp.dll", GetResources("libwebp64"))
End If End If
Return AssemblyImazenWebp End If
End SyncLock Return LoadedAssembly(Prefix)
Else End SyncLock
Return Nothing
End If
End Function End Function
'切换窗口 '切换窗口
@@ -0,0 +1,187 @@
' Author: uye (owner of the MaaAssistantArknights team)
' Original Source: MaaAssistantArknights project - https://github.com/MaaAssistantArknights/MaaAssistantArknights
' License: Apache License 2.0 (this file only)
'
' This file is originally developed for MaaAssistantArknights and licensed under AGPL v3.0.
' As the original author and copyright holder,
' I hereby re-license this file under the Apache License 2.0 for use in the Plain Craft Launcher project.
'
' This file is contributed under the spirit of good faith and open cooperation.
' It does not implement any core launcher functions of PCL.
'
' Description:
' Provides a WPF clipboard handling fix to avoid OpenClipboard exceptions
' in TextBox, RichTextBox, and DataGrid under Windows focus issues or clipboard hooks.
'
' Date: 2025-07-03
Imports System.Windows
Imports System.Windows.Controls
Imports System.Windows.Input
Imports System.Windows.Documents
Imports System.Linq
Namespace Controls.Behaviors
Public NotInheritable Class ClipboardInterceptor
Private Sub New()
End Sub
Public Shared ReadOnly EnableSafeClipboardProperty As DependencyProperty =
DependencyProperty.RegisterAttached("EnableSafeClipboard", GetType(Boolean), GetType(ClipboardInterceptor),
New PropertyMetadata(False, AddressOf OnEnableSafeClipboardChanged))
Public Shared Sub SetEnableSafeClipboard(element As DependencyObject, value As Boolean)
element.SetValue(EnableSafeClipboardProperty, value)
End Sub
Public Shared Function GetEnableSafeClipboard(element As DependencyObject) As Boolean
Return CBool(element.GetValue(EnableSafeClipboardProperty))
End Function
Private Shared Sub OnEnableSafeClipboardChanged(d As DependencyObject, e As DependencyPropertyChangedEventArgs)
If TypeOf d Is TextBox AndAlso CBool(e.NewValue) Then
AddCommandBindingsToTextBox(DirectCast(d, TextBox))
ElseIf TypeOf d Is RichTextBox AndAlso CBool(e.NewValue) Then
AddCommandBindingsToRichTextBox(DirectCast(d, RichTextBox))
ElseIf TypeOf d Is DataGrid AndAlso CBool(e.NewValue) Then
AddCommandBindingsToDataGrid(DirectCast(d, DataGrid))
End If
End Sub
Private Shared Sub AddCommandBindingsToTextBox(tb As TextBox)
tb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Copy, AddressOf OnCopyTextBox))
tb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Cut, AddressOf OnCutTextBox))
tb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Paste, AddressOf OnPasteTextBox))
End Sub
Private Shared Sub AddCommandBindingsToRichTextBox(rtb As RichTextBox)
rtb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Copy, AddressOf OnCopyRichTextBox))
rtb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Cut, AddressOf OnCutRichTextBox))
rtb.CommandBindings.Add(New CommandBinding(ApplicationCommands.Paste, AddressOf OnPasteRichTextBox))
End Sub
Private Shared Sub AddCommandBindingsToDataGrid(dg As DataGrid)
dg.CommandBindings.Add(New CommandBinding(ApplicationCommands.Copy, AddressOf OnCopyDataGrid))
End Sub
Private Shared Sub OnCopyTextBox(sender As Object, e As ExecutedRoutedEventArgs)
Dim tb = TryCast(sender, TextBox)
If tb Is Nothing OrElse tb.SelectionLength <= 0 Then Return
Try
Forms.Clipboard.Clear()
Forms.Clipboard.SetDataObject(tb.SelectedText, True)
Catch
End Try
e.Handled = True
End Sub
Private Shared Sub OnCutTextBox(sender As Object, e As ExecutedRoutedEventArgs)
Dim tb = TryCast(sender, TextBox)
If tb Is Nothing OrElse tb.SelectionLength <= 0 Then Return
Try
Forms.Clipboard.Clear()
Forms.Clipboard.SetDataObject(tb.SelectedText, True)
Catch
End Try
tb.SelectedText = String.Empty
e.Handled = True
End Sub
Private Shared Sub OnPasteTextBox(sender As Object, e As ExecutedRoutedEventArgs)
Dim tb = TryCast(sender, TextBox)
If tb Is Nothing Then Return
If Forms.Clipboard.ContainsText() Then
Dim pasteText = Forms.Clipboard.GetText()
Dim start = tb.SelectionStart
tb.SelectedText = pasteText
tb.CaretIndex = start + pasteText.Length
tb.SelectionLength = 0
End If
e.Handled = True
End Sub
Private Shared Sub OnCopyRichTextBox(sender As Object, e As ExecutedRoutedEventArgs)
Dim rtb = TryCast(sender, RichTextBox)
If rtb Is Nothing Then Return
Dim textRange = New TextRange(rtb.Selection.Start, rtb.Selection.End)
If String.IsNullOrEmpty(textRange.Text) Then Return
Try
Forms.Clipboard.Clear()
Forms.Clipboard.SetDataObject(textRange.Text, True)
Catch
End Try
e.Handled = True
End Sub
Private Shared Sub OnCutRichTextBox(sender As Object, e As ExecutedRoutedEventArgs)
Dim rtb = TryCast(sender, RichTextBox)
If rtb Is Nothing Then Return
Dim selection = New TextRange(rtb.Selection.Start, rtb.Selection.End)
If String.IsNullOrEmpty(selection.Text) Then Return
Try
Forms.Clipboard.Clear()
Forms.Clipboard.SetDataObject(selection.Text, True)
Catch
End Try
selection.Text = String.Empty
e.Handled = True
End Sub
Private Shared Sub OnPasteRichTextBox(sender As Object, e As ExecutedRoutedEventArgs)
Dim rtb = TryCast(sender, RichTextBox)
If rtb Is Nothing Then Return
If Not Forms.Clipboard.ContainsText() Then Return
Dim pasteText = Forms.Clipboard.GetText()
Dim selection = rtb.Selection
selection.Text = pasteText
Dim caretPos = selection.End
rtb.CaretPosition = caretPos
rtb.Selection.Select(caretPos, caretPos)
e.Handled = True
End Sub
Private Shared Sub OnCopyDataGrid(sender As Object, e As ExecutedRoutedEventArgs)
Dim dg = TryCast(sender, DataGrid)
If dg Is Nothing OrElse dg.SelectedCells Is Nothing OrElse dg.SelectedCells.Count = 0 Then Return
Dim sb = New System.Text.StringBuilder()
Dim rowGroups = dg.SelectedCells.GroupBy(Function(c) c.Item)
For Each row In rowGroups
Dim rowText = String.Join(vbTab, row.Select(Function(cell)
Dim tb = TryCast(cell.Column.GetCellContent(cell.Item), TextBlock)
Return If(tb IsNot Nothing, tb.Text, "")
End Function))
sb.AppendLine(rowText)
Next
Dim sbStr = sb.ToString().TrimEnd(ControlChars.Cr, ControlChars.Lf)
Try
Forms.Clipboard.Clear()
Forms.Clipboard.SetDataObject(sbStr, True)
Catch
End Try
e.Handled = True
End Sub
End Class
End Namespace
@@ -142,7 +142,7 @@ Public Class MyButton
'实现自定义事件 '实现自定义事件
Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp
If Not IsMouseDown Then Exit Sub If Not IsMouseDown Then Return
Log("[Control] 按下按钮:" & Text) Log("[Control] 按下按钮:" & Text)
RaiseEvent Click(sender, e) RaiseEvent Click(sender, e)
If Not String.IsNullOrEmpty(Tag) Then If Not String.IsNullOrEmpty(Tag) Then
@@ -185,7 +185,7 @@ Public Class MyButton
AniStart(AaColor(PanFore, BackgroundProperty, If(_ColorType = ColorState.Red, "ColorBrushRedBack", "ColorBrush7"), AnimationColorIn), "MyButton Background " & Uuid) AniStart(AaColor(PanFore, BackgroundProperty, If(_ColorType = ColorState.Red, "ColorBrushRedBack", "ColorBrush7"), AnimationColorIn), "MyButton Background " & Uuid)
End Sub End Sub
Private Sub Button_MouseUp() Handles Me.MouseLeftButtonUp Private Sub Button_MouseUp() Handles Me.MouseLeftButtonUp
If Not IsMouseDown Then Exit Sub If Not IsMouseDown Then Return
IsMouseDown = False IsMouseDown = False
AniStart({ AniStart({
AaScaleTransform(PanFore, 1 - CType(PanFore.RenderTransform, ScaleTransform).ScaleX, 300, 10, New AniEaseOutFluent(AniEasePower.Middle)) AaScaleTransform(PanFore, 1 - CType(PanFore.RenderTransform, ScaleTransform).ScaleX, 300, 10, New AniEaseOutFluent(AniEasePower.Middle))
@@ -193,7 +193,7 @@ Public Class MyButton
End Sub End Sub
Private Sub Button_MouseLeave() Handles Me.MouseLeave Private Sub Button_MouseLeave() Handles Me.MouseLeave
AniStart(AaColor(PanFore, BackgroundProperty, "ColorBrushHalfWhite", AnimationColorOut), "MyButton Background " & Uuid) AniStart(AaColor(PanFore, BackgroundProperty, "ColorBrushHalfWhite", AnimationColorOut), "MyButton Background " & Uuid)
If Not IsMouseDown Then Exit Sub If Not IsMouseDown Then Return
IsMouseDown = False IsMouseDown = False
AniStart(AaScaleTransform(PanFore, 1 - CType(PanFore.RenderTransform, ScaleTransform).ScaleX, 800,, New AniEaseOutFluent(AniEasePower.Strong)), "MyButton Scale " & Uuid) AniStart(AaScaleTransform(PanFore, 1 - CType(PanFore.RenderTransform, ScaleTransform).ScaleX, 800,, New AniEaseOutFluent(AniEasePower.Strong)), "MyButton Scale " & Uuid)
End Sub End Sub
+89 -57
View File
@@ -3,7 +3,7 @@
'控件 '控件
Inherits Grid Inherits Grid
Private ReadOnly MainGrid As Grid Private ReadOnly MainGrid As Grid
Public ReadOnly Property MainChrome As SystemDropShadowChrome Public ReadOnly Property MainChrome As MyDropShadow
Private ReadOnly MainBorder As Border Private ReadOnly MainBorder As Border
Public Property BorderChild As UIElement Public Property BorderChild As UIElement
Get Get
@@ -63,17 +63,18 @@
'UI 建立 'UI 建立
Public Sub New() Public Sub New()
MainChrome = New SystemDropShadowChrome With {.Margin = New Thickness(-9.5, -9, 0.5, -0.5), .Opacity = 0.1, .CornerRadius = New CornerRadius(6)} MainChrome = New MyDropShadow With {
MainChrome.SetResourceReference(SystemDropShadowChrome.ColorProperty, "ColorObject1") .Margin = New Thickness(-3, -3, -3, -3 - GetWPFSize(1)), .ShadowRadius = 3, .Opacity = DropShadowIdleOpacity, .CornerRadius = New CornerRadius(5)}
MainChrome.SetResourceReference(MyDropShadow.ColorProperty, "ColorObject1")
Children.Insert(0, MainChrome) Children.Insert(0, MainChrome)
MainBorder = New Border With {.Background = New SolidColorBrush(Color.FromArgb(205, 255, 255, 255)), .CornerRadius = New CornerRadius(6), .IsHitTestVisible = False} MainBorder = New Border With {.Background = New SolidColorBrush(Color.FromArgb(245, 255, 255, 255)), .CornerRadius = New CornerRadius(5), .IsHitTestVisible = False}
Children.Insert(1, MainBorder) Children.Insert(1, MainBorder)
MainGrid = New Grid MainGrid = New Grid
Children.Add(MainGrid) Children.Add(MainGrid)
End Sub End Sub
Private IsLoad As Boolean = False Private IsLoad As Boolean = False
Private Sub Init() Handles Me.Loaded Private Sub Init() Handles Me.Loaded
If IsLoad Then Exit Sub If IsLoad Then Return
IsLoad = True IsLoad = True
'初次加载限定 '初次加载限定
If MainTextBlock Is Nothing Then If MainTextBlock Is Nothing Then
@@ -89,7 +90,7 @@
MainGrid.Children.Add(MainSwap) MainGrid.Children.Add(MainSwap)
End If End If
'改变默认的折叠 '改变默认的折叠
If IsSwaped AndAlso SwapControl IsNot Nothing Then If IsSwapped AndAlso SwapControl IsNot Nothing Then
MainSwap.RenderTransform = New RotateTransform(If(SwapLogoRight, 270, 0)) MainSwap.RenderTransform = New RotateTransform(If(SwapLogoRight, 270, 0))
'取消由于高度变化被迫触发的高度动画 '取消由于高度变化被迫触发的高度动画
Dim RawUseAnimation As Boolean = UseAnimation Dim RawUseAnimation As Boolean = UseAnimation
@@ -108,7 +109,7 @@
'这一部分的代码是好几年前留下的究极屎坑,当时还不知道该咋正确调用这种方法,就写了这么一坨屎 '这一部分的代码是好几年前留下的究极屎坑,当时还不知道该咋正确调用这种方法,就写了这么一坨屎
'但是现在……反正勉强能用……懒得改了就这样吧.jpg '但是现在……反正勉强能用……懒得改了就这样吧.jpg
'别骂了别骂了.jpg '别骂了别骂了.jpg
If IsNothing(Stack.Tag) Then Exit Sub If IsNothing(Stack.Tag) Then Return
'排序 '排序
Select Case Type Select Case Type
Case 3 Case 3
@@ -186,29 +187,29 @@
Stack.Tag = Nothing Stack.Tag = Nothing
End Sub End Sub
'事件 '动画
Private Const DropShadowIdleOpacity As Double = 0.07
Private Const DropShadowHoverOpacity As Double = 0.4
Public Property HasMouseAnimation As Boolean = True Public Property HasMouseAnimation As Boolean = True
Private Sub MyCard_MouseEnter(sender As Object, e As MouseEventArgs) Handles Me.MouseEnter Private Sub MyCard_MouseEnter(sender As Object, e As MouseEventArgs) Handles Me.MouseEnter
If Not HasMouseAnimation Then Exit Sub If Not HasMouseAnimation Then Return
Dim AniList As New List(Of AniData) Dim AniList As New List(Of AniData)
If Not IsNothing(MainTextBlock) Then AniList.Add(AaColor(MainTextBlock, TextBlock.ForegroundProperty, "ColorBrush2", 150)) If Not IsNothing(MainTextBlock) Then AniList.Add(AaColor(MainTextBlock, TextBlock.ForegroundProperty, "ColorBrush2", 90))
If Not IsNothing(MainSwap) Then AniList.Add(AaColor(MainSwap, Shapes.Path.FillProperty, "ColorBrush2", 150)) If Not IsNothing(MainSwap) Then AniList.Add(AaColor(MainSwap, Shapes.Path.FillProperty, "ColorBrush2", 90))
AniList.AddRange({ AniList.AddRange({
AaColor(MainChrome, SystemDropShadowChrome.ColorProperty, "ColorObject2", 180), AaColor(MainChrome, MyDropShadow.ColorProperty, "ColorObject4", 90),
AaColor(MainBorder, Border.BackgroundProperty, New MyColor(230, 255, 255, 255) - MainBorder.Background, 180), AaOpacity(MainChrome, DropShadowHoverOpacity - MainChrome.Opacity, 90)
AaOpacity(MainChrome, 0.3 - MainChrome.Opacity, 180)
}) })
AniStart(AniList, "MyCard Mouse " & Uuid) AniStart(AniList, "MyCard Mouse " & Uuid)
End Sub End Sub
Private Sub MyCard_MouseLeave(sender As Object, e As MouseEventArgs) Handles Me.MouseLeave Private Sub MyCard_MouseLeave(sender As Object, e As MouseEventArgs) Handles Me.MouseLeave
If Not HasMouseAnimation Then Exit Sub If Not HasMouseAnimation Then Return
Dim AniList As New List(Of AniData) Dim AniList As New List(Of AniData)
If Not IsNothing(MainTextBlock) Then AniList.Add(AaColor(MainTextBlock, TextBlock.ForegroundProperty, "ColorBrush1", 250)) If Not IsNothing(MainTextBlock) Then AniList.Add(AaColor(MainTextBlock, TextBlock.ForegroundProperty, "ColorBrush1", 90))
If Not IsNothing(MainSwap) Then AniList.Add(AaColor(MainSwap, Shapes.Path.FillProperty, "ColorBrush1", 250)) If Not IsNothing(MainSwap) Then AniList.Add(AaColor(MainSwap, Shapes.Path.FillProperty, "ColorBrush1", 90))
AniList.AddRange({ AniList.AddRange({
AaColor(MainChrome, SystemDropShadowChrome.ColorProperty, "ColorObject1", 300), AaColor(MainChrome, MyDropShadow.ColorProperty, "ColorObject1", 90),
AaColor(MainBorder, Border.BackgroundProperty, New MyColor(205, 255, 255, 255) - MainBorder.Background, 300), AaOpacity(MainChrome, DropShadowIdleOpacity - MainChrome.Opacity, 90)
AaOpacity(MainChrome, 0.1 - MainChrome.Opacity, 300)
}) })
AniStart(AniList, "MyCard Mouse " & Uuid) AniStart(AniList, "MyCard Mouse " & Uuid)
End Sub End Sub
@@ -222,46 +223,64 @@
Private IsHeightAnimating As Boolean = False Private IsHeightAnimating As Boolean = False
Private ActualUsedHeight As Double '回滚实际高度(例如 NaN) Private ActualUsedHeight As Double '回滚实际高度(例如 NaN)
Private Sub MySizeChanged(sender As Object, e As SizeChangedEventArgs) Handles Me.SizeChanged Private Sub MySizeChanged(sender As Object, e As SizeChangedEventArgs) Handles Me.SizeChanged
If Not UseAnimation Then Exit Sub If Not UseAnimation Then Return
Dim DeltaHeight As Double = If(IsSwaped, SwapedHeight, e.NewSize.Height) - e.PreviousSize.Height Dim DeltaHeight As Double = If(IsSwapped, SwapedHeight, e.NewSize.Height) - e.PreviousSize.Height
'卡片的进入时动画已被页面通用切换动画替代 '卡片的进入时动画已被页面通用切换动画替代
If e.PreviousSize.Height = 0 OrElse IsHeightAnimating OrElse Math.Abs(DeltaHeight) < 1 OrElse ActualHeight = 0 Then Exit Sub If e.PreviousSize.Height = 0 OrElse IsHeightAnimating OrElse Math.Abs(DeltaHeight) < 1 OrElse ActualHeight = 0 Then Return
StartHeightAnimation(DeltaHeight, e.PreviousSize.Height, False) StartHeightAnimation(DeltaHeight, e.PreviousSize.Height, False)
End Sub End Sub
Private Sub StartHeightAnimation(DeltaHeight As Double, PreviousHeight As Double, IsLoadAnimation As Boolean) Private Sub StartHeightAnimation(Delta As Double, PreviousHeight As Double, IsLoadAnimation As Boolean)
If IsHeightAnimating OrElse FrmMain Is Nothing Then Exit Sub '避免 XAML 设计器出错 If IsHeightAnimating OrElse FrmMain Is Nothing Then Return '避免 XAML 设计器出错
Dim AnimList As New List(Of AniData) Dim AnimList As New List(Of AniData)
If DeltaHeight > 10 OrElse (DeltaHeight < -10 AndAlso Not IsNothing(SwapControl)) Then '如果不是需要折叠的卡片,高度减小时的弹跳会吞掉按钮下边框 Dim AbsDelta = Math.Abs(Delta)
'高度增加较大,使用弹起动画
Dim Delta As Double = MathClamp(Math.Abs(DeltaHeight) * 0.05, 3, 10) * Math.Sign(DeltaHeight) If AbsDelta <= 800 Then
AnimList.AddRange({ '短距离,直接使用 150ms 的缓动动画
AaHeight(Me, DeltaHeight + Delta, 300, If(IsLoadAnimation, 30, 0), If(DeltaHeight > FrmMain.Height, New AniEaseInFluent(AniEasePower.ExtraStrong), New AniEaseOutFluent(AniEasePower.ExtraStrong))), AnimList.Add(AaHeight(Me, Delta, 150,, New AniEaseOutFluent(AniEasePower.ExtraStrong)))
AaHeight(Me, -Delta, 150, 260, Ease:=New AniEaseOutFluent(AniEasePower.Strong))
})
Else Else
'普通的改变就行啦 Dim EaseLength As Integer, EaseTime As Integer
AnimList.AddRange({ Dim InitSpeed As Integer '到达缓动区前的初速度
AaHeight(Me, DeltaHeight, MathClamp(Math.Abs(DeltaHeight) * 4, 150, 250),, New AniEaseOutFluent) If Delta < 0 AndAlso AbsDelta - EaseLength > 5000 * 0.1 Then
}) '收回距离过长 (>0.1s),强制以 100ms 完成匀速段,然后让减速段更长
EaseLength = 200
EaseTime = 150
InitSpeed = (AbsDelta - EaseLength) / 0.1
ElseIf Delta > 0 AndAlso AbsDelta - EaseLength > 5000 * 0.6 Then
'展开距离过长 (>0.6s),以 5000 速度展示 300ms 匀速段,剩下的距离全部归入减速段
InitSpeed = 5000
EaseLength = AbsDelta - InitSpeed * 0.3
EaseTime = 400
Else
'中程,匀速地快速展开(或收回)
EaseLength = 150
EaseTime = 200
InitSpeed = 4000
End If
'匀速段
AnimList.Add(AaHeight(Me, (AbsDelta - EaseLength) * Math.Sign(Delta),
(AbsDelta - EaseLength) / InitSpeed * 1000))
'减速段
AnimList.Add(AaHeight(Me, EaseLength * Math.Sign(Delta),
EaseTime,, New AniEaseOutFluentWithInitial(InitSpeed, EaseTime / 1000, EaseLength), True))
End If End If
AnimList.Add(AaCode( AnimList.Add(AaCode(
Sub() Sub()
IsHeightAnimating = False IsHeightAnimating = False
Height = ActualUsedHeight Height = ActualUsedHeight
If IsSwaped Then SwapControl.Visibility = Visibility.Collapsed If IsSwapped AndAlso SwapControl IsNot Nothing Then SwapControl.Visibility = Visibility.Collapsed
End Sub,, True)) End Sub,, True))
AniStart(AnimList, "MyCard Height " & Uuid) AniStart(AnimList, "MyCard Height " & Uuid)
IsHeightAnimating = True IsHeightAnimating = True
ActualUsedHeight = If(IsSwaped, SwapedHeight, Height) ActualUsedHeight = If(IsSwapped, SwapedHeight, Height)
Height = PreviousHeight Height = PreviousHeight
End Sub End Sub
''' <summary> ''' <summary>
''' 通知 MyCard,控件内容已改变,需要中断动画并更新高度。 ''' 通知 MyCard,控件内容已改变,需要中断动画并更新高度。
''' </summary> ''' </summary>
Public Sub TriggerForceResize() Public Sub TriggerForceResize()
Height = If(IsSwaped, SwapedHeight, Double.NaN) Height = If(IsSwapped, SwapedHeight, Double.NaN)
AniStop("MyCard Height " & Uuid) AniStop("MyCard Height " & Uuid)
IsHeightAnimating = False IsHeightAnimating = False
End Sub End Sub
@@ -281,26 +300,39 @@
''' <summary> ''' <summary>
''' 是否已被折叠。 ''' 是否已被折叠。
''' </summary> ''' </summary>
Public Property IsSwaped As Boolean Public Property IsSwapped As Boolean
Get Get
Return _IsSwaped Return _IsSwapped
End Get End Get
Set(value As Boolean) Set(value As Boolean)
If _IsSwaped = value Then Exit Property If _IsSwapped = value Then Return
_IsSwaped = value _IsSwapped = value
If SwapControl Is Nothing Then Exit Property If SwapControl Is Nothing Then Return
'展开 '展开
If Not IsSwaped AndAlso TypeOf SwapControl Is StackPanel Then StackInstall(SwapControl, SwapType, Title) If Not IsSwapped AndAlso TypeOf SwapControl Is StackPanel Then StackInstall(SwapControl, SwapType, Title)
'若尚未加载,会在 Loaded 事件中触发无动画的折叠,不需要在这里进行 '若尚未加载,会在 Loaded 事件中触发无动画的折叠,不需要在这里进行
If Not IsLoaded Then Exit Property If Not IsLoaded Then Return
'更新高度 '更新高度
SwapControl.Visibility = Visibility.Visible SwapControl.Visibility = Visibility.Visible
TriggerForceResize() TriggerForceResize()
'改变箭头 '改变箭头
AniStart(AaRotateTransform(MainSwap, If(_IsSwaped, If(SwapLogoRight, 270, 0), 180) - CType(MainSwap.RenderTransform, RotateTransform).Angle, 400,, New AniEaseOutBack(AniEasePower.Weak)), "MyCard Swap " & Uuid, True) AniStart(AaRotateTransform(MainSwap, If(_IsSwapped, If(SwapLogoRight, 270, 0), 180) - CType(MainSwap.RenderTransform, RotateTransform).Angle, 250,, New AniEaseOutFluent(AniEasePower.ExtraStrong)), "MyCard Swap " & Uuid, True)
End Set End Set
End Property End Property
Private _IsSwaped As Boolean = False Private _IsSwapped As Boolean = False
''' <summary>
''' 是否已被折叠。(已过时,请使用 IsSwapped)
''' </summary>
<Obsolete("IsSwaped 存在拼写错误,请换用 IsSwapped 属性。")>
Public Property IsSwaped As Boolean
Get
Return IsSwapped
End Get
Set(value As Boolean)
IsSwapped = value
End Set
End Property
Public Shared ReadOnly IsSwapedProperty As DependencyProperty = DependencyProperty.Register("IsSwaped", GetType(Boolean), GetType(MyCard), New PropertyMetadata(False))
Public Property SwapLogoRight As Boolean = False Public Property SwapLogoRight As Boolean = False
Private IsMouseDown As Boolean = False Private IsMouseDown As Boolean = False
@@ -309,8 +341,8 @@
Public Const SwapedHeight As Integer = 40 Public Const SwapedHeight As Integer = 40
Private Sub MyCard_MouseLeftButtonDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown Private Sub MyCard_MouseLeftButtonDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonDown
Dim Pos As Double = Mouse.GetPosition(Me).Y Dim Pos As Double = Mouse.GetPosition(Me).Y
If Not IsSwaped AndAlso If Not IsSwapped AndAlso
(SwapControl Is Nothing OrElse Pos > If(IsSwaped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Exit Sub '检测点击位置;或已经不在可视树上的误判 (SwapControl Is Nothing OrElse Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置;或已经不在可视树上的误判
IsMouseDown = True IsMouseDown = True
End Sub End Sub
Private Sub MyCard_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp Private Sub MyCard_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseLeftButtonUp
@@ -318,8 +350,8 @@
IsMouseDown = False IsMouseDown = False
Dim Pos As Double = Mouse.GetPosition(Me).Y Dim Pos As Double = Mouse.GetPosition(Me).Y
If Not IsSwaped AndAlso If Not IsSwapped AndAlso
(SwapControl Is Nothing OrElse Pos > If(IsSwaped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Exit Sub '检测点击位置;或已经不在可视树上的误判 (SwapControl Is Nothing OrElse Pos > If(IsSwapped, SwapedHeight, SwapedHeight - 6) OrElse (Pos = 0 AndAlso Not IsMouseDirectlyOver)) Then Return '检测点击位置;或已经不在可视树上的误判
Dim ee = New RouteEventArgs(True) Dim ee = New RouteEventArgs(True)
RaiseEvent PreviewSwap(Me, ee) RaiseEvent PreviewSwap(Me, ee)
@@ -328,8 +360,8 @@
Return Return
End If End If
IsSwaped = Not IsSwaped IsSwapped = Not IsSwapped
Log("[Control] " & If(IsSwaped, "折叠卡片", "展开卡片") & If(Title Is Nothing, "", ":" & Title)) Log("[Control] " & If(IsSwapped, "折叠卡片", "展开卡片") & If(Title Is Nothing, "", ":" & Title))
RaiseEvent Swap(Me, ee) RaiseEvent Swap(Me, ee)
End Sub End Sub
Private Sub MyCard_MouseLeave_Swap(sender As Object, e As MouseEventArgs) Handles Me.MouseLeave Private Sub MyCard_MouseLeave_Swap(sender As Object, e As MouseEventArgs) Handles Me.MouseLeave
@@ -350,7 +382,7 @@ Partial Public Module ModAnimation
AaCode( AaCode(
Sub() Sub()
If RemoveFromChildren Then If RemoveFromChildren Then
If Control.Parent Is Nothing Then Exit Sub If Control.Parent Is Nothing Then Return
CType(Control.Parent, Object).Children.Remove(Control) CType(Control.Parent, Object).Children.Remove(Control)
Else Else
Control.Visibility = Visibility.Collapsed Control.Visibility = Visibility.Collapsed
@@ -360,7 +392,7 @@ Partial Public Module ModAnimation
}, "MyCard Dispose " & Control.Uuid) }, "MyCard Dispose " & Control.Uuid)
Else Else
If RemoveFromChildren Then If RemoveFromChildren Then
If Control.Parent Is Nothing Then Exit Sub If Control.Parent Is Nothing Then Return
CType(Control.Parent, Object).Children.Remove(Control) CType(Control.Parent, Object).Children.Remove(Control)
Else Else
Control.Visibility = Visibility.Collapsed Control.Visibility = Visibility.Collapsed
@@ -40,7 +40,7 @@ Public Class MyCheckBox
''' <param name="user">是否由用户引发。</param> ''' <param name="user">是否由用户引发。</param>
Public Sub SetChecked(value As Boolean, user As Boolean) Public Sub SetChecked(value As Boolean, user As Boolean)
Try Try
If value = Checked Then Exit Sub If value = Checked Then Return
'Preview 事件 'Preview 事件
If value AndAlso user Then If value AndAlso user Then
@@ -50,7 +50,7 @@ Public Class MyCheckBox
MouseDowned = True MouseDowned = True
Checkbox_MouseLeave() Checkbox_MouseLeave()
MouseDowned = False MouseDowned = False
Exit Sub Return
End If End If
End If End If
@@ -133,14 +133,14 @@ Public Class MyCheckBox
Private MouseDowned As Boolean = False Private MouseDowned As Boolean = False
Private AllowMouseDown As Boolean = True Private AllowMouseDown As Boolean = True
Private Sub Checkbox_MouseUp() Handles Me.MouseLeftButtonUp Private Sub Checkbox_MouseUp() Handles Me.MouseLeftButtonUp
If Not MouseDowned Then Exit Sub If Not MouseDowned Then Return
Log("[Control] 按下复选框(" & (Not Checked).ToString & "):" & Text) Log("[Control] 按下复选框(" & (Not Checked).ToString & "):" & Text)
MouseDowned = False MouseDowned = False
SetChecked(Not Checked, True) SetChecked(Not Checked, True)
AniStart(AaColor(ShapeBorder, Border.BackgroundProperty, "ColorBrushHalfWhite", 100), "MyCheckBox Background " & Uuid) AniStart(AaColor(ShapeBorder, Border.BackgroundProperty, "ColorBrushHalfWhite", 100), "MyCheckBox Background " & Uuid)
End Sub End Sub
Private Sub Checkbox_MouseDown() Handles Me.MouseLeftButtonDown Private Sub Checkbox_MouseDown() Handles Me.MouseLeftButtonDown
If Not AllowMouseDown Then Exit Sub If Not AllowMouseDown Then Return
MouseDowned = True MouseDowned = True
Focus() Focus()
AniStart(AaColor(ShapeBorder, Border.BackgroundProperty, "ColorBrushBg1", 100), "MyCheckBox Background " & Uuid) AniStart(AaColor(ShapeBorder, Border.BackgroundProperty, "ColorBrushBg1", 100), "MyCheckBox Background " & Uuid)
@@ -154,7 +154,7 @@ Public Class MyCheckBox
End If End If
End Sub End Sub
Private Sub Checkbox_MouseLeave() Handles Me.MouseLeave Private Sub Checkbox_MouseLeave() Handles Me.MouseLeave
If Not MouseDowned Then Exit Sub If Not MouseDowned Then Return
MouseDowned = False MouseDowned = False
AniStart(AaColor(ShapeBorder, Border.BackgroundProperty, "ColorBrushHalfWhite", 100), "MyCheckBox Background " & Uuid) AniStart(AaColor(ShapeBorder, Border.BackgroundProperty, "ColorBrushHalfWhite", 100), "MyCheckBox Background " & Uuid)
If Checked Then If Checked Then
@@ -203,7 +203,7 @@ Public Class MyCheckBox
}, "MyCheckBox BorderColor " & Uuid) }, "MyCheckBox BorderColor " & Uuid)
End Sub End Sub
Private Sub Checkbox_MouseLeaveAnimation() Handles Me.MouseLeave Private Sub Checkbox_MouseLeaveAnimation() Handles Me.MouseLeave
If Not IsEnabled Then Exit Sub 'MouseLeave 比 IsEnabledChanged 后执行,所以如果自定义事件修改了 IsEnabled,将导致显示错误 If Not IsEnabled Then Return 'MouseLeave 比 IsEnabledChanged 后执行,所以如果自定义事件修改了 IsEnabled,将导致显示错误
AniStart({ AniStart({
AaColor(LabText, TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray4"), AnimationTimeOfMouseOut) AaColor(LabText, TextBlock.ForegroundProperty, If(Me.IsEnabled, "ColorBrush1", "ColorBrushGray4"), AnimationTimeOfMouseOut)
}, "MyCheckBox TextColor " & Uuid) }, "MyCheckBox TextColor " & Uuid)
@@ -8,7 +8,7 @@
Public Property HintText As String = "" Public Property HintText As String = ""
Public Overrides Sub OnApplyTemplate() Public Overrides Sub OnApplyTemplate()
MyBase.OnApplyTemplate() MyBase.OnApplyTemplate()
If Not IsEditable Then Exit Sub If Not IsEditable Then Return
Try Try
TextBox = Template.FindName("PART_EditableTextBox", Me) TextBox = Template.FindName("PART_EditableTextBox", Me)
TextBox.AddHandler(LostFocusEvent, New RoutedEventHandler(AddressOf RefreshColor)) TextBox.AddHandler(LostFocusEvent, New RoutedEventHandler(AddressOf RefreshColor))
@@ -116,7 +116,7 @@
'修复 WPF Bug:下拉框文本修改后,依然误认为还选择着此前的选项,导致再次点击该选项时内容不变 '修复 WPF Bug:下拉框文本修改后,依然误认为还选择着此前的选项,导致再次点击该选项时内容不变
Private IsTextChanging As Boolean = False Private IsTextChanging As Boolean = False
Private Sub MyComboBox_TextChanged(sender As Object, e As TextChangedEventArgs) Handles Me.TextChanged Private Sub MyComboBox_TextChanged(sender As Object, e As TextChangedEventArgs) Handles Me.TextChanged
If IsTextChanging OrElse Not IsEditable Then Exit Sub If IsTextChanging OrElse Not IsEditable Then Return
If SelectedItem IsNot Nothing AndAlso Text <> SelectedItem.ToString Then If SelectedItem IsNot Nothing AndAlso Text <> SelectedItem.ToString Then
Dim RawText As String = Text Dim RawText As String = Text
Dim RawSelectionStart As Integer = TextBox.SelectionStart Dim RawSelectionStart As Integer = TextBox.SelectionStart
@@ -35,7 +35,7 @@
NewFontOpacity = 0.4 NewFontOpacity = 0.4
Time = AnimationTimeOut Time = AnimationTimeOut
End If End If
If BackColorName = NewBackColorName AndAlso FontOpacity = NewFontOpacity Then Exit Sub If BackColorName = NewBackColorName AndAlso FontOpacity = NewFontOpacity Then Return
BackColorName = NewBackColorName BackColorName = NewBackColorName
FontOpacity = NewFontOpacity FontOpacity = NewFontOpacity
'触发颜色动画 '触发颜色动画
@@ -1,65 +1,89 @@
Public NotInheritable Class SystemDropShadowChrome Public Class MyDropShadow
Inherits Decorator Inherits Decorator
'源码来源于:https://referencesource.microsoft.com/#PresentationFramework.Aero/parent/Shared/Microsoft/Windows/Themes/SystemDropShadowChrome.cs,6d9c27d92a8128c1 ''' <summary>
''' 阴影颜色。
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))) ''' </summary>
Public Property Color As Color Public Property Color As Color
Get Get
Return CType(GetValue(ColorProperty), Color) Return GetValue(ColorProperty)
End Get End Get
Set(value As Color) Set(value As Color)
SetValue(ColorProperty, value) SetValue(ColorProperty, value)
End Set End Set
End Property End Property
Public Shared ReadOnly ColorProperty As DependencyProperty = DependencyProperty.Register("Color", GetType(Color), GetType(MyDropShadow),
New FrameworkPropertyMetadata(Color.FromArgb(&H71, &H0, &H0, &H0), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)))
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)) ''' <summary>
''' 阴影模糊半径。
''' </summary>
Public Property ShadowRadius As Double
Get
Return GetValue(ShadowRadiusProperty)
End Get
Set(value As Double)
SetValue(ShadowRadiusProperty, value)
End Set
End Property
Public Shared ReadOnly ShadowRadiusProperty As DependencyProperty = DependencyProperty.Register("ShadowRadius", GetType(Double), GetType(MyDropShadow),
New FrameworkPropertyMetadata(CDbl(5), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)))
''' <summary>
''' 圆角大小。
''' </summary>
Public Property CornerRadius As CornerRadius Public Property CornerRadius As CornerRadius
Get Get
Return CType(GetValue(CornerRadiusProperty), CornerRadius) Return GetValue(CornerRadiusProperty)
End Get End Get
Set(value As CornerRadius) Set(value As CornerRadius)
SetValue(CornerRadiusProperty, value) SetValue(CornerRadiusProperty, value)
End Set End Set
End Property End Property
Private Shared Function IsCornerRadiusValid(value As Object) As Boolean Private Shared Function IsCornerRadiusValid(value As Object) As Boolean
Dim cr As CornerRadius = CType(value, CornerRadius) Dim cr As CornerRadius = value
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)) 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 End Function
Public Shared ReadOnly CornerRadiusProperty As DependencyProperty = DependencyProperty.Register("CornerRadius", GetType(CornerRadius), GetType(MyDropShadow),
New FrameworkPropertyMetadata(New CornerRadius(), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)), New ValidateValueCallback(AddressOf IsCornerRadiusValid))
' =======================================
' 渲染
' =======================================
Private Const ShadowDepth As Double = 5
Protected Overrides Sub OnRender(drawingContext As DrawingContext) Protected Overrides Sub OnRender(drawingContext As DrawingContext)
Dim cornerRadius As CornerRadius = Me.CornerRadius Dim cornerRadius As CornerRadius = Me.CornerRadius
Dim shadowBounds As New Rect(New Point(ShadowDepth, ShadowDepth), New Size(RenderSize.Width, RenderSize.Height)) Dim shadowBounds As New Rect(0, 0, RenderSize.Width, RenderSize.Height)
Dim color As Color = Me.Color Dim color As Color = Me.Color
If shadowBounds.Width > 0 AndAlso shadowBounds.Height > 0 AndAlso color.A > 0 Then If shadowBounds.Width > 0 AndAlso shadowBounds.Height > 0 AndAlso color.A > 0 Then
Dim centerWidth As Double = shadowBounds.Right - shadowBounds.Left - 2 * ShadowDepth Dim centerWidth As Double = shadowBounds.Right - shadowBounds.Left - 2 * ShadowRadius
Dim centerHeight As Double = shadowBounds.Bottom - shadowBounds.Top - 2 * ShadowDepth Dim centerHeight As Double = shadowBounds.Bottom - shadowBounds.Top - 2 * ShadowRadius
Dim maxRadius As Double = Math.Min(centerWidth * 0.5, centerHeight * 0.5) Dim maxRadius As Double = Math.Min(centerWidth * 0.5, centerHeight * 0.5)
cornerRadius.TopLeft = Math.Min(cornerRadius.TopLeft, maxRadius) cornerRadius.TopLeft = Math.Min(cornerRadius.TopLeft, maxRadius)
cornerRadius.TopRight = Math.Min(cornerRadius.TopRight, maxRadius) cornerRadius.TopRight = Math.Min(cornerRadius.TopRight, maxRadius)
cornerRadius.BottomLeft = Math.Min(cornerRadius.BottomLeft, maxRadius) cornerRadius.BottomLeft = Math.Min(cornerRadius.BottomLeft, maxRadius)
cornerRadius.BottomRight = Math.Min(cornerRadius.BottomRight, maxRadius) cornerRadius.BottomRight = Math.Min(cornerRadius.BottomRight, maxRadius)
Dim brushes As Brush() = GetBrushes(color, cornerRadius) Dim brushes As Brush() = GetBrushes(color, cornerRadius)
Dim centerTop As Double = shadowBounds.Top + ShadowDepth Dim centerTop As Double = shadowBounds.Top + ShadowRadius
Dim centerLeft As Double = shadowBounds.Left + ShadowDepth Dim centerLeft As Double = shadowBounds.Left + ShadowRadius
Dim centerRight As Double = shadowBounds.Right - ShadowDepth Dim centerRight As Double = shadowBounds.Right - ShadowRadius
Dim centerBottom As Double = shadowBounds.Bottom - ShadowDepth Dim centerBottom As Double = shadowBounds.Bottom - ShadowRadius
Dim guidelineSetX As Double() = New Double() {centerLeft, centerLeft + cornerRadius.TopLeft, centerRight - cornerRadius.TopRight, centerLeft + cornerRadius.BottomLeft, centerRight - cornerRadius.BottomRight, centerRight} 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} 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)) drawingContext.PushGuidelineSet(New GuidelineSet(guidelineSetX, guidelineSetY))
cornerRadius.TopLeft += ShadowDepth cornerRadius.TopLeft += ShadowRadius
cornerRadius.TopRight += ShadowDepth cornerRadius.TopRight += ShadowRadius
cornerRadius.BottomLeft += ShadowDepth cornerRadius.BottomLeft += ShadowRadius
cornerRadius.BottomRight += ShadowDepth cornerRadius.BottomRight += ShadowRadius
Dim topLeft As New Rect(shadowBounds.Left, shadowBounds.Top, cornerRadius.TopLeft, cornerRadius.TopLeft) Dim topLeft As New Rect(shadowBounds.Left, shadowBounds.Top, cornerRadius.TopLeft, cornerRadius.TopLeft)
drawingContext.DrawRectangle(brushes(Placement.TopLeft), Nothing, topLeft) drawingContext.DrawRectangle(brushes(Placement.TopLeft), Nothing, topLeft)
Dim topWidth As Double = guidelineSetX(2) - guidelineSetX(1) Dim topWidth As Double = guidelineSetX(2) - guidelineSetX(1)
If topWidth > 0 Then If topWidth > 0 Then
Dim top As New Rect(guidelineSetX(1), shadowBounds.Top, topWidth, ShadowDepth) Dim top As New Rect(guidelineSetX(1), shadowBounds.Top, topWidth, ShadowRadius)
drawingContext.DrawRectangle(brushes(Placement.Top), Nothing, top) drawingContext.DrawRectangle(brushes(Placement.Top), Nothing, top)
End If End If
@@ -68,14 +92,14 @@
Dim leftHeight As Double = guidelineSetY(3) - guidelineSetY(1) Dim leftHeight As Double = guidelineSetY(3) - guidelineSetY(1)
If leftHeight > 0 Then If leftHeight > 0 Then
Dim left As New Rect(shadowBounds.Left, guidelineSetY(1), ShadowDepth, leftHeight) Dim left As New Rect(shadowBounds.Left, guidelineSetY(1), ShadowRadius, leftHeight)
drawingContext.DrawRectangle(brushes(Placement.Left), Nothing, left) drawingContext.DrawRectangle(brushes(Placement.Left), Nothing, left)
End If End If
Dim rightHeight As Double = guidelineSetY(4) - guidelineSetY(2) Dim rightHeight As Double = guidelineSetY(4) - guidelineSetY(2)
If rightHeight > 0 Then If rightHeight > 0 Then
Dim right As New Rect(guidelineSetX(5), guidelineSetY(2), ShadowDepth, rightHeight) Dim right As New Rect(guidelineSetX(5), guidelineSetY(2), ShadowRadius, rightHeight)
drawingContext.DrawRectangle(brushes(Placement.Right), Nothing, right) drawingContext.DrawRectangle(brushes(Placement.Right), Nothing, right)
End If End If
@@ -84,20 +108,20 @@
Dim bottomWidth As Double = guidelineSetX(4) - guidelineSetX(3) Dim bottomWidth As Double = guidelineSetX(4) - guidelineSetX(3)
If bottomWidth > 0 Then If bottomWidth > 0 Then
Dim bottom As New Rect(guidelineSetX(3), guidelineSetY(5), bottomWidth, ShadowDepth) Dim bottom As New Rect(guidelineSetX(3), guidelineSetY(5), bottomWidth, ShadowRadius)
drawingContext.DrawRectangle(brushes(Placement.Bottom), Nothing, bottom) drawingContext.DrawRectangle(brushes(Placement.Bottom), Nothing, bottom)
End If End If
Dim bottomRight As New Rect(guidelineSetX(4), guidelineSetY(4), cornerRadius.BottomRight, cornerRadius.BottomRight) Dim bottomRight As New Rect(guidelineSetX(4), guidelineSetY(4), cornerRadius.BottomRight, cornerRadius.BottomRight)
drawingContext.DrawRectangle(brushes(Placement.BottomRight), Nothing, 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 If cornerRadius.TopLeft = ShadowRadius 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) Dim center As New Rect(guidelineSetX(0), guidelineSetY(0), centerWidth, centerHeight)
drawingContext.DrawRectangle(brushes(Placement.Center), Nothing, center) drawingContext.DrawRectangle(brushes(Placement.Center), Nothing, center)
Else Else
Dim figure As New PathFigure() Dim figure As New PathFigure()
If cornerRadius.TopLeft > ShadowDepth Then If cornerRadius.TopLeft > ShadowRadius Then
figure.StartPoint = New Point(guidelineSetX(1), guidelineSetY(0)) 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(1), guidelineSetY(1)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(1)), True)) figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(1)), True))
@@ -105,7 +129,7 @@
figure.StartPoint = New Point(guidelineSetX(0), guidelineSetY(0)) figure.StartPoint = New Point(guidelineSetX(0), guidelineSetY(0))
End If End If
If cornerRadius.BottomLeft > ShadowDepth Then If cornerRadius.BottomLeft > ShadowRadius Then
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(3)), True)) 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(3)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(5)), True)) figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(5)), True))
@@ -113,7 +137,7 @@
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(5)), True)) figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(5)), True))
End If End If
If cornerRadius.BottomRight > ShadowDepth Then If cornerRadius.BottomRight > ShadowRadius Then
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(5)), True)) 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(4), guidelineSetY(4)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(4)), True)) figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(4)), True))
@@ -121,7 +145,7 @@
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(5)), True)) figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(5)), True))
End If End If
If cornerRadius.TopRight > ShadowDepth Then If cornerRadius.TopRight > ShadowRadius Then
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(2)), True)) 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(2)), True))
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(0)), True)) figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(0)), True))
@@ -158,28 +182,27 @@
Private _brushes As Brush() Private _brushes As Brush()
Private Shared Sub ClearBrushes(o As DependencyObject, e As DependencyPropertyChangedEventArgs) Private Shared Sub ClearBrushes(o As DependencyObject, e As DependencyPropertyChangedEventArgs)
CType(o, SystemDropShadowChrome)._brushes = Nothing CType(o, MyDropShadow)._brushes = Nothing
End Sub End Sub
Private Shared Function CreateStops(c As Color, cornerRadius As Double) As GradientStopCollection Private Function CreateStops(c As Color, cornerRadius As Double) As GradientStopCollection
Dim gradientScale As Double = 1 / (cornerRadius + ShadowDepth) Dim gradientScale As Double = 1 / (ShadowRadius + cornerRadius)
Dim gsc As New GradientStopCollection From { Dim gsc As New GradientStopCollection
New GradientStop(c, (0.5 + cornerRadius) * gradientScale)
}
Dim stopColor As Color = c Dim stopColor As Color = c
gsc.Add(New GradientStop(stopColor, (ShadowRadius * 0.1 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.74336 * c.A) stopColor.A = CByte(0.74336 * c.A)
gsc.Add(New GradientStop(stopColor, (1.5 + cornerRadius) * gradientScale)) gsc.Add(New GradientStop(stopColor, (ShadowRadius * 0.3 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.38053 * c.A) stopColor.A = CByte(0.38053 * c.A)
gsc.Add(New GradientStop(stopColor, (2.5 + cornerRadius) * gradientScale)) gsc.Add(New GradientStop(stopColor, (ShadowRadius * 0.5 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.12389 * c.A) stopColor.A = CByte(0.12389 * c.A)
gsc.Add(New GradientStop(stopColor, (3.5 + cornerRadius) * gradientScale)) gsc.Add(New GradientStop(stopColor, (ShadowRadius * 0.7 + cornerRadius) * gradientScale))
stopColor.A = CByte(0.02654 * c.A) stopColor.A = CByte(0.02654 * c.A)
gsc.Add(New GradientStop(stopColor, (4.5 + cornerRadius) * gradientScale)) gsc.Add(New GradientStop(stopColor, (ShadowRadius * 0.9 + cornerRadius) * gradientScale))
stopColor.A = 0 stopColor.A = 0
gsc.Add(New GradientStop(stopColor, (5 + cornerRadius) * gradientScale)) gsc.Add(New GradientStop(stopColor, (ShadowRadius + cornerRadius) * gradientScale))
gsc.Freeze() gsc.Freeze()
Return gsc Return gsc
End Function End Function
Private Shared Function CreateBrushes(c As Color, cornerRadius As CornerRadius) As Brush() Private Function CreateBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
Dim brushes As Brush() = New Brush(8) {} Dim brushes As Brush() = New Brush(8) {}
brushes(Placement.Center) = New SolidColorBrush(c) brushes(Placement.Center) = New SolidColorBrush(c)
brushes(Placement.Center).Freeze() brushes(Placement.Center).Freeze()
@@ -297,3 +320,5 @@
End Function End Function
End Class End Class
'参考自:https://referencesource.microsoft.com/#PresentationFramework.Aero/parent/Shared/Microsoft/Windows/Themes/SystemDropShadowChrome.cs,6d9c27d92a8128c1
@@ -11,7 +11,7 @@
Return _Progress Return _Progress
End Get End Get
Set(value As Double) Set(value As Double)
If _Progress = value Then Exit Property If _Progress = value Then Return
_Progress = value _Progress = value
If value < 0.0001 Then If value < 0.0001 Then
PanProgress.Visibility = Visibility.Collapsed PanProgress.Visibility = Visibility.Collapsed
@@ -30,7 +30,7 @@
Return _Logo Return _Logo
End Get End Get
Set(value As String) Set(value As String)
If value = _Logo Then Exit Property If value = _Logo Then Return
_Logo = value _Logo = value
Path.Data = (New GeometryConverter).ConvertFromString(value) Path.Data = (New GeometryConverter).ConvertFromString(value)
End Set End Set
@@ -51,7 +51,7 @@
Return _Show Return _Show
End Get End Get
Set(value As Boolean) Set(value As Boolean)
If _Show = value Then Exit Property If _Show = value Then Return
_Show = value _Show = value
RunInUi(Sub() RunInUi(Sub()
If value Then If value Then
@@ -121,7 +121,7 @@
Focus() Focus()
End Sub End Sub
Private Sub Button_RightMouseDown(sender As Object, e As MouseButtonEventArgs) Handles PanClick.MouseRightButtonDown Private Sub Button_RightMouseDown(sender As Object, e As MouseButtonEventArgs) Handles PanClick.MouseRightButtonDown
If Not CanRightClick Then Exit Sub If Not CanRightClick Then Return
If Not IsLeftMouseHeld AndAlso Not IsRightMouseHeld Then If Not IsLeftMouseHeld AndAlso Not IsRightMouseHeld Then
AniStart({ AniStart({
AaScaleTransform(PanScale, 0.85 - CType(PanScale.RenderTransform, ScaleTransform).ScaleX, 800,, New AniEaseOutFluent(AniEasePower.Strong)), AaScaleTransform(PanScale, 0.85 - CType(PanScale.RenderTransform, ScaleTransform).ScaleX, 800,, New AniEaseOutFluent(AniEasePower.Strong)),
@@ -141,7 +141,7 @@
RefreshColor() '直接刷新颜色以判断是否已触发 MouseLeave RefreshColor() '直接刷新颜色以判断是否已触发 MouseLeave
End Sub End Sub
Private Sub Button_RightMouseUp() Handles PanClick.MouseRightButtonUp Private Sub Button_RightMouseUp() Handles PanClick.MouseRightButtonUp
If Not CanRightClick Then Exit Sub If Not CanRightClick Then Return
If Not IsLeftMouseHeld Then If Not IsLeftMouseHeld Then
AniStart({ AniStart({
AaScaleTransform(PanScale, 1 - CType(PanScale.RenderTransform, ScaleTransform).ScaleX, 300,, New AniEaseOutBack) AaScaleTransform(PanScale, 1 - CType(PanScale.RenderTransform, ScaleTransform).ScaleX, 300,, New AniEaseOutBack)
@@ -14,7 +14,7 @@ Public Class MyExtraTextButton
Return _Logo Return _Logo
End Get End Get
Set(value As String) Set(value As String)
If value = _Logo Then Exit Property If value = _Logo Then Return
_Logo = value _Logo = value
Path.Data = (New GeometryConverter).ConvertFromString(value) Path.Data = (New GeometryConverter).ConvertFromString(value)
End Set End Set
@@ -55,7 +55,7 @@ Public Class MyExtraTextButton
Return _Show Return _Show
End Get End Get
Set(value As Boolean) Set(value As Boolean)
If _Show = value Then Exit Property If _Show = value Then Return
_Show = value _Show = value
RunInUi( RunInUi(
Sub() Sub()
+4 -12
View File
@@ -3,22 +3,14 @@
xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
xmlns:local="clr-namespace:PCL" xmlns:local="clr-namespace:PCL"
FocusVisualStyle="{x:Null}" FocusVisualStyle="{x:Null}"
UseLayoutRounding="True" SnapsToDevicePixels="True" HorizontalAlignment="Stretch" BorderThickness="1" BorderBrush="#99FF4444" CornerRadius="3"> UseLayoutRounding="True" SnapsToDevicePixels="True" HorizontalAlignment="Stretch" BorderThickness="3,0,0,0" BorderBrush="#99FF4444" CornerRadius="2">
<Border.Background>
<LinearGradientBrush EndPoint="1,0.5" StartPoint="0,0.5">
<GradientStop x:Name="Gradient1" Color="#88FFBBBB" Offset="0.3"/>
<GradientStop x:Name="Gradient2" Color="#88FF8888" Offset="0.9"/>
</LinearGradientBrush>
</Border.Background>
<Grid UseLayoutRounding="False" SnapsToDevicePixels="False"> <Grid UseLayoutRounding="False" SnapsToDevicePixels="False">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" /> <ColumnDefinition Width="1*" />
<ColumnDefinition Width="Auto" /> <ColumnDefinition Width="Auto" />
</Grid.ColumnDefinitions> </Grid.ColumnDefinitions>
<Path IsHitTestVisible="False" Grid.Column="0" x:Name="Path" VerticalAlignment="Center" Fill="#BF0000" Width="14" Stretch="Uniform" Margin="10,0,2,0" Data="F1 M 58.5832,55.4172L 17.4169,55.4171C 15.5619,53.5621 15.5619,50.5546 17.4168,48.6996L 35.201,15.8402C 37.056,13.9852 40.0635,13.9852 41.9185,15.8402L 58.5832,48.6997C 60.4382,50.5546 60.4382,53.5622 58.5832,55.4172 Z M 34.0417,25.7292L 36.0208,41.9584L 39.9791,41.9583L 41.9583,25.7292L 34.0417,25.7292 Z M 38,44.3333C 36.2511,44.3333 34.8333,45.7511 34.8333,47.5C 34.8333,49.2489 36.2511,50.6667 38,50.6667C 39.7489,50.6667 41.1666,49.2489 41.1666,47.5C 41.1666,45.7511 39.7489,44.3333 38,44.3333 Z " /> <TextBlock IsHitTestVisible="False" x:Name="LabText" LineHeight="16" Margin="0,0,0,-1" Padding="12,9" VerticalAlignment="Center" TextWrapping="Wrap" />
<TextBlock IsHitTestVisible="False" Grid.Column="1" x:Name="LabText" Margin="0,0.5,0,0" Padding="6,6,8,6" VerticalAlignment="Center" Foreground="#BF0000" TextWrapping="Wrap" /> <local:MyIconButton x:Name="BtnClose" Visibility="Collapsed" Theme="Custom" Margin="0,0,8,0" Grid.Column="1" Height="20" Width="20" VerticalAlignment="Center" Logo="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z"
<local:MyIconButton x:Name="BtnClose" SnapsToDevicePixels="True" Visibility="Collapsed" Foreground="#BF0000" Theme="Custom" Margin="0,0,6,0" Grid.Column="2" Height="20" Width="20" VerticalAlignment="Center" Logo="F1 M 26.9166,22.1667L 37.9999,33.25L 49.0832,22.1668L 53.8332,26.9168L 42.7499,38L 53.8332,49.0834L 49.0833,53.8334L 37.9999,42.75L 26.9166,53.8334L 22.1666,49.0833L 33.25,38L 22.1667,26.9167L 26.9166,22.1667 Z" ToolTip="不再提示" ToolTipService.Placement="Center" ToolTipService.VerticalOffset="29" ToolTipService.HorizontalOffset="2" />
ToolTip="不再显示" ToolTipService.Placement="Center" ToolTipService.VerticalOffset="29" ToolTipService.HorizontalOffset="2" />
</Grid> </Grid>
</Border> </Border>
+73 -38
View File
@@ -2,37 +2,73 @@
<ContentProperty("Inlines")> <ContentProperty("Inlines")>
Public Class MyHint Public Class MyHint
Public Uuid As Integer = GetUuid() Public Uuid As Integer = GetUuid()
Private _IsWarn As Boolean = True '边框
Public Property IsWarn As Boolean Public Property HasBorder As Boolean
Get Get
Return _IsWarn Return BorderThickness.Top > 0
End Get End Get
Set(value As Boolean) Set(value As Boolean)
If _IsWarn = value Then Exit Property If value Then
_IsWarn = value BorderThickness = New Thickness(3, GetWPFSize(1), GetWPFSize(1), GetWPFSize(1))
If _IsWarn Then
BorderBrush = New MyColor("#CCFF4444")
Gradient1.Color = New MyColor("#BBFFBBBB")
Gradient2.Color = New MyColor("#BBFF8888")
Path.Fill = New MyColor("#BF0000")
LabText.Foreground = New MyColor("#BF0000")
BtnClose.Foreground = New MyColor("#BF0000")
Path.Data = (New GeometryConverter).ConvertFromString("F1 M 58.5832,55.4172L 17.4169,55.4171C 15.5619,53.5621 15.5619,50.5546 17.4168,48.6996L 35.201,15.8402C 37.056,13.9852 40.0635,13.9852 41.9185,15.8402L 58.5832,48.6997C 60.4382,50.5546 60.4382,53.5622 58.5832,55.4172 Z M 34.0417,25.7292L 36.0208,41.9584L 39.9791,41.9583L 41.9583,25.7292L 34.0417,25.7292 Z M 38,44.3333C 36.2511,44.3333 34.8333,45.7511 34.8333,47.5C 34.8333,49.2489 36.2511,50.6667 38,50.6667C 39.7489,50.6667 41.1666,49.2489 41.1666,47.5C 41.1666,45.7511 39.7489,44.3333 38,44.3333 Z ")
Else Else
BorderBrush = New MyColor("#CC4D76FF") BorderThickness = New Thickness(3, 0, 0, 0)
Gradient1.Color = New MyColor("#BBB0D0FF")
Gradient2.Color = New MyColor("#BB9EBAFF")
Path.Fill = New MyColor("#0062BF")
LabText.Foreground = New MyColor("#0062BF")
BtnClose.Foreground = New MyColor("#0062BF")
Path.Data = (New GeometryConverter).ConvertFromString("F1M38,19C48.4934,19 57,27.5066 57,38 57,48.4934 48.4934,57 38,57 27.5066,57 19,48.4934 19,38 19,27.5066 27.5066,19 38,19z M33.25,33.25L33.25,36.4167 36.4166,36.4167 36.4166,47.5 33.25,47.5 33.25,50.6667 44.3333,50.6667 44.3333,47.5 41.1666,47.5 41.1666,36.4167 41.1666,33.25 33.25,33.25z M38.7917,25.3333C37.48,25.3333 36.4167,26.3967 36.4167,27.7083 36.4167,29.02 37.48,30.0833 38.7917,30.0833 40.1033,30.0833 41.1667,29.02 41.1667,27.7083 41.1667,26.3967 40.1033,25.3333 38.7917,25.3333z")
End If End If
End Set End Set
End Property End Property
'配色
Public Enum Themes
Blue = 0
Red = 1
Yellow = 2
End Enum
Public Property Theme As Themes
Get
Return _ColorType
End Get
Set(value As Themes)
_ColorType = value
UpdateUI()
End Set
End Property
Private _ColorType As Themes = Themes.Red
Private Sub UpdateUI() Handles Me.Loaded
Select Case Theme
Case Themes.Blue
Background = New MyColor("#d9ecff")
BorderBrush = New MyColor("#1172D4")
LabText.Foreground = New MyColor("#0F64B8")
BtnClose.Foreground = New MyColor("#0F64B8")
Case Themes.Red
Background = New MyColor("#ffdddf")
BorderBrush = New MyColor("#d82929")
LabText.Foreground = New MyColor("#bf0b0b")
BtnClose.Foreground = New MyColor("#bf0b0b")
Case Themes.Yellow
Background = New MyColor("#ffebd7")
BorderBrush = New MyColor("#f57a00")
LabText.Foreground = New MyColor("#d86c00")
BtnClose.Foreground = New MyColor("#d86c00")
End Select
End Sub
<Obsolete("IsWarn 已过时。请换用 Theme 属性。")>
Public Property IsWarn As Boolean
Get
Return Theme = Themes.Red
End Get
Set(value As Boolean)
Theme = If(value, Themes.Red, Themes.Blue)
End Set
End Property
Public Shared ReadOnly IsWarnProperty As DependencyProperty =
DependencyProperty.Register("IsWarn", GetType(Boolean), GetType(MyHint), New PropertyMetadata(True,
Sub(d As MyHint, e As DependencyPropertyChangedEventArgs)
d.Theme = If(e.NewValue, Themes.Red, Themes.Blue)
End Sub))
'文本
Public ReadOnly Property Inlines As InlineCollection Public ReadOnly Property Inlines As InlineCollection
Get Get
Return LabText.Inlines Return LabText.Inlines
@@ -52,6 +88,7 @@ Public Class MyHint
d.LabText.Text = e.NewValue d.LabText.Text = e.NewValue
End Sub)) End Sub))
'关闭按钮
Public Property CanClose As Boolean Public Property CanClose As Boolean
Get Get
Return BtnClose.Visibility = Visibility.Visible Return BtnClose.Visibility = Visibility.Visible
@@ -60,12 +97,9 @@ Public Class MyHint
BtnClose.Visibility = If(value, Visibility.Visible, Visibility.Collapsed) BtnClose.Visibility = If(value, Visibility.Visible, Visibility.Collapsed)
End Set End Set
End Property End Property
Public Property RelativeSetup As String = "" Public Property RelativeSetup As String = ""
Private Sub MyHint_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded Private Sub MyHint_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded
If CanClose AndAlso Setup.Get(RelativeSetup) Then If CanClose AndAlso Setup.Get(RelativeSetup) Then Visibility = Visibility.Collapsed
Visibility = Visibility.Collapsed
End If
End Sub End Sub
Private Sub BtnClose_Click(sender As Object, e As EventArgs) Handles BtnClose.Click Private Sub BtnClose_Click(sender As Object, e As EventArgs) Handles BtnClose.Click
Setup.Set(RelativeSetup, True) Setup.Set(RelativeSetup, True)
@@ -109,20 +143,21 @@ Public Class MyHint
End Class End Class
Partial Public Module ModAnimation Partial Public Module ModAnimation
Public Sub AniDispose(Control As MyHint, RemoveFromChildren As Boolean, Optional CallBack As ParameterizedThreadStart = Nothing) Public Sub AniDispose(Control As MyHint, RemoveFromChildren As Boolean, Optional CallBack As ParameterizedThreadStart = Nothing)
If Not Control.IsHitTestVisible Then Exit Sub If Not Control.IsHitTestVisible Then Return
Control.IsHitTestVisible = False Control.IsHitTestVisible = False
AniStart({ AniStart({
AaScaleTransform(Control, -0.08, 200,, New AniEaseInFluent), AaScaleTransform(Control, -0.08, 200,, New AniEaseInFluent),
AaOpacity(Control, -1, 200,, New AniEaseOutFluent), AaOpacity(Control, -1, 200,, New AniEaseOutFluent),
AaHeight(Control, -Control.ActualHeight, 150, 100, New AniEaseOutFluent), AaHeight(Control, -Control.ActualHeight, 150, 100, New AniEaseOutFluent),
AaCode(Sub() AaCode(
If RemoveFromChildren Then Sub()
CType(Control.Parent, Object).Children.Remove(Control) If RemoveFromChildren Then
Else CType(Control.Parent, Object).Children.Remove(Control)
Control.Visibility = Visibility.Collapsed Else
End If Control.Visibility = Visibility.Collapsed
If CallBack IsNot Nothing Then CallBack(Control) End If
End Sub,, True) If CallBack IsNot Nothing Then CallBack(Control)
}, "MyCard Dispose " & Control.Uuid) End Sub,, True)
}, "MyCard Dispose " & Control.Uuid)
End Sub End Sub
End Module End Module
@@ -186,7 +186,7 @@
End Class End Class
Partial Public Module ModAnimation Partial Public Module ModAnimation
Public Sub AniDispose(Control As MyIconButton, RemoveFromChildren As Boolean, Optional CallBack As ParameterizedThreadStart = Nothing) Public Sub AniDispose(Control As MyIconButton, RemoveFromChildren As Boolean, Optional CallBack As ParameterizedThreadStart = Nothing)
If Not Control.IsHitTestVisible Then Exit Sub If Not Control.IsHitTestVisible Then Return
Control.IsHitTestVisible = False Control.IsHitTestVisible = False
AniStart({ AniStart({
AaScaleTransform(Control, -1.5, 200,, New AniEaseInFluent), AaScaleTransform(Control, -1.5, 200,, New AniEaseInFluent),
@@ -72,7 +72,7 @@ Public Class MyIconTextButton
Public Event Click(sender As Object, e As RouteEventArgs) Public Event Click(sender As Object, e As RouteEventArgs)
Private IsMouseDown As Boolean = False Private IsMouseDown As Boolean = False
Private Sub MyIconTextButton_MouseUp() Handles Me.MouseLeftButtonUp Private Sub MyIconTextButton_MouseUp() Handles Me.MouseLeftButtonUp
If Not IsMouseDown Then Exit Sub If Not IsMouseDown Then Return
Log("[Control] 按下带图标按钮:" & Text) Log("[Control] 按下带图标按钮:" & Text)
IsMouseDown = False IsMouseDown = False
RaiseEvent Click(Me, New RouteEventArgs(True)) RaiseEvent Click(Me, New RouteEventArgs(True))
+9 -9
View File
@@ -34,9 +34,9 @@
End Get End Get
Set(value As String) Set(value As String)
If value = "" Then value = Nothing If value = "" Then value = Nothing
If _Source = value Then Exit Property If _Source = value Then Return
_Source = value _Source = value
If Not IsInitialized Then Exit Property '属性读取顺序修正:在完成 XAML 属性读取后再触发图片加载(#4868) If Not IsInitialized Then Return '属性读取顺序修正:在完成 XAML 属性读取后再触发图片加载(#4868)
Load() Load()
End Set End Set
End Property End Property
@@ -82,7 +82,7 @@
End Get End Get
Set(value As String) Set(value As String)
If value = "" Then value = Nothing If value = "" Then value = Nothing
If _ActualSource = value Then Exit Property If _ActualSource = value Then Return
_ActualSource = value _ActualSource = value
Try Try
Dim Bitmap As MyBitmap = If(value Is Nothing, Nothing, New MyBitmap(value)) '在这里先触发可能的文件读取,尽量避免在 UI 线程中读取文件 Dim Bitmap As MyBitmap = If(value Is Nothing, Nothing, New MyBitmap(value)) '在这里先触发可能的文件读取,尽量避免在 UI 线程中读取文件
@@ -103,12 +103,12 @@
'空 '空
If Source Is Nothing Then If Source Is Nothing Then
ActualSource = Nothing ActualSource = Nothing
Exit Sub Return
End If End If
'本地图片 '本地图片
If Not Source.StartsWithF("http") Then If Not Source.StartsWithF("http") Then
ActualSource = Source ActualSource = Source
Exit Sub Return
End If End If
'从缓存加载网络图片 '从缓存加载网络图片
Dim Url As String = Source Dim Url As String = Source
@@ -118,7 +118,7 @@
Dim EnableCache As Boolean = Me.EnableCache Dim EnableCache As Boolean = Me.EnableCache
If EnableCache AndAlso TempFile.Exists Then If EnableCache AndAlso TempFile.Exists Then
ActualSource = TempPath ActualSource = TempPath
If (Date.Now - TempFile.LastWriteTime) < FileCacheExpiredTime Then Exit Sub '无需刷新缓存 If (Date.Now - TempFile.LastWriteTime) < FileCacheExpiredTime Then Return '无需刷新缓存
End If End If
RunInNewThread( RunInNewThread(
Sub() Sub()
@@ -159,19 +159,19 @@ RetryStart:
'空 '空
If Url Is Nothing Then If Url Is Nothing Then
ActualSource = Nothing ActualSource = Nothing
Exit Sub Return
End If End If
'本地图片 '本地图片
If Not Url.StartsWithF("http") Then If Not Url.StartsWithF("http") Then
ActualSource = Url ActualSource = Url
Exit Sub Return
End If End If
'从缓存加载网络图片 '从缓存加载网络图片
TempPath = GetTempPath(Url) TempPath = GetTempPath(Url)
TempFile = New FileInfo(TempPath) TempFile = New FileInfo(TempPath)
If EnableCache AndAlso TempFile.Exists() Then If EnableCache AndAlso TempFile.Exists() Then
ActualSource = TempPath ActualSource = TempPath
If (Date.Now - TempFile.CreationTime) < FileCacheExpiredTime Then Exit Sub '无需刷新缓存 If (Date.Now - TempFile.CreationTime) < FileCacheExpiredTime Then Return '无需刷新缓存
End If End If
'下载 '下载
If Source = Url Then Thread.Sleep(1000) '延迟 1s 重试 If Source = Url Then Thread.Sleep(1000) '延迟 1s 重试
@@ -197,7 +197,7 @@ Public Class MyListItem
Return _Info Return _Info
End Get End Get
Set(value As String) Set(value As String)
If _Info = value Then Exit Property If _Info = value Then Return
value = value.Replace(vbCr, "").Replace(vbLf, "") value = value.Replace(vbCr, "").Replace(vbLf, "")
_Info = value _Info = value
LabInfo.Text = value LabInfo.Text = value
@@ -212,7 +212,7 @@ Public Class MyListItem
Return _Logo Return _Logo
End Get End Get
Set(value As String) Set(value As String)
If _Logo = value Then Exit Property If _Logo = value Then Return
_Logo = value _Logo = value
'删除旧 Logo '删除旧 Logo
If Not IsNothing(PathLogo) Then Children.Remove(PathLogo) If Not IsNothing(PathLogo) Then Children.Remove(PathLogo)
@@ -297,7 +297,7 @@ Public Class MyListItem
Return _Type Return _Type
End Get End Get
Set(value As CheckType) Set(value As CheckType)
If _Type = value Then Exit Property If _Type = value Then Return
_Type = value _Type = value
'切换左栏大小 '切换左栏大小
ColumnCheck.Width = New GridLength(If(_Type = CheckType.None OrElse _Type = CheckType.Clickable, If(Height < 40, 4, 2), 6)) ColumnCheck.Width = New GridLength(If(_Type = CheckType.None OrElse _Type = CheckType.Clickable, If(Height < 40, 4, 2), 6))
@@ -367,31 +367,31 @@ Public Class MyListItem
RaiseEvent Changed(Me, ChangedEventArgs) RaiseEvent Changed(Me, ChangedEventArgs)
If ChangedEventArgs.Handled Then If ChangedEventArgs.Handled Then
_Checked = RawValue _Checked = RawValue
Exit Sub Return
End If End If
End If End If
_Checked = value _Checked = value
Else Else
If value = _Checked Then Exit Sub If value = _Checked Then Return
_Checked = value _Checked = value
If IsInitialized Then If IsInitialized Then
RaiseEvent Changed(Me, ChangedEventArgs) RaiseEvent Changed(Me, ChangedEventArgs)
If ChangedEventArgs.Handled Then If ChangedEventArgs.Handled Then
_Checked = RawValue _Checked = RawValue
Exit Sub Return
End If End If
End If End If
End If End If
If value Then If value Then
Dim CheckEventArgs As New RouteEventArgs(user) Dim CheckEventArgs As New RouteEventArgs(user)
RaiseEvent Check(Me, CheckEventArgs) RaiseEvent Check(Me, CheckEventArgs)
If CheckEventArgs.Handled Then Exit Sub If CheckEventArgs.Handled Then Return
End If End If
'保证只有一个单选 ListItem 选中 '保证只有一个单选 ListItem 选中
If Type = CheckType.RadioBox Then If Type = CheckType.RadioBox Then
If IsNothing(Parent) Then Exit Sub If IsNothing(Parent) Then Return
Dim RadioboxList As New List(Of MyListItem) Dim RadioboxList As New List(Of MyListItem)
Dim CheckedCount As Integer = 0 Dim CheckedCount As Integer = 0
'收集控件列表与选中个数 '收集控件列表与选中个数
@@ -502,15 +502,15 @@ Public Class MyListItem
'触发点击事件 '触发点击事件
Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp
If Not IsMouseDown Then Exit Sub If Not IsMouseDown Then Return
RaiseEvent Click(sender, e) RaiseEvent Click(sender, e)
If e.Handled Then Exit Sub If e.Handled Then Return
'触发自定义事件 '触发自定义事件
If Not String.IsNullOrEmpty(EventType) Then If Not String.IsNullOrEmpty(EventType) Then
ModEvent.TryStartEvent(EventType, EventData) ModEvent.TryStartEvent(EventType, EventData)
e.Handled = True e.Handled = True
End If End If
If e.Handled Then Exit Sub If e.Handled Then Return
'实际的单击处理 '实际的单击处理
Select Case Type Select Case Type
Case CheckType.Clickable Case CheckType.Clickable
@@ -581,7 +581,7 @@ Public Class MyListItem
Time = 180 Time = 180
End If End If
End If End If
If StateLast = StateNew Then Exit Sub If StateLast = StateNew Then Return
StateLast = StateNew StateLast = StateNew
'触发颜色动画 '触发颜色动画
If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画
@@ -35,7 +35,7 @@ Public Class MyLoading
Return _ShowProgress Return _ShowProgress
End Get End Get
Set(value As Boolean) Set(value As Boolean)
If _ShowProgress = value Then Exit Property If _ShowProgress = value Then Return
_ShowProgress = value _ShowProgress = value
RefreshText() RefreshText()
End Set End Set
@@ -82,7 +82,7 @@ Public Class MyLoading
LabText.Text = StrTrim(Ex.Message) LabText.Text = StrTrim(Ex.Message)
If {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝", If {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝",
"操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) LabText.Text.Contains(s)) Then "操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) LabText.Text.Contains(s)) Then
LabText.Text = "网络环境不佳,请重试或尝试使用 VPN" LabText.Text = "网络环境不佳,请稍后重试,或使用 VPN 以改善网络环境"
End If End If
End If End If
Else Else
@@ -142,7 +142,7 @@ Public Class MyLoading
Return _OuterState Return _OuterState
End Get End Get
Set(value As MyLoadingState) Set(value As MyLoadingState)
If _OuterState = value Then Exit Property If _OuterState = value Then Return
Dim OldValue = _OuterState Dim OldValue = _OuterState
_OuterState = value _OuterState = value
'引发事件 '引发事件
@@ -159,7 +159,7 @@ Public Class MyLoading
Return _InnerState Return _InnerState
End Get End Get
Set(value As MyLoadingState) Set(value As MyLoadingState)
If _InnerState = value Then Exit Property If _InnerState = value Then Return
Dim OldValue = _InnerState Dim OldValue = _InnerState
_InnerState = value _InnerState = value
'引发事件 '引发事件
@@ -183,7 +183,7 @@ Public Class MyLoading
Private IsLooping As Boolean = False Private IsLooping As Boolean = False
Private Sub AniLoop() Private Sub AniLoop()
'这坨循环代码也是老屎坑了,救救.jpg '这坨循环代码也是老屎坑了,救救.jpg
If Not HasAnimation OrElse IsLooping OrElse Not InnerState = MyLoadingState.Run OrElse AniSpeed > 10 OrElse Not IsLoaded Then Exit Sub If Not HasAnimation OrElse IsLooping OrElse Not InnerState = MyLoadingState.Run OrElse AniSpeed > 10 OrElse Not IsLoaded Then Return
IsLooping = True IsLooping = True
ErrorAnimationWaiting = True ErrorAnimationWaiting = True
AniStart({ AniStart({
@@ -271,7 +271,7 @@ Public Class MyLoadingStateSimulator
Return _LoadingState Return _LoadingState
End Get End Get
Set(value As MyLoadingState) Set(value As MyLoadingState)
If _LoadingState = value Then Exit Property If _LoadingState = value Then Return
Dim OldState = _LoadingState Dim OldState = _LoadingState
_LoadingState = value _LoadingState = value
RaiseEvent LoadingStateChanged(value, OldState) RaiseEvent LoadingStateChanged(value, OldState)
@@ -37,7 +37,7 @@
Time = AnimationTimeOut Time = AnimationTimeOut
End If End If
'重复性验证 '重复性验证
If ColorName = BackName Then Exit Sub If ColorName = BackName Then Return
ColorName = BackName ColorName = BackName
'触发颜色动画 '触发颜色动画
If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画
@@ -73,13 +73,13 @@
Public Sub Btn1_Click() Handles Btn1.Click Public Sub Btn1_Click() Handles Btn1.Click
TextArea.Validate() '#5773 TextArea.Validate() '#5773
If MyConverter.IsExited OrElse Not TextArea.IsValidated Then Exit Sub If MyConverter.IsExited OrElse Not TextArea.IsValidated Then Return
MyConverter.IsExited = True MyConverter.IsExited = True
MyConverter.Result = TextArea.Text MyConverter.Result = TextArea.Text
Close() Close()
End Sub End Sub
Public Sub Btn2_Click() Handles Btn2.Click Public Sub Btn2_Click() Handles Btn2.Click
If MyConverter.IsExited Then Exit Sub If MyConverter.IsExited Then Return
MyConverter.IsExited = True MyConverter.IsExited = True
MyConverter.Result = Nothing MyConverter.Result = Nothing
Close() Close()
@@ -77,13 +77,13 @@
End Sub End Sub
Public Sub Btn1_Click() Handles Btn1.Click Public Sub Btn1_Click() Handles Btn1.Click
If MyConverter.IsExited OrElse SelectedIndex = -1 Then Exit Sub If MyConverter.IsExited OrElse SelectedIndex = -1 Then Return
MyConverter.IsExited = True MyConverter.IsExited = True
MyConverter.Result = SelectedIndex MyConverter.Result = SelectedIndex
Close() Close()
End Sub End Sub
Public Sub Btn2_Click() Handles Btn2.Click Public Sub Btn2_Click() Handles Btn2.Click
If MyConverter.IsExited Then Exit Sub If MyConverter.IsExited Then Return
MyConverter.IsExited = True MyConverter.IsExited = True
MyConverter.Result = Nothing MyConverter.Result = Nothing
Close() Close()
@@ -70,7 +70,7 @@
End Sub End Sub
Public Sub Btn1_Click() Handles Btn1.Click Public Sub Btn1_Click() Handles Btn1.Click
If MyConverter.IsExited Then Exit Sub If MyConverter.IsExited Then Return
If MyConverter.Button1Action IsNot Nothing Then If MyConverter.Button1Action IsNot Nothing Then
MyConverter.Button1Action() MyConverter.Button1Action()
Else Else
@@ -80,7 +80,7 @@
End If End If
End Sub End Sub
Public Sub Btn2_Click() Handles Btn2.Click Public Sub Btn2_Click() Handles Btn2.Click
If MyConverter.IsExited Then Exit Sub If MyConverter.IsExited Then Return
If MyConverter.Button2Action IsNot Nothing Then If MyConverter.Button2Action IsNot Nothing Then
MyConverter.Button2Action() MyConverter.Button2Action()
Else Else
@@ -90,7 +90,7 @@
End If End If
End Sub End Sub
Public Sub Btn3_Click() Handles Btn3.Click Public Sub Btn3_Click() Handles Btn3.Click
If MyConverter.IsExited Then Exit Sub If MyConverter.IsExited Then Return
If MyConverter.Button3Action IsNot Nothing Then If MyConverter.Button3Action IsNot Nothing Then
MyConverter.Button3Action() MyConverter.Button3Action()
Else Else
+12 -11
View File
@@ -39,16 +39,17 @@
Element.Opacity = 0 Element.Opacity = 0
Element.RenderTransform = New TranslateTransform(-25, 0) Element.RenderTransform = New TranslateTransform(-25, 0)
If TypeOf Element Is MyListItem Then CType(Element, MyListItem).IsMouseOverAnimationEnabled = False If TypeOf Element Is MyListItem Then CType(Element, MyListItem).IsMouseOverAnimationEnabled = False
AniList.Add(AaOpacity(Element, If(TypeOf Element Is TextBlock, 0.6, 1), 200, Delay, New AniEaseOutFluent(AniEasePower.Weak))) AniList.Add(AaOpacity(Element, If(TypeOf Element Is TextBlock, 0.6, 1), 100, Delay, New AniEaseOutFluent(AniEasePower.Weak)))
AniList.Add(AaTranslateX(Element, 5, 200, Delay, New AniEaseOutFluent)) AniList.Add(AaTranslateX(Element, 5, 200, Delay, New AniEaseOutFluent))
AniList.Add(AaTranslateX(Element, 20, 300, Delay, New AniEaseOutBack(AniEasePower.Weak))) AniList.Add(AaTranslateX(Element, 20, 300, Delay, New AniEaseOutBack(AniEasePower.Weak)))
If TypeOf Element Is MyListItem Then If TypeOf Element Is MyListItem Then
AniList.Add(AaCode(Sub() AniList.Add(AaCode(
CType(Element, MyListItem).IsMouseOverAnimationEnabled = True Sub()
CType(Element, MyListItem).RefreshColor(Me, New EventArgs) CType(Element, MyListItem).IsMouseOverAnimationEnabled = True
End Sub, Delay + 280)) CType(Element, MyListItem).RefreshColor(Me, New EventArgs)
End Sub, Delay + 280))
End If End If
Delay += Math.Max(8, 20 - Id) * 2.5 Delay += Math.Max(15 - Id, 7) * 2
Id += 1 Id += 1
End If End If
Next Next
@@ -63,8 +64,8 @@
RenderTransformOrigin = New Point(0.5, 0.5) RenderTransformOrigin = New Point(0.5, 0.5)
End If End If
AniStart({ AniStart({
AaScaleTransform(Me, 0.95 - CType(RenderTransform, ScaleTransform).ScaleX, 130,, New AniEaseInFluent(AniEasePower.Weak)), AaScaleTransform(Me, 0.95 - CType(RenderTransform, ScaleTransform).ScaleX, 110,, New AniEaseInFluent(AniEasePower.Weak)),
AaOpacity(Me, -Opacity, 100, 30) AaOpacity(Me, -Opacity, 80, 30)
}, "PageLeft PageChange " & Uuid) }, "PageLeft PageChange " & Uuid)
Else Else
'逐个退出动画 '逐个退出动画
@@ -72,8 +73,8 @@
Dim Id As Integer = 0 Dim Id As Integer = 0
Dim Controls = GetAllAnimControls() Dim Controls = GetAllAnimControls()
For Each Element As FrameworkElement In Controls For Each Element As FrameworkElement In Controls
AniList.Add(AaOpacity(Element, -Element.Opacity, 60, 80 / Controls.Count * Id)) AniList.Add(AaOpacity(Element, -Element.Opacity, 50, 70 / Controls.Count * Id))
AniList.Add(AaTranslateX(Element, -6, 60, 80 / Controls.Count * Id)) AniList.Add(AaTranslateX(Element, -6, 50, 70 / Controls.Count * Id))
Id += 1 Id += 1
Next Next
AniStart(AniList, "PageLeft PageChange " & Uuid) AniStart(AniList, "PageLeft PageChange " & Uuid)
@@ -87,7 +88,7 @@
Return AllControls Return AllControls
End Function End Function
Private Sub GetAllAnimControls(Element As FrameworkElement, ByRef AllControls As List(Of FrameworkElement), IgnoreInvisibility As Boolean) Private Sub GetAllAnimControls(Element As FrameworkElement, ByRef AllControls As List(Of FrameworkElement), IgnoreInvisibility As Boolean)
If Not IgnoreInvisibility AndAlso Element.Visibility = Visibility.Collapsed Then Exit Sub If Not IgnoreInvisibility AndAlso Element.Visibility = Visibility.Collapsed Then Return
If TypeOf Element Is MyTextButton Then If TypeOf Element Is MyTextButton Then
AllControls.Add(Element) AllControls.Add(Element)
ElseIf TypeOf Element Is MyListItem Then ElseIf TypeOf Element Is MyListItem Then
+11 -11
View File
@@ -33,7 +33,7 @@
Return _PageState Return _PageState
End Get End Get
Set(value As PageStates) Set(value As PageStates)
If _PageState = value Then Exit Property If _PageState = value Then Return
_PageState = value _PageState = value
If ModeDebug Then Log("[UI] 页面状态切换为 " & GetStringFromEnum(value)) If ModeDebug Then Log("[UI] 页面状态切换为 " & GetStringFromEnum(value))
End Set End Set
@@ -106,7 +106,7 @@
End Sub End Sub
'重试 '重试
Public Sub PageLoaderRestart(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = True) '由外部调用的重试 Public Sub PageLoaderRestart(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = True) '由外部调用的重试
If Not PageLoaderAutoRun Then Exit Sub If Not PageLoaderAutoRun Then Return
If PageLoader.GetType.Name.StartsWithF("LoaderTask") Then If PageLoader.GetType.Name.StartsWithF("LoaderTask") Then
PageLoader.Start(CType(PageLoader, Object).StartGetInput(Input, PageLoaderInputInvoke), IsForceRestart:=IsForceRestart) PageLoader.Start(CType(PageLoader, Object).StartGetInput(Input, PageLoaderInputInvoke), IsForceRestart:=IsForceRestart)
Else Else
@@ -187,7 +187,7 @@
''' 需要立即切换至 Empty。 ''' 需要立即切换至 Empty。
''' </summary> ''' </summary>
Public Sub PageOnForceExit() Public Sub PageOnForceExit()
If PageState = PageStates.Empty Then Exit Sub If PageState = PageStates.Empty Then Return
If ModeDebug Then Log("[UI] 已触发 PageOnForceExit") If ModeDebug Then Log("[UI] 已触发 PageOnForceExit")
PageState = PageStates.Empty PageState = PageStates.Empty
AniStop("PageRight PageChange " & PageUuid) AniStop("PageRight PageChange " & PageUuid)
@@ -302,7 +302,7 @@
Private Sub PageLoaderState(sender As Object, NewState As LoadState, OldState As LoadState) Private Sub PageLoaderState(sender As Object, NewState As LoadState, OldState As LoadState)
Select Case NewState Select Case NewState
Case LoadState.Failed, LoadState.Loading Case LoadState.Failed, LoadState.Loading
If OldState = LoadState.Failed OrElse OldState = LoadState.Loading Then Exit Sub If OldState = LoadState.Failed OrElse OldState = LoadState.Loading Then Return
If ModeDebug Then Log("[UI] 已触发 PageLoaderState (Start/Refresh)") If ModeDebug Then Log("[UI] 已触发 PageLoaderState (Start/Refresh)")
'(重新)开始运行 '(重新)开始运行
'需要从部分状态切换到 ReloadExit '需要从部分状态切换到 ReloadExit
@@ -314,7 +314,7 @@
PageState = PageStates.ContentExit PageState = PageStates.ContentExit
End Select End Select
Case LoadState.Finished, LoadState.Aborted, LoadState.Waiting Case LoadState.Finished, LoadState.Aborted, LoadState.Waiting
If Not (OldState = LoadState.Failed OrElse OldState = LoadState.Loading) Then Exit Sub If Not (OldState = LoadState.Failed OrElse OldState = LoadState.Loading) Then Return
If ModeDebug Then Log("[UI] 已触发 PageLoaderState (Stop/Abort)") If ModeDebug Then Log("[UI] 已触发 PageLoaderState (Stop/Abort)")
'运行结束 '运行结束
'需要从 LoaderWait 切换到 ContentEnter,或从 LoaderStay 切换到 LoaderExit '需要从 LoaderWait 切换到 ContentEnter,或从 LoaderStay 切换到 LoaderExit
@@ -358,10 +358,10 @@
Else Else
Control.Opacity = 0 Control.Opacity = 0
Control.RenderTransform = New TranslateTransform(0, -16) Control.RenderTransform = New TranslateTransform(0, -16)
AniList.Add(AaOpacity(Control, 1, 150, Delay, New AniEaseOutFluent(AniEasePower.Weak))) AniList.Add(AaOpacity(Control, 1, 100, Delay, New AniEaseOutFluent(AniEasePower.Weak)))
AniList.Add(AaTranslateY(Control, 5, 250, Delay, New AniEaseOutFluent)) AniList.Add(AaTranslateY(Control, 5, 250, Delay, New AniEaseOutFluent))
AniList.Add(AaTranslateY(Control, 11, 350, Delay, New AniEaseOutBack)) AniList.Add(AaTranslateY(Control, 11, 350, Delay, New AniEaseOutBack))
Delay += 40 Delay += 25
End If End If
Next Next
Next Next
@@ -387,9 +387,9 @@
CType(Control, MyExtraTextButton).Show = False CType(Control, MyExtraTextButton).Show = False
Else Else
Control.IsHitTestVisible = False Control.IsHitTestVisible = False
AniList.Add(AaOpacity(Control, -1, 90, Delay)) AniList.Add(AaOpacity(Control, -1, 70, Delay))
AniList.Add(AaTranslateY(Control, -6, 90, Delay)) AniList.Add(AaTranslateY(Control, -6, 70, Delay))
Delay += 20 Delay += 15
End If End If
Next Next
Next Next
@@ -423,7 +423,7 @@
Return AllControls.Except(DisabledPageAnimControls) Return AllControls.Except(DisabledPageAnimControls)
End Function End Function
Private Sub _GetAllAnimControls(Element As FrameworkElement, ByRef AllControls As List(Of FrameworkElement), IgnoreInvisibility As Boolean) Private Sub _GetAllAnimControls(Element As FrameworkElement, ByRef AllControls As List(Of FrameworkElement), IgnoreInvisibility As Boolean)
If Not IgnoreInvisibility AndAlso Element.Visibility = Visibility.Collapsed Then Exit Sub If Not IgnoreInvisibility AndAlso Element.Visibility = Visibility.Collapsed Then Return
If TypeOf Element Is MyCard OrElse TypeOf Element Is MyHint OrElse TypeOf Element Is MyExtraTextButton OrElse TypeOf Element Is TextBlock OrElse TypeOf Element Is MyTextButton Then If TypeOf Element Is MyCard OrElse TypeOf Element Is MyHint OrElse TypeOf Element Is MyExtraTextButton OrElse TypeOf Element Is TextBlock OrElse TypeOf Element Is MyTextButton Then
AllControls.Add(Element) AllControls.Add(Element)
ElseIf TypeOf Element Is ContentControl Then ElseIf TypeOf Element Is ContentControl Then
@@ -41,7 +41,7 @@ Public Class MyRadioBox
RaiseEvent PreviewCheck(Me, e) RaiseEvent PreviewCheck(Me, e)
If e.Handled Then If e.Handled Then
Radiobox_MouseLeave() Radiobox_MouseLeave()
Exit Sub Return
End If End If
End If End If
@@ -54,7 +54,7 @@ Public Class MyRadioBox
End If End If
'保证只有一个单选框选中 '保证只有一个单选框选中
If Parent Is Nothing Then Exit Sub If Parent Is Nothing Then Return
Dim RadioboxList As New List(Of MyRadioBox) Dim RadioboxList As New List(Of MyRadioBox)
Dim CheckedCount As Integer = 0 Dim CheckedCount As Integer = 0
For Each Control In CType(Parent, Object).Children '收集控件列表与选中个数 For Each Control In CType(Parent, Object).Children '收集控件列表与选中个数
@@ -172,7 +172,7 @@ Public Class MyRadioBox
Private MouseDowned As Boolean = False Private MouseDowned As Boolean = False
Private AllowMouseDown As Boolean = True Private AllowMouseDown As Boolean = True
Private Sub Radiobox_MouseUp() Handles Me.MouseLeftButtonUp Private Sub Radiobox_MouseUp() Handles Me.MouseLeftButtonUp
If Not MouseDowned Then Exit Sub If Not MouseDowned Then Return
Log("[Control] 按下单选框:" & Text) Log("[Control] 按下单选框:" & Text)
SetChecked(True, True) SetChecked(True, True)
MouseDowned = False MouseDowned = False
@@ -187,7 +187,7 @@ Public Class MyRadioBox
End If End If
End Sub End Sub
Private Sub Radiobox_MouseLeave() Handles Me.MouseLeave Private Sub Radiobox_MouseLeave() Handles Me.MouseLeave
If Not MouseDowned Then Exit Sub If Not MouseDowned Then Return
MouseDowned = False MouseDowned = False
AniStart(AaColor(ShapeBorder, Ellipse.FillProperty, "ColorBrushHalfWhite", 100), "MyRadioBox Background " & Uuid) AniStart(AaColor(ShapeBorder, Ellipse.FillProperty, "ColorBrushHalfWhite", 100), "MyRadioBox Background " & Uuid)
If Not Checked Then If Not Checked Then
@@ -224,7 +224,7 @@ Public Class MyRadioBox
AniStart(AaColor(LabText, TextBlock.ForegroundProperty, "ColorBrush3", AnimationTimeOfMouseIn), "MyRadioBox TextColor " & Uuid) AniStart(AaColor(LabText, TextBlock.ForegroundProperty, "ColorBrush3", AnimationTimeOfMouseIn), "MyRadioBox TextColor " & Uuid)
End Sub End Sub
Private Sub Radiobox_MouseLeaveAnimation() Handles Me.MouseLeave Private Sub Radiobox_MouseLeaveAnimation() Handles Me.MouseLeave
If Not Me.IsEnabled Then Exit Sub 'MouseLeave 比 IsEnabledChanged 后执行,所以如果自定义事件修改了 IsEnabled,将导致显示错误 If Not Me.IsEnabled Then Return 'MouseLeave 比 IsEnabledChanged 后执行,所以如果自定义事件修改了 IsEnabled,将导致显示错误
If IsLoaded AndAlso AniControlEnabled = 0 Then If IsLoaded AndAlso AniControlEnabled = 0 Then
AniStart(AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4"), AnimationTimeOfMouseOut), "MyRadioBox BorderColor " & Uuid) AniStart(AaColor(ShapeBorder, Ellipse.StrokeProperty, If(IsEnabled, If(Checked, "ColorBrush2", "ColorBrush1"), "ColorBrushGray4"), AnimationTimeOfMouseOut), "MyRadioBox BorderColor " & Uuid)
AniStart(AaColor(LabText, TextBlock.ForegroundProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray4"), AnimationTimeOfMouseOut), "MyRadioBox TextColor " & Uuid) AniStart(AaColor(LabText, TextBlock.ForegroundProperty, If(IsEnabled, "ColorBrush1", "ColorBrushGray4"), AnimationTimeOfMouseOut), "MyRadioBox TextColor " & Uuid)
@@ -62,7 +62,7 @@ Public Class MyRadioButton
'保证只有一个单选框选中 '保证只有一个单选框选中
If IsNothing(Parent) Then Exit Sub If IsNothing(Parent) Then Return
Dim RadioboxList As New List(Of MyRadioButton) Dim RadioboxList As New List(Of MyRadioButton)
Dim CheckedCount As Integer = 0 Dim CheckedCount As Integer = 0
'收集控件列表与选中个数 '收集控件列表与选中个数
@@ -101,7 +101,7 @@ Public Class MyRadioButton
'更改动画 '更改动画
If Not IsChanged Then Exit Sub If Not IsChanged Then Return
RefreshColor(Nothing, anime) RefreshColor(Nothing, anime)
'触发事件 '触发事件
@@ -147,17 +147,17 @@ Public Class MyRadioButton
Public Event PreviewClick(sender As Object, e As RouteEventArgs) Public Event PreviewClick(sender As Object, e As RouteEventArgs)
Private IsMouseDown As Boolean = False Private IsMouseDown As Boolean = False
Private Sub Radiobox_MouseUp() Handles Me.MouseLeftButtonUp Private Sub Radiobox_MouseUp() Handles Me.MouseLeftButtonUp
If Checked Then Exit Sub If Checked Then Return
If Not IsMouseDown Then Exit Sub If Not IsMouseDown Then Return
Log("[Control] 按下单选按钮:" & Text) Log("[Control] 按下单选按钮:" & Text)
IsMouseDown = False IsMouseDown = False
Dim e As New RouteEventArgs(True) Dim e As New RouteEventArgs(True)
RaiseEvent PreviewClick(Me, e) RaiseEvent PreviewClick(Me, e)
If e.Handled Then Exit Sub If e.Handled Then Return
SetChecked(True, True, True) SetChecked(True, True, True)
End Sub End Sub
Private Sub Radiobox_MouseDown() Handles Me.MouseLeftButtonDown Private Sub Radiobox_MouseDown() Handles Me.MouseLeftButtonDown
If Checked Then Exit Sub If Checked Then Return
IsMouseDown = True IsMouseDown = True
RefreshColor() RefreshColor()
End Sub End Sub
@@ -6,7 +6,7 @@
Private RealOffset As Double Private RealOffset As Double
Private Sub MyScrollViewer_PreviewMouseWheel(sender As Object, e As MouseWheelEventArgs) Handles Me.PreviewMouseWheel Private Sub MyScrollViewer_PreviewMouseWheel(sender As Object, e As MouseWheelEventArgs) Handles Me.PreviewMouseWheel
If e.Delta = 0 OrElse ActualHeight = 0 OrElse ScrollableHeight = 0 Then Exit Sub If e.Delta = 0 OrElse ActualHeight = 0 OrElse ScrollableHeight = 0 Then Return
Dim SourceType = e.Source.GetType Dim SourceType = e.Source.GetType
If Content.TemplatedParent Is Nothing AndAlso ( If Content.TemplatedParent Is Nothing AndAlso (
(GetType(ComboBox).IsAssignableFrom(SourceType) AndAlso CType(e.Source, ComboBox).IsDropDownOpen) OrElse (GetType(ComboBox).IsAssignableFrom(SourceType) AndAlso CType(e.Source, ComboBox).IsDropDownOpen) OrElse
@@ -14,7 +14,7 @@
GetType(ComboBoxItem).IsAssignableFrom(SourceType) OrElse GetType(ComboBoxItem).IsAssignableFrom(SourceType) OrElse
TypeOf e.Source Is CheckBox) Then TypeOf e.Source Is CheckBox) Then
'如果当前是在对有滚动条的下拉框或文本框执行,则不接管操作 '如果当前是在对有滚动条的下拉框或文本框执行,则不接管操作
Exit Sub Return
End If End If
e.Handled = True e.Handled = True
PerformVerticalOffsetDelta(-e.Delta) PerformVerticalOffsetDelta(-e.Delta)
@@ -14,7 +14,7 @@
Return _MaxValue Return _MaxValue
End Get End Get
Set(value As Integer) Set(value As Integer)
If value = _MaxValue Then Exit Property If value = _MaxValue Then Return
_MaxValue = value _MaxValue = value
RefreshWidth(Nothing, Nothing) RefreshWidth(Nothing, Nothing)
End Set End Set
@@ -29,7 +29,7 @@
Try Try
newValue = MathClamp(newValue, 0, MaxValue) newValue = MathClamp(newValue, 0, MaxValue)
If _Value = newValue Then Exit Property If _Value = newValue Then Return
'触发 Preview 事件,修改新值 '触发 Preview 事件,修改新值
Dim OldValue = _Value Dim OldValue = _Value
@@ -40,12 +40,12 @@
If e.Handled Then If e.Handled Then
_Value = OldValue _Value = OldValue
DragStop() DragStop()
Exit Property Return
End If End If
End If End If
If IsLoaded AndAlso AniControlEnabled = 0 Then If IsLoaded AndAlso AniControlEnabled = 0 Then
If ActualWidth < ShapeDot.Width Then Exit Property If ActualWidth < ShapeDot.Width Then Return
Dim NewWidth As Double = _Value / MaxValue * (ActualWidth - ShapeDot.Width) Dim NewWidth As Double = _Value / MaxValue * (ActualWidth - ShapeDot.Width)
Dim DeltaProcess As Double = Math.Abs(LineFore.Width / (ActualWidth - ShapeDot.Width) - _Value / MaxValue) Dim DeltaProcess As Double = Math.Abs(LineFore.Width / (ActualWidth - ShapeDot.Width) - _Value / MaxValue)
Dim Time As Double = (1 - Math.Pow(1 - DeltaProcess, 3)) * 300 + If(ChangeByKey, 100, 0) Dim Time As Double = (1 - Math.Pow(1 - DeltaProcess, 3)) * 300 + If(ChangeByKey, 100, 0)
@@ -103,7 +103,7 @@
Popup.IsOpen = False Popup.IsOpen = False
End Sub End Sub
Public Sub RefreshPopup() Public Sub RefreshPopup()
If GetHintText Is Nothing Then Exit Sub If GetHintText Is Nothing Then Return
Popup.IsOpen = True Popup.IsOpen = True
TextHint.Text = GetHintText.DynamicInvoke(Value) TextHint.Text = GetHintText.DynamicInvoke(Value)
Dim typeface As New Typeface(TextHint.FontFamily, TextHint.FontStyle, TextHint.FontWeight, TextHint.FontStretch) Dim typeface As New Typeface(TextHint.FontFamily, TextHint.FontStyle, TextHint.FontWeight, TextHint.FontStretch)
@@ -165,7 +165,7 @@
End Sub End Sub
Private Sub MySlider_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown Private Sub MySlider_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown
'拒绝一边拖动一边用按键改变 '拒绝一边拖动一边用按键改变
If ReferenceEquals(Me, DragControl) Then Exit Sub If ReferenceEquals(Me, DragControl) Then Return
'改变值 '改变值
If e.Key = Key.Left Then If e.Key = Key.Left Then
ChangeByKey = True ChangeByKey = True
@@ -178,7 +178,7 @@
ChangeByKey = False ChangeByKey = False
e.Handled = True e.Handled = True
Else Else
Exit Sub Return
End If End If
'更新 Popup '更新 Popup
If GetHintText IsNot Nothing Then If GetHintText IsNot Nothing Then
+5 -5
View File
@@ -36,7 +36,7 @@
End Property End Property
Public Overrides Sub OnApplyTemplate() Public Overrides Sub OnApplyTemplate()
MyBase.OnApplyTemplate() MyBase.OnApplyTemplate()
If HintText = "" OrElse labHint.Text <> "" Then Exit Sub If HintText = "" OrElse labHint.Text <> "" Then Return
labHint.Text = If(Text = "", HintText, "") labHint.Text = If(Text = "", HintText, "")
End Sub End Sub
@@ -217,11 +217,11 @@
IsTextChanged = IsLoaded IsTextChanged = IsLoaded
'进行输入验证 '进行输入验证
Validate() Validate()
If Not IsValidated Then Exit Sub If Not IsValidated Then Return
'改变文本 '改变文本
RaiseEvent ValidatedTextChanged(sender, e) RaiseEvent ValidatedTextChanged(sender, e)
Catch ex As Exception Catch ex As Exception
Log(ex, "进行输入验证时出错", LogLevel.Assert) Log(ex, "进行输入验证时出错", LogLevel.Critical)
End Try End Try
End Sub End Sub
@@ -230,7 +230,7 @@
Private Sub RefreshColor() Handles Me.IsEnabledChanged, Me.MouseEnter, Me.MouseLeave, Me.GotFocus, Me.LostFocus Private Sub RefreshColor() Handles Me.IsEnabledChanged, Me.MouseEnter, Me.MouseLeave, Me.GotFocus, Me.LostFocus
Try Try
'不对 ComboBox 从属进行动画 '不对 ComboBox 从属进行动画
If TemplatedParent IsNot Nothing AndAlso TypeOf TemplatedParent Is MyComboBox Then Exit Sub If TemplatedParent IsNot Nothing AndAlso TypeOf TemplatedParent Is MyComboBox Then Return
'判断当前颜色 '判断当前颜色
Dim ForeColorName As String, BackColorName As String Dim ForeColorName As String, BackColorName As String
Dim AnimationTime As Integer Dim AnimationTime As Integer
@@ -280,7 +280,7 @@
End Sub End Sub
Private Sub RefreshTextColor() Handles Me.IsEnabledChanged Private Sub RefreshTextColor() Handles Me.IsEnabledChanged
Dim NewColor As MyColor = If(IsEnabled, ColorGray1, ColorGray4) Dim NewColor As MyColor = If(IsEnabled, ColorGray1, ColorGray4)
If CType(Foreground, SolidColorBrush).Color.R = NewColor.R Then Exit Sub If CType(Foreground, SolidColorBrush).Color.R = NewColor.R Then Return
If IsLoaded AndAlso AniControlEnabled = 0 AndAlso Not Text = "" Then If IsLoaded AndAlso AniControlEnabled = 0 AndAlso Not Text = "" Then
'有动画 '有动画
AniStart({AaColor(Me, ForegroundProperty, If(IsEnabled, "ColorBrushGray1", "ColorBrushGray4"), 200)}, "MyTextBox TextColor " & Uuid) AniStart({AaColor(Me, ForegroundProperty, If(IsEnabled, "ColorBrushGray1", "ColorBrushGray4"), 200)}, "MyTextBox TextColor " & Uuid)
@@ -72,7 +72,7 @@
Time = AnimationTimeOut Time = AnimationTimeOut
End If End If
'重复性验证 '重复性验证
If ColorName = ForeName Then Exit Sub If ColorName = ForeName Then Return
ColorName = ForeName ColorName = ForeName
'触发颜色动画 '触发颜色动画
If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画
+8 -10
View File
@@ -99,9 +99,7 @@
<Grid x:Name="PanTitle" Height="48"> <Grid x:Name="PanTitle" Height="48">
<Grid.Background> <Grid.Background>
<LinearGradientBrush EndPoint="1,0" StartPoint="0,0"> <LinearGradientBrush EndPoint="1,0" StartPoint="0,0">
<GradientStop Color="{StaticResource ColorObject3}" Offset="0"/> <GradientStop Color="{StaticResource ColorObject4}" Offset="0"/>
<GradientStop Color="{StaticResource ColorObject2}" Offset="0.5"/>
<GradientStop Color="{StaticResource ColorObject3}" Offset="1"/>
</LinearGradientBrush> </LinearGradientBrush>
</Grid.Background> </Grid.Background>
<local:MyImage x:Name="ImgTitle" IsHitTestVisible="False" Stretch="UniformToFill" IsEnabled="False" RenderOptions.BitmapScalingMode="LowQuality" /> <local:MyImage x:Name="ImgTitle" IsHitTestVisible="False" Stretch="UniformToFill" IsEnabled="False" RenderOptions.BitmapScalingMode="LowQuality" />
@@ -115,19 +113,19 @@
<ColumnDefinition Width="Auto" /> <ColumnDefinition Width="Auto" />
<ColumnDefinition Width="1*" /> <ColumnDefinition Width="1*" />
</Grid.ColumnDefinitions> </Grid.ColumnDefinitions>
<Path x:Name="ShapeTitleLogo" Data="M26,29 v-25 h5 a7,7 180 0 1 0,14 h-5 M61,6.5 a10,11.5 180 1 0 0,18 M68,2.5 v24.5 h12 M98,2 v27 M107,2 v27" SnapsToDevicePixels="False" UseLayoutRounding="False" IsHitTestVisible="False" HorizontalAlignment="Left" Margin="19,15.5,0,15.5" Stretch="fill" Stroke="White" StrokeThickness="1.9" Width="53" /> <Path x:Name="ShapeTitleLogo" Data="M26,29 v-25 h6 a7,7 180 0 1 0,14 h-6 M62.5,6.5 a10,11.5 180 1 0 0,18 M71,2.5 v24.5 h13.5" SnapsToDevicePixels="False" UseLayoutRounding="False" IsHitTestVisible="False" HorizontalAlignment="Left" Margin="19,15.5,0,15.5" Stretch="fill" Stroke="White" StrokeThickness="2.2" Width="39" />
<TextBlock x:Name="LabTitleLogo" Visibility="Collapsed" SnapsToDevicePixels="False" UseLayoutRounding="False" IsHitTestVisible="False" HorizontalAlignment="Left" Margin="18,0,0,0" Foreground="White" FontSize="17" VerticalAlignment="Center" /> <TextBlock x:Name="LabTitleLogo" Visibility="Collapsed" SnapsToDevicePixels="False" UseLayoutRounding="False" IsHitTestVisible="False" HorizontalAlignment="Left" Margin="18,0,0,0" Foreground="White" FontSize="17" VerticalAlignment="Center" />
<local:MyImage x:Name="ImageTitleLogo" SnapsToDevicePixels="False" UseLayoutRounding="False" IsHitTestVisible="False" HorizontalAlignment="Left" Margin="7" VerticalAlignment="Center" Visibility="Collapsed" /> <local:MyImage x:Name="ImageTitleLogo" SnapsToDevicePixels="False" UseLayoutRounding="False" IsHitTestVisible="False" HorizontalAlignment="Left" Margin="7" VerticalAlignment="Center" Visibility="Collapsed" />
<StackPanel Grid.Column="1" x:Name="PanTitleSelect" HorizontalAlignment="Left" Height="27" VerticalAlignment="Center" Orientation="Horizontal" Margin="13,0"> <StackPanel Grid.Column="1" x:Name="PanTitleSelect" HorizontalAlignment="Left" Height="27" VerticalAlignment="Center" Orientation="Horizontal" Margin="13,0">
<local:MyRadioButton x:Name="BtnTitleSelect0" Text="{DynamicResource LangTitleHome}" Tag="0" Margin="5,0" Checked="True" Padding="2,0" <local:MyRadioButton x:Name="BtnTitleSelect0" Text="启动" Tag="0" Margin="5,0" Checked="True" Padding="2,0"
LogoScale="0.95" Logo="M985.403 552.96C985.403 812.702 773.041 1024 512 1024S38.597 812.702 38.597 552.96c0-158.208 79.163-304.955 211.771-392.625 31.074-20.52 72.94-11.973 93.46 19.101s12.012 72.94-19.062 93.46c-94.681 62.622-151.237 167.306-151.237 280.064 0 185.344 151.788 336.108 338.471 336.108S850.471 738.304 850.471 552.96c0-114.649-57.974-220.278-155.096-282.585-31.35-20.125-40.448-61.833-20.362-93.184s61.794-40.448 93.184-20.4c135.995 87.236 217.206 235.362 217.206 396.169zM512 560.128c37.258 0 67.466-30.208 67.466-67.466V67.466C579.466 30.208 549.258 0 512 0s-67.466 30.208-67.466 67.466v425.196c0 37.258 30.208 67.466 67.466 67.466z" /> LogoScale="0.9" Logo="M52.1,164.5c-1.4,0-3.1-0.5-4.2-1.3c-2.6-1.7-4-4.2-4-7V43.8c0-2.9,1.6-5.8,4.1-7c1.2-0.8,2.7-1.2,4.1-1.2c1.5,0,2.9,0.4,4.2,1.2L153.1,93c0,0,0.1,0,0.1,0.1c2.6,1.7,4,4.2,4,7c0,3-1.7,5.8-4.2,7.1l-96.8,56.2C55.1,164,53.5,164.5,52.1,164.5z M60.4,142.1l72.1-42.1L60.4,58.2V142.1z" />
<local:MyRadioButton x:Name="BtnTitleSelect1" Text="{DynamicResource LangTitleDownload}" Tag="1" Margin="5,0" Padding="2,0" <local:MyRadioButton x:Name="BtnTitleSelect1" Text="下载" Tag="1" Margin="5,0" Padding="2,0"
LogoScale="0.9" Logo="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" /> LogoScale="0.9" Logo="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" />
<local:MyRadioButton x:Name="BtnTitleSelect2" Text="联机" Tag="2" Margin="5,0" Padding="2,0" <local:MyRadioButton x:Name="BtnTitleSelect2" Text="联机" Tag="2" Margin="5,0" Padding="2,0"
LogoScale="1.05" Logo="M512 817c-48.601 0-88-39.399-88-88s39.399-88 88-88 88 39.399 88 88-39.399 88-88 88zM237.671 565.74C308.335 474.58 397.369 429 504.774 429c118.433 0 214.225 55.421 287.377 166.264l-53.407 30.369c-13.84 7.87-31.362 4.367-41.114-8.219-50.291-64.911-114.577-97.367-192.856-97.367-86.851 0-156.835 40.318-209.95 120.953l-47.995-28.02c-15.263-8.91-20.412-28.507-11.502-43.77a32 32 0 0 1 2.344-3.47zM107.691 419.47C205.24 278.491 337.805 208 505.379 208c178.77 0 317.694 80.224 416.772 240.672l-56.54 31.73c-13.686 7.68-30.922 4.303-40.697-7.975C735.581 360.213 629.07 303.009 505.38 300.815 373.997 298.485 261.637 362.88 168.3 494l-50.116-28.505c-15.362-8.738-20.732-28.275-11.994-43.637a32 32 0 0 1 1.5-2.387z"/> LogoScale="1.05" Logo="M512 817c-48.601 0-88-39.399-88-88s39.399-88 88-88 88 39.399 88 88-39.399 88-88 88zM237.671 565.74C308.335 474.58 397.369 429 504.774 429c118.433 0 214.225 55.421 287.377 166.264l-53.407 30.369c-13.84 7.87-31.362 4.367-41.114-8.219-50.291-64.911-114.577-97.367-192.856-97.367-86.851 0-156.835 40.318-209.95 120.953l-47.995-28.02c-15.263-8.91-20.412-28.507-11.502-43.77a32 32 0 0 1 2.344-3.47zM107.691 419.47C205.24 278.491 337.805 208 505.379 208c178.77 0 317.694 80.224 416.772 240.672l-56.54 31.73c-13.686 7.68-30.922 4.303-40.697-7.975C735.581 360.213 629.07 303.009 505.38 300.815 373.997 298.485 261.637 362.88 168.3 494l-50.116-28.505c-15.362-8.738-20.732-28.275-11.994-43.637a32 32 0 0 1 1.5-2.387z"/>
<local:MyRadioButton x:Name="BtnTitleSelect3" Text="{DynamicResource LangTitleSetup}" Tag="3" Margin="5,0" Padding="2,0" <local:MyRadioButton x:Name="BtnTitleSelect3" Text="设置" Tag="3" Margin="5,0" Padding="2,0"
LogoScale="1.1" Logo="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"/> LogoScale="1.1" Logo="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"/>
<local:MyRadioButton x:Name="BtnTitleSelect4" Text="{DynamicResource LangTitleOther}" Tag="4" Margin="5,0" Padding="2,0" <local:MyRadioButton x:Name="BtnTitleSelect4" Text="更多" Tag="4" Margin="5,0" Padding="2,0"
LogoScale="0.93" Logo="M364 0h-273C40 0 0 40 0 91v273C0 414 40 455 91 455h273C414 455 455 414 455 364V91C455 40 414 0 364 0zM341 341H113V113h227v227zM933 0h-273C609 0 568 40 568 91v273c0 50 40 91 91 91h273C983 455 1024 414 1024 364V91c0-50-40-91-90-91zM910 341h-227V113h227v227zM364 568h-273C40 568 0 609 0 659v273c0 50 40 91 91 91h273C414 1024 455 983 455 932v-273C455 609 414 568 364 568zM341 910H113v-227h227v227zM933 568h-273c-50 0-91 40-91 91v273c0 50 40 91 91 91h273c50 0 90-40 90-91v-273c0-50-40-90-90-90zM910 910h-227v-227h227v227z"/> LogoScale="0.93" Logo="M364 0h-273C40 0 0 40 0 91v273C0 414 40 455 91 455h273C414 455 455 414 455 364V91C455 40 414 0 364 0zM341 341H113V113h227v227zM933 0h-273C609 0 568 40 568 91v273c0 50 40 91 91 91h273C983 455 1024 414 1024 364V91c0-50-40-91-90-91zM910 341h-227V113h227v227zM364 568h-273C40 568 0 609 0 659v273c0 50 40 91 91 91h273C414 1024 455 983 455 932v-273C455 609 414 568 364 568zM341 910H113v-227h227v227zM933 568h-273c-50 0-91 40-91 91v273c0 50 40 91 91 91h273c50 0 90-40 90-91v-273c0-50-40-90-90-90zM910 910h-227v-227h227v227z"/>
</StackPanel> </StackPanel>
</Grid> </Grid>
@@ -145,7 +143,7 @@
<Rectangle x:Name="RectLeftBackground" Width="0" Fill="{DynamicResource ColorBrushBackgroundTransparentSidebar}" IsHitTestVisible="False" /> <Rectangle x:Name="RectLeftBackground" Width="0" Fill="{DynamicResource ColorBrushBackgroundTransparentSidebar}" IsHitTestVisible="False" />
<Rectangle x:Name="RectLeftShadow" Width="4" HorizontalAlignment="Left" IsHitTestVisible="False" Grid.Column="1" > <Rectangle x:Name="RectLeftShadow" Width="4" HorizontalAlignment="Left" IsHitTestVisible="False" Grid.Column="1" >
<Rectangle.Fill> <Rectangle.Fill>
<LinearGradientBrush EndPoint="1,0" StartPoint="0,0" Opacity="0.085"> <LinearGradientBrush EndPoint="1,0" StartPoint="0,0" Opacity="0.04">
<GradientStop Color="#000000" Offset="0"/> <GradientStop Color="#000000" Offset="0"/>
<GradientStop Color="#00000000" Offset="1"/> <GradientStop Color="#00000000" Offset="1"/>
</LinearGradientBrush> </LinearGradientBrush>
+172 -77
View File
@@ -1,4 +1,5 @@
Imports System.ComponentModel Imports System.ComponentModel
Imports System.Windows.Interop
Public Class FormMain Public Class FormMain
@@ -10,6 +11,29 @@ Public Class FormMain
Dim FeatureList As New List(Of KeyValuePair(Of Integer, String)) Dim FeatureList As New List(Of KeyValuePair(Of Integer, String))
'统计更新日志条目 '统计更新日志条目
#If BETA Then #If BETA Then
If LastVersion < 367 Then 'Release 2.10.6
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:启用 MCIM 社区资源镜像源,以缓解社区资源难以下载的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:正版登录出错时无法给出正确的错误信息"))
FeatureCount += 9
BugCount += 9
End If
If LastVersion < 365 Then 'Release 2.10.5
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:下载资源时,会单独记忆每种资源上次下载到的文件夹,以防混淆"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化:网络底层框架与下载稳定性"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:无法启动一部分 LabyMod 和 GTNH 客户端"))
FeatureCount += 22
BugCount += 26
End If
If LastVersion < 361 Then 'Release 2.10.3
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复:无法安装部分使用老版本 PCL 导出的整合包"))
End If
If LastVersion < 359 Then 'Release 2.10.2
If LastVersion >= 357 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:下载资源包、光影包时能自动跳转到对应的文件夹"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:调整界面样式与动画,让整体视觉更干净,操作体验更顺滑"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复:无法从 CurseForge 下载 Mod 等资源,或是安装整合包"))
FeatureCount += 28
BugCount += 28
End If
If LastVersion < 357 Then 'Release 2.10.0 If LastVersion < 357 Then 'Release 2.10.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增:下载资源包、光影包、数据包")) FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增:下载资源包、光影包、数据包"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增:允许设置文件下载源")) FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增:允许设置文件下载源"))
@@ -72,6 +96,40 @@ Public Class FormMain
'3:BUG+ IMP* FEAT- '3:BUG+ IMP* FEAT-
'2:BUG* IMP- '2:BUG* IMP-
'1:BUG- '1:BUG-
If LastVersion < 366 Then 'Snapshot 2.10.6
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:启用 MCIM 社区资源镜像源,以缓解社区资源难以下载的问题"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:正版登录出错时无法给出正确的错误信息"))
FeatureCount += 9
BugCount += 9
End If
If LastVersion < 364 Then 'Snapshot 2.10.5
If LastVersion >= 363 Then
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:无法添加新的正版账号"))
BugCount += 1
End If
End If
If LastVersion < 363 Then 'Snapshot 2.10.4
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:下载资源时,会单独记忆每种资源上次下载到的文件夹,以防混淆"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "优化:网络底层框架与下载稳定性"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:无法启动一部分 LabyMod 和 GTNH 客户端"))
FeatureCount += 22
BugCount += 26
End If
If LastVersion < 362 Then 'Snapshot 2.10.3
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复:无法安装部分使用老版本 PCL 导出的整合包"))
End If
If LastVersion < 360 Then 'Snapshot 2.10.2
FeatureList.Add(New KeyValuePair(Of Integer, String)(2, "修复:无法从 CurseForge 下载 Mod 等资源,或是安装整合包"))
If LastVersion >= 358 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(1, "修复:无法加载正版皮肤的头像"))
FeatureCount += 3
BugCount += 5
End If
If LastVersion < 358 Then 'Snapshot 2.10.1
If LastVersion >= 356 Then FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:下载资源包、光影包时能自动跳转到对应的文件夹"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "优化:调整界面样式与动画,让整体视觉更干净,操作体验更顺滑"))
FeatureCount += 25
BugCount += 23
End If
If LastVersion < 356 Then 'Snapshot 2.10.0 If LastVersion < 356 Then 'Snapshot 2.10.0
FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增:下载资源包、光影包、数据包")) FeatureList.Add(New KeyValuePair(Of Integer, String)(5, "新增:下载资源包、光影包、数据包"))
FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增:允许设置文件下载源")) FeatureList.Add(New KeyValuePair(Of Integer, String)(3, "新增:允许设置文件下载源"))
@@ -200,7 +258,7 @@ Public Class FormMain
If Not Setup.IsUnset("LaunchArgumentIndie") Then If Not Setup.IsUnset("LaunchArgumentIndie") Then
Log("[Start] 从老 PCL 迁移版本隔离") Log("[Start] 从老 PCL 迁移版本隔离")
Setup.Set("LaunchArgumentIndieV2", Setup.Get("LaunchArgumentIndie")) Setup.Set("LaunchArgumentIndieV2", Setup.Get("LaunchArgumentIndie"))
ElseIf Not Setup.IsUnset("WindowHeight") Then ElseIf Not Setup.IsUnset("LaunchVersionSelect") Then
Log("[Start] 从老 PCL 升级,但此前未调整版本隔离,使用老的版本隔离默认值") Log("[Start] 从老 PCL 升级,但此前未调整版本隔离,使用老的版本隔离默认值")
Setup.Set("LaunchArgumentIndieV2", Setup.GetDefault("LaunchArgumentIndie")) Setup.Set("LaunchArgumentIndieV2", Setup.GetDefault("LaunchArgumentIndie"))
Else Else
@@ -211,16 +269,24 @@ Public Class FormMain
'刷新主题 '刷新主题
ThemeCheckAll(False) ThemeCheckAll(False)
Setup.Load("UiLauncherTheme") Setup.Load("UiLauncherTheme")
'注册拖拽事件(不能直接加 Handles,否则没用;#6340)
[AddHandler](DragDrop.DragEnterEvent, New DragEventHandler(AddressOf HandleDrag), handledEventsToo:=True)
[AddHandler](DragDrop.DragOverEvent, New DragEventHandler(AddressOf HandleDrag), handledEventsToo:=True)
'加载 UI '加载 UI
InitializeComponent() InitializeComponent()
Opacity = 0 Opacity = 0
''开启管理员权限下的文件拖拽,但下列代码也没用(#2531) '开启管理员权限下的文件拖拽
'If IsAdmin() Then If IsAdmin() Then
' Log("[Start] PCL 正以管理员权限运行") Static Helper As New DragHelper
' ChangeWindowMessageFilter(&H233, 1) AddHandler SourceInitialized,
' ChangeWindowMessageFilter(&H4A, 1) Sub()
' ChangeWindowMessageFilter(&H49, 1) Dim WpfHelper As New WindowInteropHelper(Me)
'End If Helper.HwndIntPtrSource = HwndSource.FromHwnd(WpfHelper.Handle)
Helper.AddHook()
End Sub
AddHandler Closing, Sub() Helper.RemoveDragHook()
AddHandler Helper.DragDrop, Sub() FileDrag(Helper.DropFilePaths)
End If
'切换到首页 '切换到首页
If Not IsNothing(FrmLaunchLeft.Parent) Then FrmLaunchLeft.SetValue(ContentPresenter.ContentProperty, Nothing) If Not IsNothing(FrmLaunchLeft.Parent) Then FrmLaunchLeft.SetValue(ContentPresenter.ContentProperty, Nothing)
If Not IsNothing(FrmLaunchRight.Parent) Then FrmLaunchRight.SetValue(ContentPresenter.ContentProperty, Nothing) If Not IsNothing(FrmLaunchRight.Parent) Then FrmLaunchRight.SetValue(ContentPresenter.ContentProperty, Nothing)
@@ -267,7 +333,7 @@ Public Class FormMain
Resizer.addResizerUp(ResizerT) Resizer.addResizerUp(ResizerT)
'PLC 彩蛋 'PLC 彩蛋
If RandomInteger(1, 1000) = 233 Then If RandomInteger(1, 1000) = 233 Then
ShapeTitleLogo.Data = New GeometryConverter().ConvertFromString("M26,29 v-25 h5 a7,7 180 0 1 0,14 h-5 M80,6.5 a10,11.5 180 1 0 0,18 M47,2.5 v24.5 h12 M98,2 v27 M107,2 v27") ShapeTitleLogo.Data = New GeometryConverter().ConvertFromString("M26,29 v-25 h6 a7,7 180 0 1 0,14 h-6 M83,6.5 a10,11.5 180 1 0 0,18 M48,2.5 v24.5 h13.5")
End If End If
'加载窗口 '加载窗口
ThemeRefreshMain() ThemeRefreshMain()
@@ -337,7 +403,9 @@ Public Class FormMain
Catch ex As Exception Catch ex As Exception
Log(ex, "清理自动更新文件失败") Log(ex, "清理自动更新文件失败")
End Try End Try
End Sub, "Start Loader", ThreadPriority.Lowest) '上报
Telemetry("启动")
End Sub, "初始化", ThreadPriority.Lowest)
Log("[Start] 第三阶段加载用时:" & GetTimeTick() - ApplicationStartTick & " ms") Log("[Start] 第三阶段加载用时:" & GetTimeTick() - ApplicationStartTick & " ms")
End Sub End Sub
@@ -433,8 +501,8 @@ Public Class FormMain
Log("[Start] 已从老版本迁移 Mod 命名设置") Log("[Start] 已从老版本迁移 Mod 命名设置")
End If End If
'输出更新日志 '输出更新日志
If LastVersionCode <= 0 Then Exit Sub If LastVersionCode <= 0 Then Return
If LowerVersionCode >= VersionCode Then Exit Sub If LowerVersionCode >= VersionCode Then Return
ShowUpdateLog(LowerVersionCode) ShowUpdateLog(LowerVersionCode)
End Sub End Sub
Private Sub DowngradeSub(LastVersionCode As Integer) Private Sub DowngradeSub(LastVersionCode As Integer)
@@ -468,7 +536,7 @@ Public Class FormMain
Next Next
End Sub, "强行停止下载任务") End Sub, "强行停止下载任务")
Else Else
Exit Sub Return
End If End If
End If End If
'关闭 '关闭
@@ -508,26 +576,20 @@ Public Class FormMain
On Error Resume Next On Error Resume Next
IsProgramEnded = True IsProgramEnded = True
AniControlEnabled += 1 AniControlEnabled += 1
PageLinkIoi.IoiStop(False)
PageLinkHiper.HiperStop(False)
If IsUpdateWaitingRestart Then UpdateRestart(False) If IsUpdateWaitingRestart Then UpdateRestart(False)
If ReturnCode = ProcessReturnValues.Exception Then If ReturnCode = ProcessReturnValues.Exception Then
If Not IsLogShown Then If Not IsLogShown Then
FeedbackInfo() FeedbackInfo()
Log("请在 https://github.com/Hex-Dragon/PCL2/issues 提交错误报告,以便于作者解决此问题!") Log("请在 https://github.com/Meloong-Git/PCL/issues 提交错误报告,以便于作者解决此问题!")
IsLogShown = True IsLogShown = True
ShellOnly(Path & "PCL\Log1.txt") ShellOnly(Path & "PCL\Log1.txt")
End If End If
Thread.Sleep(500) '防止 PCL 在记事本打开前就被掐掉 Thread.Sleep(500) '防止 PCL 在记事本打开前就被掐掉
End If End If
Log("[System] 程序已退出,返回值:" & GetStringFromEnum(CType(ReturnCode, [Enum]))) Log("[System] 程序已退出,返回值:" & GetStringFromEnum(ReturnCode))
LogFlush() LogFlush()
If ReturnCode = ProcessReturnValues.Success Then If ReturnCode <> ProcessReturnValues.Success Then Environment.Exit(ReturnCode)
Process.GetCurrentProcess.Kill() Process.GetCurrentProcess.Kill()
Else
Environment.Exit(ReturnCode)
Process.GetCurrentProcess.Kill()
End If
End Sub End Sub
Private Sub BtnTitleClose_Click(sender As Object, e As RoutedEventArgs) Handles BtnTitleClose.Click Private Sub BtnTitleClose_Click(sender As Object, e As RoutedEventArgs) Handles BtnTitleClose.Click
EndProgram(True) EndProgram(True)
@@ -568,12 +630,13 @@ Public Class FormMain
'按键事件 '按键事件
Private Sub FormMain_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown Private Sub FormMain_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown
If e.IsRepeat Then Exit Sub If e.IsRepeat Then Return
'调用弹窗:回车选择第一个,Esc 选择最后一个 '修复按下 Alt 后误认为弹出系统菜单导致的冻结
If PanMsg.Children.Count > 0 Then If e.SystemKey = Key.LeftAlt OrElse e.SystemKey = Key.RightAlt Then e.Handled = True
'在有弹窗时:回车选择第一个,Esc 选择最后一个
If PanMsg.Children.Any Then
If e.Key = Key.Enter Then If e.Key = Key.Enter Then
CType(PanMsg.Children(0), Object).Btn1_Click() CType(PanMsg.Children(0), Object).Btn1_Click()
Exit Sub
ElseIf e.Key = Key.Escape Then ElseIf e.Key = Key.Escape Then
Dim Msg As Object = PanMsg.Children(0) Dim Msg As Object = PanMsg.Children(0)
If TypeOf Msg IsNot MyMsgInput AndAlso TypeOf Msg IsNot MyMsgSelect AndAlso Msg.Btn3.Visibility = Visibility.Visible Then If TypeOf Msg IsNot MyMsgInput AndAlso TypeOf Msg IsNot MyMsgSelect AndAlso Msg.Btn3.Visibility = Visibility.Visible Then
@@ -583,16 +646,21 @@ Public Class FormMain
Else Else
Msg.Btn1_Click() Msg.Btn1_Click()
End If End If
Exit Sub
End If End If
Return
End If End If
'==========================
' 在没有弹窗时:继续检查……
'==========================
'按 ESC 返回上一级 '按 ESC 返回上一级
If e.Key = Key.Escape Then TriggerPageBack() If e.Key = Key.Escape Then TriggerPageBack()
'更改隐藏版本可见性 '更改隐藏版本可见性
If e.Key = Key.F11 AndAlso PageCurrent = FormMain.PageType.VersionSelect Then If e.Key = Key.F11 AndAlso PageCurrent = FormMain.PageType.VersionSelect Then
FrmSelectRight.ShowHidden = Not FrmSelectRight.ShowHidden FrmSelectRight.ShowHidden = Not FrmSelectRight.ShowHidden
LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\")
Exit Sub Return
End If End If
'更改功能隐藏可见性 '更改功能隐藏可见性
If e.Key = Key.F12 Then If e.Key = Key.F12 Then
@@ -603,13 +671,13 @@ Public Class FormMain
Hint("功能隐藏设置已重新开启!", HintType.Finish) Hint("功能隐藏设置已重新开启!", HintType.Finish)
End If End If
PageSetupUI.HiddenRefresh() PageSetupUI.HiddenRefresh()
Exit Sub Return
End If End If
'按 F5 刷新页面 '按 F5 刷新页面
If e.Key = Key.F5 Then If e.Key = Key.F5 Then
If TypeOf PageLeft Is IRefreshable Then CType(PageLeft, IRefreshable).Refresh() If TypeOf PageLeft Is IRefreshable Then CType(PageLeft, IRefreshable).Refresh()
If TypeOf PageRight Is IRefreshable Then CType(PageRight, IRefreshable).Refresh() If TypeOf PageRight Is IRefreshable Then CType(PageRight, IRefreshable).Refresh()
Exit Sub Return
End If End If
'调用启动游戏 '调用启动游戏
If e.Key = Key.Enter AndAlso PageCurrent = FormMain.PageType.Launch Then If e.Key = Key.Enter AndAlso PageCurrent = FormMain.PageType.Launch Then
@@ -619,12 +687,10 @@ Public Class FormMain
FrmLaunchLeft.LaunchButtonClick() FrmLaunchLeft.LaunchButtonClick()
End If End If
End If End If
'修复按下 Alt 后误认为弹出系统菜单导致的冻结
If e.SystemKey = Key.LeftAlt OrElse e.SystemKey = Key.RightAlt Then e.Handled = True
End Sub End Sub
Private Sub FormMain_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseDown Private Sub FormMain_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.MouseDown
'鼠标侧键返回上一级 '鼠标侧键返回上一级
If FrmMain.PanMsg.Children.Count > 0 OrElse WaitingMyMsgBox.Any Then Exit Sub '弹窗中(#5513) If FrmMain.PanMsg.Children.Count > 0 OrElse WaitingMyMsgBox.Any Then Return '弹窗中(#5513)
If e.ChangedButton = MouseButton.XButton1 OrElse e.ChangedButton = MouseButton.XButton2 Then TriggerPageBack() If e.ChangedButton = MouseButton.XButton1 OrElse e.ChangedButton = MouseButton.XButton2 Then TriggerPageBack()
End Sub End Sub
Private Sub TriggerPageBack() Private Sub TriggerPageBack()
@@ -651,15 +717,41 @@ Public Class FormMain
End Sub End Sub
'文件拖放 '文件拖放
Private Sub FrmMain_PreviewDragOver(sender As Object, e As DragEventArgs) Handles Me.PreviewDragOver Private Sub HandleDrag(sender As Object, e As DragEventArgs)
If e.Data.GetFormats.Contains("FileDrop") Then
e.Effects = DragDropEffects.Link
Else
e.Effects = DragDropEffects.None
End If
End Sub
Private Sub FrmMain_Drop(sender As Object, e As DragEventArgs) Handles Me.PreviewDrop
Try Try
If e.Handled AndAlso (e.Effects <> DragDropEffects.None) Then Return
e.Handled = True
'缓存
Static PrevData As IDataObject, PrevEffects As DragDropEffects
If e.Data Is PrevData Then
e.Effects = PrevEffects
Return
End If
'确定拖放效果
e.Effects = DragDropEffects.None
If e.Data.GetDataPresent(DataFormats.Text) Then
Dim Str As String = e.Data.GetData(DataFormats.Text)
If Str.StartsWithF("authlib-injector:yggdrasil-server:") Then
e.Effects = DragDropEffects.Copy
ElseIf Str.StartsWithF("file:///") Then
e.Effects = DragDropEffects.Copy
End If
ElseIf e.Data.GetDataPresent(DataFormats.FileDrop) Then
Dim Files As String() = e.Data.GetData(DataFormats.FileDrop)
If Files IsNot Nothing AndAlso Files.Length > 0 Then
e.Effects = DragDropEffects.Link
End If
End If
PrevData = e.Data
PrevEffects = e.Effects
Log("[System] 设置拖放类型:" & GetStringFromEnum(e.Effects))
Catch ex As Exception
Log(ex, "处理拖放时出错", LogLevel.Feedback)
End Try
End Sub
Private Sub FrmMain_Drop(sender As Object, e As DragEventArgs) Handles Me.Drop
Try
ShowWindowToTop()
If e.Data.GetDataPresent(DataFormats.Text) Then If e.Data.GetDataPresent(DataFormats.Text) Then
'获取文本 '获取文本
Try Try
@@ -668,22 +760,23 @@ Public Class FormMain
If Str.StartsWithF("authlib-injector:yggdrasil-server:") Then If Str.StartsWithF("authlib-injector:yggdrasil-server:") Then
'Authlib 拖拽 'Authlib 拖拽
e.Handled = True e.Handled = True
e.Effects = DragDropEffects.Copy
Dim AuthlibServer As String = Net.WebUtility.UrlDecode(Str.Substring("authlib-injector:yggdrasil-server:".Length)) Dim AuthlibServer As String = Net.WebUtility.UrlDecode(Str.Substring("authlib-injector:yggdrasil-server:".Length))
Log("[System] Authlib 拖拽:" & AuthlibServer) Log("[System] Authlib 拖拽:" & AuthlibServer)
If Not String.IsNullOrEmpty(New ValidateHttp().Validate(AuthlibServer)) Then If Not String.IsNullOrEmpty(New ValidateHttp().Validate(AuthlibServer)) Then
Hint($"输入的 Authlib 验证服务器不符合网址格式({AuthlibServer})!", HintType.Critical) Hint($"输入的 Authlib 验证服务器不符合网址格式({AuthlibServer})!", HintType.Critical)
Exit Sub Return
End If End If
Dim TargetVersion = If(PageCurrent = PageType.VersionSetup, PageVersionLeft.Version, McVersionCurrent) Dim TargetVersion = If(PageCurrent = PageType.VersionSetup, PageVersionLeft.Version, McVersionCurrent)
If TargetVersion Is Nothing Then If TargetVersion Is Nothing Then
Hint("请先下载游戏,再设置第三方登录!", HintType.Critical) Hint("请先下载游戏,再设置第三方登录!", HintType.Critical)
Exit Sub Return
End If End If
If AuthlibServer = "https://littleskin.cn/api/yggdrasil" Then If AuthlibServer = "https://littleskin.cn/api/yggdrasil" Then
'LittleSkin 'LittleSkin
If MyMsgBox($"是否要在版本 {TargetVersion.Name} 中开启 LittleSkin 登录?" & vbCrLf & If MyMsgBox($"是否要在版本 {TargetVersion.Name} 中开启 LittleSkin 登录?" & vbCrLf &
"你可以在 版本设置 → 设置 → 服务器选项 中修改登录方式。", "第三方登录开启确认", "确定", "取消") = 2 Then "你可以在 版本设置 → 设置 → 服务器选项 中修改登录方式。", "第三方登录开启确认", "确定", "取消") = 2 Then
Exit Sub Return
End If End If
Setup.Set("VersionServerLogin", 4, Version:=TargetVersion) Setup.Set("VersionServerLogin", 4, Version:=TargetVersion)
Setup.Set("VersionServerAuthServer", "https://littleskin.cn/api/yggdrasil", Version:=TargetVersion) Setup.Set("VersionServerAuthServer", "https://littleskin.cn/api/yggdrasil", Version:=TargetVersion)
@@ -694,7 +787,7 @@ Public Class FormMain
If MyMsgBox($"是否要在版本 {TargetVersion.Name} 中开启第三方登录?" & vbCrLf & If MyMsgBox($"是否要在版本 {TargetVersion.Name} 中开启第三方登录?" & vbCrLf &
$"登录服务器:{AuthlibServer}" & vbCrLf & vbCrLf & $"登录服务器:{AuthlibServer}" & vbCrLf & vbCrLf &
"你可以在 版本设置 → 设置 → 服务器选项 中修改登录方式。", "第三方登录开启确认", "确定", "取消") = 2 Then "你可以在 版本设置 → 设置 → 服务器选项 中修改登录方式。", "第三方登录开启确认", "确定", "取消") = 2 Then
Exit Sub Return
End If End If
Setup.Set("VersionServerLogin", 4, Version:=TargetVersion) Setup.Set("VersionServerLogin", 4, Version:=TargetVersion)
Setup.Set("VersionServerAuthServer", AuthlibServer, Version:=TargetVersion) Setup.Set("VersionServerAuthServer", AuthlibServer, Version:=TargetVersion)
@@ -712,20 +805,22 @@ Public Class FormMain
'文件拖拽(例如从浏览器下载窗口拖入) '文件拖拽(例如从浏览器下载窗口拖入)
Dim FilePath = Net.WebUtility.UrlDecode(Str).Substring("file:///".Length).Replace("/", "\") Dim FilePath = Net.WebUtility.UrlDecode(Str).Substring("file:///".Length).Replace("/", "\")
e.Handled = True e.Handled = True
e.Effects = DragDropEffects.Copy
FileDrag(New List(Of String) From {FilePath}) FileDrag(New List(Of String) From {FilePath})
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "无法接取文本拖拽事件", LogLevel.Developer) Log(ex, "无法接取文本拖拽事件", LogLevel.Developer)
Exit Sub Return
End Try End Try
ElseIf e.Data.GetDataPresent(DataFormats.FileDrop) Then ElseIf e.Data.GetDataPresent(DataFormats.FileDrop) Then
'获取文件并检查 '获取文件并检查
Dim FilePathRaw = e.Data.GetData(DataFormats.FileDrop) Dim FilePathRaw = e.Data.GetData(DataFormats.FileDrop)
If FilePathRaw Is Nothing Then '#2690 If FilePathRaw Is Nothing Then '#2690
Hint("请将文件解压后再拖入!", HintType.Critical) Hint("请将文件解压后再拖入!", HintType.Critical)
Exit Sub Return
End If End If
e.Handled = True e.Handled = True
e.Effects = DragDropEffects.Link
FileDrag(CType(FilePathRaw, IEnumerable(Of String))) FileDrag(CType(FilePathRaw, IEnumerable(Of String)))
End If End If
Catch ex As Exception Catch ex As Exception
@@ -740,10 +835,10 @@ Public Class FormMain
'基础检查 '基础检查
If Directory.Exists(FilePathList.First) AndAlso Not File.Exists(FilePathList.First) Then If Directory.Exists(FilePathList.First) AndAlso Not File.Exists(FilePathList.First) Then
Hint("请拖入一个文件,而非文件夹!", HintType.Critical) Hint("请拖入一个文件,而非文件夹!", HintType.Critical)
Exit Sub Return
ElseIf Not File.Exists(FilePathList.First) Then ElseIf Not File.Exists(FilePathList.First) Then
Hint("拖入的文件不存在:" & FilePathList.First, HintType.Critical) Hint("拖入的文件不存在:" & FilePathList.First, HintType.Critical)
Exit Sub Return
End If End If
'多文件拖拽 '多文件拖拽
If FilePathList.Count > 1 Then If FilePathList.Count > 1 Then
@@ -751,7 +846,7 @@ Public Class FormMain
For Each File In FilePathList For Each File In FilePathList
If Not {"jar", "litemod", "disabled", "old"}.Contains(File.AfterLast(".").ToLower) Then If Not {"jar", "litemod", "disabled", "old"}.Contains(File.AfterLast(".").ToLower) Then
Hint("一次请只拖入一个文件!", HintType.Critical) Hint("一次请只拖入一个文件!", HintType.Critical)
Exit Sub Return
End If End If
Next Next
End If End If
@@ -761,7 +856,7 @@ Public Class FormMain
Log("[System] 文件后缀为 XAML,作为主页加载") Log("[System] 文件后缀为 XAML,作为主页加载")
If File.Exists(Path & "PCL\Custom.xaml") Then If File.Exists(Path & "PCL\Custom.xaml") Then
If MyMsgBox("已存在一个主页文件,是否要将它覆盖?", "覆盖确认", "覆盖", "取消") = 2 Then If MyMsgBox("已存在一个主页文件,是否要将它覆盖?", "覆盖确认", "覆盖", "取消") = 2 Then
Exit Sub Return
End If End If
End If End If
CopyFile(FilePath, Path & "PCL\Custom.xaml") CopyFile(FilePath, Path & "PCL\Custom.xaml")
@@ -771,18 +866,18 @@ Public Class FormMain
FrmLaunchRight.ForceRefresh() FrmLaunchRight.ForceRefresh()
Hint("已加载主页自定义文件!", HintType.Finish) Hint("已加载主页自定义文件!", HintType.Finish)
End Sub) End Sub)
Exit Sub Return
End If End If
'安装 Mod '安装 Mod
If PageVersionMod.InstallMods(FilePathList) Then Exit Sub If PageVersionMod.InstallMods(FilePathList) Then Return
'安装整合包 '安装整合包
If {"zip", "rar", "mrpack"}.Any(Function(t) t = Extension) Then '部分压缩包是 zip 格式但后缀为 rar,总之试一试 If {"zip", "rar", "mrpack"}.Any(Function(t) t = Extension) Then '部分压缩包是 zip 格式但后缀为 rar,总之试一试
Log("[System] 文件为压缩包,尝试作为整合包安装") Log("[System] 文件为压缩包,尝试作为整合包安装")
Try Try
ModpackInstall(FilePath) ModpackInstall(FilePath)
Exit Sub Return
Catch ex As CancelledException Catch ex As CancelledException
Exit Sub '用户主动取消 Return '用户主动取消
Catch ex As Exception Catch ex As Exception
'安装失败,继续往后尝试 '安装失败,继续往后尝试
End Try End Try
@@ -790,17 +885,17 @@ Public Class FormMain
'RAR 处理 'RAR 处理
If Extension = "rar" Then If Extension = "rar" Then
Hint("PCL 无法处理 rar 格式的压缩包,请在解压后重新压缩为 zip 格式再试!") Hint("PCL 无法处理 rar 格式的压缩包,请在解压后重新压缩为 zip 格式再试!")
Exit Sub Return
End If End If
'错误报告分析 '错误报告分析
Try Try
Log("[System] 尝试进行错误报告分析") Log("[System] 尝试进行错误报告分析")
Dim Analyzer As New CrashAnalyzer(GetUuid()) Dim Analyzer As New CrashAnalyzer
Analyzer.Import(FilePath) Analyzer.Import(FilePath)
If Analyzer.Prepare() = 0 Then Exit Try If Not Analyzer.Prepare() Then Exit Try
Analyzer.Analyze() Analyzer.Analyze()
Analyzer.Output(True, New List(Of String)) Analyzer.Output(True, New List(Of String))
Exit Sub Return
Catch ex As Exception Catch ex As Exception
Log(ex, "自主错误报告分析失败", LogLevel.Feedback) Log(ex, "自主错误报告分析失败", LogLevel.Feedback)
End Try End Try
@@ -840,7 +935,7 @@ Public Class FormMain
Return _Hidden Return _Hidden
End Get End Get
Set(value As Boolean) Set(value As Boolean)
If _Hidden = value Then Exit Property If _Hidden = value Then Return
_Hidden = value _Hidden = value
If value Then If value Then
'隐藏 '隐藏
@@ -1103,7 +1198,7 @@ Public Class FormMain
''' 通过点击导航栏改变页面。 ''' 通过点击导航栏改变页面。
''' </summary> ''' </summary>
Private Sub BtnTitleSelect_Click(sender As MyRadioButton, raiseByMouse As Boolean) Handles BtnTitleSelect0.Check, BtnTitleSelect1.Check, BtnTitleSelect2.Check, BtnTitleSelect3.Check, BtnTitleSelect4.Check Private Sub BtnTitleSelect_Click(sender As MyRadioButton, raiseByMouse As Boolean) Handles BtnTitleSelect0.Check, BtnTitleSelect1.Check, BtnTitleSelect2.Check, BtnTitleSelect3.Check, BtnTitleSelect4.Check
If IsChangingPage Then Exit Sub If IsChangingPage Then Return
PageChangeActual(Val(sender.Tag)) PageChangeActual(Val(sender.Tag))
End Sub End Sub
''' <summary> ''' <summary>
@@ -1122,7 +1217,7 @@ Public Class FormMain
''' 切换现有页面的实际方法。 ''' 切换现有页面的实际方法。
''' </summary> ''' </summary>
Private Sub PageChangeActual(Stack As PageStackData, Optional SubType As PageSubType = -1) Private Sub PageChangeActual(Stack As PageStackData, Optional SubType As PageSubType = -1)
If PageCurrent = Stack AndAlso (PageCurrentSub = SubType OrElse SubType = -1) Then Exit Sub If PageCurrent = Stack AndAlso (PageCurrentSub = SubType OrElse SubType = -1) Then Return
AniControlEnabled += 1 AniControlEnabled += 1
Try Try
@@ -1241,14 +1336,14 @@ Public Class FormMain
PanMainLeft.Background = Nothing PanMainLeft.Background = Nothing
AniControlEnabled -= 1 AniControlEnabled -= 1
RunInUi(Sub() PanMainLeft_Resize(PanMainLeft.ActualWidth), True) RunInUi(Sub() PanMainLeft_Resize(PanMainLeft.ActualWidth), True)
End Sub, 130), End Sub, 110),
AaCode( AaCode(
Sub() Sub()
'延迟触发页面通用动画,以使得在 Loaded 事件中加载的控件得以处理 '延迟触发页面通用动画,以使得在 Loaded 事件中加载的控件得以处理
PageLeft.Opacity = 1 PageLeft.Opacity = 1
PageLeft.TriggerShowAnimation() PageLeft.TriggerShowAnimation()
End Sub, 30, True) End Sub, 30, True)
}, "FrmMain PageChangeLeft") }, "FrmMain PageChangeLeft")
AniStart({ AniStart({
AaCode( AaCode(
Sub() Sub()
@@ -1260,14 +1355,14 @@ Public Class FormMain
PanMainRight.Background = Nothing PanMainRight.Background = Nothing
AniControlEnabled -= 1 AniControlEnabled -= 1
RunInUi(Sub() BtnExtraBack.ShowRefresh(), True) RunInUi(Sub() BtnExtraBack.ShowRefresh(), True)
End Sub, 130), End Sub, 110),
AaCode( AaCode(
Sub() Sub()
'延迟触发页面通用动画,以使得在 Loaded 事件中加载的控件得以处理 '延迟触发页面通用动画,以使得在 Loaded 事件中加载的控件得以处理
PageRight.Opacity = 1 PageRight.Opacity = 1
PageRight.PageOnEnter() PageRight.PageOnEnter()
End Sub, 30, True) End Sub, 30, True)
}, "FrmMain PageChangeRight") }, "FrmMain PageChangeRight")
End Sub End Sub
''' <summary> ''' <summary>
''' 退出子界面。 ''' 退出子界面。
@@ -1293,7 +1388,7 @@ Public Class FormMain
'左边栏改变 '左边栏改变
Private Sub PanMainLeft_SizeChanged(sender As Object, e As SizeChangedEventArgs) Handles PanMainLeft.SizeChanged Private Sub PanMainLeft_SizeChanged(sender As Object, e As SizeChangedEventArgs) Handles PanMainLeft.SizeChanged
If Not e.WidthChanged Then Exit Sub If Not e.WidthChanged Then Return
PanMainLeft_Resize(e.NewSize.Width) PanMainLeft_Resize(e.NewSize.Width)
End Sub End Sub
Private Sub PanMainLeft_Resize(NewWidth As Double) Private Sub PanMainLeft_Resize(NewWidth As Double)
@@ -1303,16 +1398,16 @@ Public Class FormMain
If NewWidth > 0 Then If NewWidth > 0 Then
'宽度足够,显示 '宽度足够,显示
AniStart({ AniStart({
AaWidth(RectLeftBackground, NewWidth - RectLeftBackground.Width, 400,, New AniEaseOutFluent(AniEasePower.ExtraStrong)), AaWidth(RectLeftBackground, NewWidth - RectLeftBackground.Width, 180,, New AniEaseOutFluent(AniEasePower.ExtraStrong)),
AaOpacity(RectLeftShadow, 1 - RectLeftShadow.Opacity, 200), AaOpacity(RectLeftShadow, 1 - RectLeftShadow.Opacity, 180),
AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 250) AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 150)
}, "FrmMain LeftChange", True) }, "FrmMain LeftChange", True)
Else Else
'宽度不足,隐藏 '宽度不足,隐藏
AniStart({ AniStart({
AaWidth(RectLeftBackground, -RectLeftBackground.Width, 200,, New AniEaseOutFluent), AaWidth(RectLeftBackground, -RectLeftBackground.Width, 180,, New AniEaseOutFluent),
AaOpacity(RectLeftShadow, -RectLeftShadow.Opacity, 200), AaOpacity(RectLeftShadow, -RectLeftShadow.Opacity, 180),
AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 170) AaCode(Sub() PanMainLeft.IsHitTestVisible = True, 150)
}, "FrmMain LeftChange", True) }, "FrmMain LeftChange", True)
End If End If
Else Else
@@ -1328,14 +1423,14 @@ Public Class FormMain
'在时钟中调用,使得即使鼠标在窗口外松开,也可以释放控件 '在时钟中调用,使得即使鼠标在窗口外松开,也可以释放控件
Public Sub DragTick() Public Sub DragTick()
If DragControl Is Nothing Then Exit Sub If DragControl Is Nothing Then Return
If Not Mouse.LeftButton = MouseButtonState.Pressed Then If Not Mouse.LeftButton = MouseButtonState.Pressed Then
DragStop() DragStop()
End If End If
End Sub End Sub
'在鼠标移动时调用,以改变 Slider 位置 '在鼠标移动时调用,以改变 Slider 位置
Public Sub DragDoing() Handles PanBack.MouseMove Public Sub DragDoing() Handles PanBack.MouseMove
If DragControl Is Nothing Then Exit Sub If DragControl Is Nothing Then Return
If Mouse.LeftButton = MouseButtonState.Pressed Then If Mouse.LeftButton = MouseButtonState.Pressed Then
DragControl.DragDoing() DragControl.DragDoing()
Else Else
@@ -1345,7 +1440,7 @@ Public Class FormMain
Public Sub DragStop() Public Sub DragStop()
'存在其他线程调用的可能性,因此需要确保在 UI 线程运行 '存在其他线程调用的可能性,因此需要确保在 UI 线程运行
RunInUi(Sub() RunInUi(Sub()
If DragControl Is Nothing Then Exit Sub If DragControl Is Nothing Then Return
Dim Control = DragControl Dim Control = DragControl
DragControl = Nothing DragControl = Nothing
Control.DragStop() '控件会在该事件中判断 DragControl,所以得放在后面 Control.DragStop() '控件会在该事件中判断 DragControl,所以得放在后面
@@ -624,6 +624,26 @@ Public Module ModAnimation
Return Ease.GetValue(t) Return Ease.GetValue(t)
End Function End Function
End Class 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 / 回弹 'Back / 回弹
''' <summary> ''' <summary>
@@ -807,7 +827,7 @@ Sleeper:
Thread.Sleep(1) Thread.Sleep(1)
Loop Loop
Catch ex As Exception Catch ex As Exception
Log(ex, "动画帧执行失败", LogLevel.Assert) Log(ex, "动画帧执行失败", LogLevel.Critical)
End Try End Try
End Sub, "Animation", ThreadPriority.AboveNormal) End Sub, "Animation", ThreadPriority.AboveNormal)
End Sub End Sub
+124 -107
View File
@@ -1,6 +1,6 @@
Imports System.Globalization Imports System.Globalization
Imports System.IO.Compression Imports System.IO.Compression
Imports System.Reflection Imports System.Net.Sockets
Imports System.Runtime.CompilerServices Imports System.Runtime.CompilerServices
Imports System.Security.Cryptography Imports System.Security.Cryptography
Imports System.Security.Principal Imports System.Security.Principal
@@ -13,13 +13,13 @@ Public Module ModBase
#Region "声明" #Region "声明"
'下列版本信息由更新器自动修改 '下列版本信息由更新器自动修改
Public Const VersionBaseName As String = "2.10.0" '不含分支前缀的显示用版本名 Public Const VersionBaseName As String = "2.10.6" '不含分支前缀的显示用版本名
Public Const VersionStandardCode As String = "2.10.0." & VersionBranchCode '标准格式的四段式版本号 Public Const VersionStandardCode As String = "2.10.6." & VersionBranchCode '标准格式的四段式版本号
Public Const CommitHash As String = "" 'Commit Hash,由 GitHub Workflow 自动替换 Public Const CommitHash As String = "" 'Commit Hash,由 GitHub Workflow 自动替换
#If BETA Then #If BETA Then
Public Const VersionCode As Integer = 357 'Release Public Const VersionCode As Integer = 367 'Release
#Else #Else
Public Const VersionCode As Integer = 356 'Snapshot Public Const VersionCode As Integer = 366 'Snapshot
#End If #End If
'自动生成的版本信息 '自动生成的版本信息
Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
@@ -785,13 +785,16 @@ Public Module ModBase
End Function End Function
'读取、写入、复制文件 '读取、写入、复制文件
''' <summary>
''' 复制文件。会自动创建文件夹、会覆盖已有的文件。
''' </summary>
Public Sub CopyFile(FromPath As String, ToPath As String) Public Sub CopyFile(FromPath As String, ToPath As String)
Try Try
'还原文件路径 '还原文件路径
If Not FromPath.Contains(":\") Then FromPath = Path & FromPath FromPath = ShortenPath(If(FromPath.Contains(":\"), FromPath, Path & FromPath))
If Not ToPath.Contains(":\") Then ToPath = Path & ToPath ToPath = ShortenPath(If(ToPath.Contains(":\"), ToPath, Path & ToPath))
'如果复制同一个文件则跳过 '如果复制同一个文件则跳过
If FromPath = ToPath Then Exit Sub If FromPath = ToPath Then Return
'确保目录存在 '确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(ToPath)) Directory.CreateDirectory(GetPathFromFullPath(ToPath))
'复制文件 '复制文件
@@ -803,7 +806,6 @@ Public Module ModBase
''' <summary> ''' <summary>
''' 读取文件,如果失败则返回空数组。 ''' 读取文件,如果失败则返回空数组。
''' </summary> ''' </summary>
''' <param name="FilePath">文件完整或相对路径。</param>
Public Function ReadFileBytes(FilePath As String, Optional Encoding As Encoding = Nothing) As Byte() Public Function ReadFileBytes(FilePath As String, Optional Encoding As Encoding = Nothing) As Byte()
Try Try
'还原文件路径 '还原文件路径
@@ -859,7 +861,7 @@ Public Module ModBase
''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param> ''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
Public Sub WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing) 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 = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath))
'确保目录存在 '确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath)) Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件 '写入文件
@@ -884,7 +886,7 @@ Public Module ModBase
''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param> ''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) Public Sub WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False)
'处理相对路径 '处理相对路径
If Not FilePath.Contains(":\") Then FilePath = Path & FilePath FilePath = ShortenPath(If(FilePath.Contains(":\"), FilePath, Path & FilePath))
'确保目录存在 '确保目录存在
Directory.CreateDirectory(GetPathFromFullPath(FilePath)) Directory.CreateDirectory(GetPathFromFullPath(FilePath))
'写入文件 '写入文件
@@ -1292,11 +1294,11 @@ Re:
''' </summary> ''' </summary>
Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing, Public Sub ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing,
Optional ProgressIncrementHandler As Action(Of Double) = Nothing) Optional ProgressIncrementHandler As Action(Of Double) = Nothing)
Directory.CreateDirectory(DestDirectory) Directory.CreateDirectory(ShortenPath(DestDirectory))
If CompressFilePath.EndsWithF(".gz", True) Then If CompressFilePath.EndsWithF(".gz", True) Then
'以 gz 方式解压 '以 gz 方式解压
Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress) Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress)
Dim decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", ""), FileMode.OpenOrCreate, FileAccess.Write) Dim decompressedFile As New FileStream(ShortenPath(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", "")), FileMode.OpenOrCreate, FileAccess.Write)
Dim data As Integer = stream.ReadByte() Dim data As Integer = stream.ReadByte()
While data <> -1 While data <> -1
decompressedFile.WriteByte(data) decompressedFile.WriteByte(data)
@@ -1307,10 +1309,10 @@ Re:
Else Else
'以 zip 方式解压 '以 zip 方式解压
Using Archive = ZipFile.Open(CompressFilePath, ZipArchiveMode.Read, If(Encode, Encoding.GetEncoding("GB18030"))) 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 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) Dim DestinationPath As String = ShortenPath(IO.Path.Combine(DestDirectory, Entry.FullName))
If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then If DestinationPath.EndsWithF("\") OrElse DestinationPath.EndsWithF("/") Then
Continue For '不创建空文件夹 Continue For '不创建空文件夹
Else Else
@@ -1363,7 +1365,7 @@ RetryDir:
Try Try
Directory.Delete(Path, True) Directory.Delete(Path, True)
Catch ex As Exception Catch ex As Exception
If Not RetriedDir Then If Not RetriedDir AndAlso Not RunInUi() Then
RetriedDir = True RetriedDir = True
Log(ex, $"删除文件夹失败,将在 0.3s 后重试({Path})") Log(ex, $"删除文件夹失败,将在 0.3s 后重试({Path})")
Thread.Sleep(300) Thread.Sleep(300)
@@ -1385,10 +1387,10 @@ RetryDir:
ToPath = ToPath.Replace("/", "\") ToPath = ToPath.Replace("/", "\")
If Not ToPath.EndsWithF("\") Then ToPath &= "\" If Not ToPath.EndsWithF("\") Then ToPath &= "\"
Dim AllFiles = EnumerateFiles(FromPath).ToList Dim AllFiles = EnumerateFiles(FromPath).ToList
Dim FileCount As Integer = AllFiles.Count Dim FileCount As Long = AllFiles.Count
For Each File In AllFiles For Each File In AllFiles
CopyFile(File.FullName, File.FullName.Replace(FromPath, ToPath)) 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 Next
End Sub End Sub
''' <summary> ''' <summary>
@@ -1447,22 +1449,8 @@ RetryDir:
IsInner = True IsInner = True
Loop 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
'构造输出信息 '构造输出信息
Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList)
If CommonReason Is Nothing Then If CommonReason Is Nothing Then
Return DescList.Join(vbCrLf) Return DescList.Join(vbCrLf)
Else Else
@@ -1490,22 +1478,8 @@ RetryDir:
DescList = DescList.Distinct.ToList DescList = DescList.Distinct.ToList
Dim Desc As String = Join(DescList, vbCrLf & "→ ") 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
'构造输出信息 '构造输出信息
Dim CommonReason As String = AnalyzeCommonReason(InnerEx, DescList)
If CommonReason IsNot Nothing Then If CommonReason IsNot Nothing Then
Return CommonReason & "详细错误:" & DescList.First Return CommonReason & "详细错误:" & DescList.First
Else Else
@@ -1513,6 +1487,24 @@ RetryDir:
Return Join(DescList, " ← ") Return Join(DescList, " ← ")
End If End If
End Function End Function
Private Function AnalyzeCommonReason(InnerEx 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 {"远程主机强迫关闭了", "远程方已关闭传输流", "未能解析此远程名称", "由于目标计算机积极拒绝",
"操作已超时", "操作超时", "服务器超时", "连接超时"}.Any(Function(s) DescList.Any(Function(l) l.Contains(s))) Then
Return "你的网络环境不佳,导致难以连接到服务器。请稍后重试,或使用 VPN 以改善网络环境。"
Else
Return Nothing
End If
End Function
''' <summary> ''' <summary>
''' 返回一个枚举对应的字符串。 ''' 返回一个枚举对应的字符串。
@@ -1549,12 +1541,12 @@ RetryDir:
''' <summary> ''' <summary>
''' 获取 JSON 对象。 ''' 获取 JSON 对象。
''' </summary> ''' </summary>
Public Function GetJson(Data As String) Public Function GetJson(Data As String) As JToken
Try Try
Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local}) Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local})
Catch ex As Exception Catch ex As Exception
Dim Length As Integer = If(Data, "").Length 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 Try
End Function End Function
@@ -1981,8 +1973,8 @@ RetryDir:
#Region "系统" #Region "系统"
''' <summary> ''' <summary>
''' 线程安全的,可以直接使用 For Each 的 List。 ''' 线程安全的 List。
''' 在使用 For Each 循环时,列表的结果可能并非最新,但不会抛出异常。 ''' 通过在 For Each 循环中使用一个浅表副本规避多线程操作或移除自身导致的异常。
''' </summary> ''' </summary>
Public Class SafeList(Of T) Public Class SafeList(Of T)
Inherits SynchronizedCollection(Of T) Inherits SynchronizedCollection(Of T)
@@ -2014,8 +2006,8 @@ RetryDir:
End Class End Class
''' <summary> ''' <summary>
''' 线程安全的,可以直接使用 For Each 的字典。 ''' 线程安全的字典。
''' 在使用 For Each 循环时,字典的结果可能并非最新,但不会抛出异常。 ''' 通过在 For Each 循环中使用一个浅表副本规避多线程操作或移除自身导致的异常。
''' </summary> ''' </summary>
Public Class SafeDictionary(Of TKey, TValue) Public Class SafeDictionary(Of TKey, TValue)
Implements IDictionary(Of TKey, TValue) Implements IDictionary(Of TKey, TValue)
@@ -2129,6 +2121,19 @@ RetryDir:
End Function End Function
End Class 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>
''' 可用于临时存放文件的,不含任何特殊字符的文件夹路径,以“\”结尾。 ''' 可用于临时存放文件的,不含任何特殊字符的文件夹路径,以“\”结尾。
''' </summary> ''' </summary>
@@ -2177,10 +2182,10 @@ RetryDir:
End Function End Function
''' <summary> ''' <summary>
''' 判断当前系统语言是否为 zh-CN。 ''' 判断当前系统语言是否为中文。
''' </summary> ''' </summary>
Public Function IsSystemLanguageChinese() As Boolean 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 End Function
Private Uuid As Integer = 1 Private Uuid As Integer = 1
@@ -2223,6 +2228,9 @@ NextElement:
Next i Next i
Return ResultArray Return ResultArray
End Function End Function
<Extension> Public Function Any(Arr As UIElementCollection) As Boolean
Return Arr?.Count > 0
End Function
''' <summary> ''' <summary>
''' 获取格式类似于“11:08:52.037”的当前时间的字符串。 ''' 获取格式类似于“11:08:52.037”的当前时间的字符串。
@@ -2460,7 +2468,7 @@ NextElement:
''' </summary> ''' </summary>
Public Sub RunInThread(Action As Action) Public Sub RunInThread(Action As Action)
If RunInUi() Then If RunInUi() Then
RunInNewThread(Action, "Runtime Invoke " & GetUuid() & "#") RunInNewThread(Action, "Invoke " & GetUuid())
Else Else
Action() Action()
End If End If
@@ -2623,10 +2631,6 @@ Retry:
''' 相对增减控件的左边距。 ''' 相对增减控件的左边距。
''' </summary> ''' </summary>
Public Sub DeltaLeft(control As FrameworkElement, newValue As Double) 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 If TypeOf control Is Window Then
'窗口改变 '窗口改变
CType(control, Window).Left += newValue CType(control, Window).Left += newValue
@@ -2638,8 +2642,6 @@ Retry:
Case HorizontalAlignment.Right 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, 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) '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 Select
End If End If
End Sub End Sub
@@ -2647,17 +2649,12 @@ Retry:
''' 设置控件的左边距。(仅针对置左控件) ''' 设置控件的左边距。(仅针对置左控件)
''' </summary> ''' </summary>
Public Sub SetLeft(control As FrameworkElement, newValue As Double) 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) control.Margin = New Thickness(newValue, control.Margin.Top, control.Margin.Right, control.Margin.Bottom)
End Sub End Sub
''' <summary> ''' <summary>
''' 相对增减控件的上边距。 ''' 相对增减控件的上边距。
''' </summary> ''' </summary>
Public Sub DeltaTop(control As FrameworkElement, newValue As Double) 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 If TypeOf control Is Window Then
'窗口改变 '窗口改变
CType(control, Window).Top += newValue CType(control, Window).Top += newValue
@@ -2669,12 +2666,9 @@ Retry:
Case VerticalAlignment.Bottom 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, 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) '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 Select
End If End If
'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Return '安全性检查
'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Exit Sub '安全性检查
'Select Case control.VerticalAlignment 'Select Case control.VerticalAlignment
' Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center ' Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center
' control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom) ' control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
@@ -2687,7 +2681,6 @@ Retry:
''' 设置控件的顶边距。(仅针对置上控件) ''' 设置控件的顶边距。(仅针对置上控件)
''' </summary> ''' </summary>
Public Sub SetTop(control As FrameworkElement, newValue As Double) 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) control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
End Sub End Sub
@@ -2758,11 +2751,11 @@ Retry:
Using Reader As New XamlXmlReader(Stream) Using Reader As New XamlXmlReader(Stream)
While Reader.Read() While Reader.Read()
For Each BlackListType In {GetType(WebBrowser), GetType(Frame), GetType(MediaElement), GetType(ObjectDataProvider), GetType(XamlReader), GetType(Window), GetType(XmlDataProvider)} 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.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.Value IsNot Nothing AndAlso Reader.Value = BlackListType.Name Then Throw New UnauthorizedAccessException($"基于安全考虑,不允许使用 {BlackListType.Name} 值。")
Next Next
For Each BlackListMember In {"Code", "FactoryMethod", "Static"} 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 Next
End While End While
End Using End Using
@@ -2847,9 +2840,10 @@ Retry:
''' </summary> ''' </summary>
Feedback = 5 Feedback = 5
''' <summary> ''' <summary>
''' 弹窗,结束程序。 ''' 弹出 Windows 原生弹窗,要求反馈。在无法保证 WPF 窗口能正常运行时使用此级别。
''' 在第二次触发后会直接结束程序。
''' </summary> ''' </summary>
Assert = 6 Critical = 6
End Enum End Enum
Private LogList As New StringBuilder Private LogList As New StringBuilder
Private LogWritter As StreamWriter Private LogWritter As StreamWriter
@@ -2892,7 +2886,7 @@ Retry:
Private ReadOnly LogFlushLock As New Object '防止外部调用 LogFlush 时同时输出多次日志 Private ReadOnly LogFlushLock As New Object '防止外部调用 LogFlush 时同时输出多次日志
Public Sub LogFlush() Public Sub LogFlush()
On Error Resume Next On Error Resume Next
If LogWritter Is Nothing Then Exit Sub If LogWritter Is Nothing Then Return
Dim Log As String = Nothing Dim Log As String = Nothing
SyncLock LogFlushLock SyncLock LogFlushLock
If LogList.Length > 0 Then If LogList.Length > 0 Then
@@ -2908,6 +2902,7 @@ Retry:
End Sub End Sub
Private ReadOnly LogListLock As New Object '防止日志乱码,只在调试模式下启用 Private ReadOnly LogListLock As New Object '防止日志乱码,只在调试模式下启用
Private IsCriticalErrorTriggered As Boolean = False
''' <summary> ''' <summary>
''' 输出 Log。 ''' 输出 Log。
''' </summary> ''' </summary>
@@ -2918,7 +2913,7 @@ Retry:
'处理错误会导致再次调用 Log() 导致无限循环 '处理错误会导致再次调用 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 If ModeDebug Then
SyncLock LogListLock SyncLock LogListLock
LogList.Append(AppendText) LogList.Append(AppendText)
@@ -2929,7 +2924,7 @@ Retry:
#If DEBUG Then #If DEBUG Then
Console.Write(AppendText) Console.Write(AppendText)
#End If #End If
If IsProgramEnded OrElse Level = LogLevel.Normal Then Exit Sub If IsProgramEnded OrElse Level = LogLevel.Normal Then Return
'去除前缀 '去除前缀
Text = Text.RegexReplace("\[[^\]]+?\] ", "") Text = Text.RegexReplace("\[[^\]]+?\] ", "")
@@ -2956,22 +2951,26 @@ Retry:
Else Else
MyMsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True) MyMsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True)
End If End If
Case LogLevel.Assert Case LogLevel.Critical
Dim Time As Long = GetTimeTick() If IsCriticalErrorTriggered Then
FormMain.EndProgramForce(ProcessReturnValues.Exception)
Return
End If
IsCriticalErrorTriggered = True
If CanFeedback(False) Then If CanFeedback(False) Then
If MsgBox(Text & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True) If MsgBox(Text & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True)
Else Else
MsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title) MsgBox(Text & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title)
End If 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 End Select
'上报
If Level >= LogLevel.Hint Then
Telemetry("PCL 错误",
"Level", GetStringFromEnum(Level),
"Title", FilterUserName(FilterAccessToken(Title, "*"), "*"),
"Exception", FilterUserName(FilterAccessToken(Text, "*"), "*"))
End If
End Sub End Sub
''' <summary> ''' <summary>
''' 输出错误信息。 ''' 输出错误信息。
@@ -2979,13 +2978,13 @@ Retry:
''' <param name="Desc">错误描述。会在处理时在末尾加入冒号。</param> ''' <param name="Desc">错误描述。会在处理时在末尾加入冒号。</param>
Public Sub Log(Ex As Exception, Desc As String, Optional Level As LogLevel = LogLevel.Debug, Optional Title As String = "出现错误") Public Sub Log(Ex As Exception, Desc As String, Optional Level As LogLevel = LogLevel.Debug, Optional Title As String = "出现错误")
On Error Resume Next 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 & ":" & GetExceptionDetail(Ex)
'输出日志 '输出日志
Dim AppendText As String = "[" & GetTimeNow() & "] " & Desc & ":" & GetExceptionDetail(Ex, True) & vbCrLf '减轻同步锁占用 Dim AppendText As String = $"[{GetTimeNow()}] <{If(Thread.CurrentThread.Name = "", "主线程", Thread.CurrentThread.Name)}> {Desc}:{GetExceptionDetail(Ex, True)}{vbCrLf}" '减轻同步锁占用
If ModeDebug Then If ModeDebug Then
SyncLock LogListLock SyncLock LogListLock
LogList.Append(AppendText) LogList.Append(AppendText)
@@ -2996,7 +2995,7 @@ Retry:
#If DEBUG Then #If DEBUG Then
Console.Write(AppendText) Console.Write(AppendText)
#End If #End If
If IsProgramEnded Then Exit Sub If IsProgramEnded Then Return
'输出提示 '输出提示
Select Case Level Select Case Level
@@ -3025,22 +3024,26 @@ Retry:
Else Else
MyMsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True) MyMsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", Title, IsWarn:=True)
End If End If
Case LogLevel.Assert Case LogLevel.Critical
Dim Time As Long = GetTimeTick() If IsCriticalErrorTriggered Then
FormMain.EndProgramForce(ProcessReturnValues.Exception)
Return
End If
IsCriticalErrorTriggered = True
If CanFeedback(False) Then If CanFeedback(False) Then
If MsgBox(ExFull & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True) If MsgBox(ExFull & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback(False, True)
Else Else
MsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title) MsgBox(ExFull & vbCrLf & vbCrLf & "将 PCL 更新至最新版或许可以解决这个问题……", MsgBoxStyle.Critical, Title)
End If 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 End Select
'上报
If Level >= LogLevel.Hint Then
Telemetry("PCL 异常",
"Level", GetStringFromEnum(Level),
"Title", FilterUserName(FilterAccessToken(Title, "*"), "*"),
"Exception", FilterUserName(FilterAccessToken(ExFull, "*"), "*"))
End If
End Sub End Sub
'反馈 '反馈
@@ -3050,7 +3053,7 @@ Retry:
If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug,请点击 打开文件夹 按钮,并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关,请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug,请点击 打开文件夹 按钮,并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关,请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then
OpenExplorer(Path & "PCL\Log1.txt") OpenExplorer(Path & "PCL\Log1.txt")
End If End If
OpenWebsite("https://github.com/Hex-Dragon/PCL2/issues/") OpenWebsite("https://github.com/Meloong-Git/PCL/issues/")
End Sub End Sub
Public Function CanFeedback(ShowHint As Boolean) As Boolean Public Function CanFeedback(ShowHint As Boolean) As Boolean
If False.Equals(PageSetupSystem.IsLauncherNewest) Then If False.Equals(PageSetupSystem.IsLauncherNewest) Then
@@ -3077,9 +3080,23 @@ Retry:
"文件位置:" & Path) "文件位置:" & Path)
End Sub End Sub
'断言 '遥测
Public Sub DebugAssert(Exp As Boolean) Public Sub Telemetry([Event] As String, ParamArray Datas As String())
If Not Exp Then Throw New Exception("断言命中") 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
Log("[System] 匿名数据上报失败", LogLevel.Debug)
End Try
End Sub, "Telemetry", ThreadPriority.Lowest)
End Sub End Sub
'获取当前的堆栈信息 '获取当前的堆栈信息
@@ -85,7 +85,7 @@
Return _State Return _State
End Get End Get
Set(value As LoadState) Set(value As LoadState)
If _State = value Then Exit Property If _State = value Then Return
Dim OldState = _State Dim OldState = _State
If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000)) If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000))
_State = value _State = value
@@ -112,7 +112,7 @@
Return _LoadingState Return _LoadingState
End Get End Get
Set(value As MyLoading.MyLoadingState) Set(value As MyLoading.MyLoadingState)
If _LoadingState = value Then Exit Property If _LoadingState = value Then Return
Dim OldState = _LoadingState Dim OldState = _LoadingState
_LoadingState = value _LoadingState = value
RaiseEvent LoadingStateChanged(value, OldState) RaiseEvent LoadingStateChanged(value, OldState)
@@ -154,7 +154,7 @@
End Select End Select
End Get End Get
Set(value As Double) Set(value As Double)
If _Progress = value Then Exit Property If _Progress = value Then Return
Dim OldValue = _Progress Dim OldValue = _Progress
_Progress = value _Progress = value
RaiseEvent ProgressChanged(value, OldValue) RaiseEvent ProgressChanged(value, OldValue)
@@ -184,7 +184,7 @@
Thread.Sleep(10) Thread.Sleep(10)
Loop Loop
If State = LoadState.Finished Then If State = LoadState.Finished Then
Exit Sub Return
ElseIf State = LoadState.Aborted Then ElseIf State = LoadState.Aborted Then
Throw New ThreadInterruptedException("加载器执行已中断。") Throw New ThreadInterruptedException("加载器执行已中断。")
ElseIf IsNothing([Error]) Then ElseIf IsNothing([Error]) Then
@@ -207,7 +207,7 @@
If Timeout < 0 Then Throw New TimeoutException(TimeoutMessage) If Timeout < 0 Then Throw New TimeoutException(TimeoutMessage)
Loop Loop
If State = LoadState.Finished Then If State = LoadState.Finished Then
Exit Sub Return
ElseIf State = LoadState.Aborted Then ElseIf State = LoadState.Aborted Then
Throw New ThreadInterruptedException("加载器执行已中断。") Throw New ThreadInterruptedException("加载器执行已中断。")
ElseIf IsNothing([Error]) Then ElseIf IsNothing([Error]) Then
@@ -308,48 +308,49 @@
Progress = -1 Progress = -1
End SyncLock End SyncLock
Else Else
Exit Sub Return
End If End If
LastRunningThread = New Thread( LastRunningThread = New Thread(
Sub() Sub()
Try Try
IsForceRestarting = IsForceRestart IsForceRestarting = IsForceRestart
If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动") If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已{If(IsForceRestarting, "强制", "")}启动")
LoadDelegate(Me) LoadDelegate(Me)
If IsAborted Then If IsAborted Then
Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束,输出被弃用(最新线程:{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)})", LogLevel.Developer) Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已中断但线程正常运行至结束,输出被弃用(最新线程:{If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId)})", LogLevel.Developer)
Else Return
RaisePreviewFinish() End If
State = LoadState.Finished If ModeDebug Then Log($"[Loader] 加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已完成")
LastFinishedTime = GetTimeTick() '未中断,本次输出有效 RaisePreviewFinish()
End If State = LoadState.Finished
Catch ex As CancelledException LastFinishedTime = GetTimeTick() '未中断,本次输出有效
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断,已完成 {Math.Round(Progress * 100)}%") Catch ex As CancelledException
If Not IsAborted Then State = LoadState.Aborted If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发取消中断,已完成 {Math.Round(Progress * 100)}%")
Catch ex As ThreadInterruptedException If Not IsAborted Then State = LoadState.Aborted
If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断,已完成 {Math.Round(Progress * 100)}%") Catch ex As ThreadInterruptedException
'如果线程是因为判断到 IsAborted 而提前中止,则代表已有新线程被重启,此时不应当改为 Aborted If ModeDebug Then Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 已触发线程中断,已完成 {Math.Round(Progress * 100)}%")
'如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException,则代表没有重启线程,这通常代表用户手动取消,应当改为 Aborted '如果线程是因为判断到 IsAborted 而提前中止,则代表已有新线程被重启,此时不应当改为 Aborted
If Not IsAborted Then State = LoadState.Aborted '如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException,则代表没有重启线程,这通常代表用户手动取消,应当改为 Aborted
Catch ex As Exception If Not IsAborted Then State = LoadState.Aborted
If IsAborted Then Exit Sub Catch ex As Exception
Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错,已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer) If IsAborted Then Return
[Error] = ex Log(ex, $"加载线程 {Name} ({Thread.CurrentThread.ManagedThreadId}) 出错,已完成 {Math.Round(Progress * 100)}%", LogLevel.Developer)
State = LoadState.Failed [Error] = ex
End Try State = LoadState.Failed
End Sub) With {.Name = Name, .Priority = ThreadPriority} End Try
End Sub) With {.Name = "L/" & Name, .Priority = ThreadPriority}
LastRunningThread.Start() '不能使用 RunInNewThread,否则在函数返回前线程就会运行完,导致误判 IsAborted LastRunningThread.Start() '不能使用 RunInNewThread,否则在函数返回前线程就会运行完,导致误判 IsAborted
End Sub End Sub
Public Overrides Sub Abort() Public Overrides Sub Abort()
If State <> LoadState.Loading Then Exit Sub If State <> LoadState.Loading Then Return
SyncLock LockState SyncLock LockState
State = LoadState.Aborted State = LoadState.Aborted
End SyncLock End SyncLock
TriggerThreadAbort() TriggerThreadAbort()
End Sub End Sub
Private Sub TriggerThreadAbort() 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 ModeDebug Then Log($"[Loader] 加载线程 {Name} ({LastRunningThread.ManagedThreadId}) 已中断")
If LastRunningThread.IsAlive Then LastRunningThread.Interrupt() If LastRunningThread.IsAlive Then LastRunningThread.Interrupt()
LastRunningThread = Nothing LastRunningThread = Nothing
@@ -419,7 +420,7 @@
'改变状态 '改变状态
SyncLock LockState SyncLock LockState
If State = LoadState.Loading Then If State = LoadState.Loading Then
Exit Sub Return
Else Else
State = LoadState.Loading State = LoadState.Loading
End If End If
@@ -439,7 +440,7 @@
If State = LoadState.Loading OrElse State = LoadState.Waiting Then If State = LoadState.Loading OrElse State = LoadState.Waiting Then
State = LoadState.Aborted State = LoadState.Aborted
Else Else
Exit Sub Return
End If End If
End SyncLock End SyncLock
RunInThread( RunInThread(
@@ -470,7 +471,7 @@
Case Else Case Else
'完蛋,出错了 '完蛋,出错了
SyncLock LockState SyncLock LockState
If State >= LoadState.Finished Then Exit Sub If State >= LoadState.Finished Then Return
[Error] = New Exception(Loader.Name & "失败", Loader.Error) [Error] = New Exception(Loader.Name & "失败", Loader.Error)
State = Loader.State State = Loader.State
End SyncLock End SyncLock
@@ -478,14 +479,14 @@
Loader.Abort() Loader.Abort()
Next Next
FrmMain.BtnExtraDownload.ShowRefresh() FrmMain.BtnExtraDownload.ShowRefresh()
Exit Sub Return
End Select End Select
End Sub End Sub
''' <summary> ''' <summary>
''' 触发一次更新,以启动新加载器或完成。 ''' 触发一次更新,以启动新加载器或完成。
''' </summary> ''' </summary>
Private Sub Update() 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 IsFinished As Boolean = True
Dim Blocked As Boolean = False Dim Blocked As Boolean = False
Dim Input As Object = Me.Input Dim Input As Object = Me.Input
@@ -584,16 +585,11 @@ Restart:
Try Try
Dim NewState As Shell.TaskbarItemProgressState Dim NewState As Shell.TaskbarItemProgressState
Dim NewProgress As Double = LoaderTaskbarProgressGet() Dim NewProgress As Double = LoaderTaskbarProgressGet()
'检查任务是否完成,若完成则移除 '若单个任务已中止,或全部任务已完成,则刷新并移除
'外显任务是否已经全部完成 For Each Task In LoaderTaskbar
Dim IsAllDownloadTaskCompleted As Boolean = True If LoaderTaskbar.All(Function(l) l.State <> LoadState.Loading) OrElse
For Each Loader In LoaderTaskbar.ToList() (Task.State = LoadState.Waiting OrElse Task.State = LoadState.Aborted) Then
If Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False FrmSpeedLeft?.TaskRefresh(Task)
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)
LoaderTaskbar.Remove(Task) LoaderTaskbar.Remove(Task)
Log($"[Taskbar] {Task.Name} 已移出任务列表") Log($"[Taskbar] {Task.Name} 已移出任务列表")
End If End If
@@ -625,8 +621,8 @@ Restart:
End Sub End Sub
Public Function LoaderTaskbarProgressGet() As Double Public Function LoaderTaskbarProgressGet() As Double
Try Try
If Not LoaderTaskbar.Where(Function(l) l.Show).Any Then Return 1 If Not LoaderTaskbar.Any Then Return 1
Return MathClamp(LoaderTaskbar.Where(Function(l) l.Show).Select(Function(l) l.Progress).Average(), 0, 1) Return MathClamp(LoaderTaskbar.Select(Function(l) l.Progress).Average(), 0, 1)
Catch ex As Exception Catch ex As Exception
Log(ex, "获取任务栏进度出错", LogLevel.Feedback) Log(ex, "获取任务栏进度出错", LogLevel.Feedback)
Return 0.5 Return 0.5
File diff suppressed because it is too large Load Diff
@@ -78,8 +78,8 @@
If SplitedLine.Count >= 2 Then If SplitedLine.Count >= 2 Then
Entry.ChineseName = SplitedLine(1) Entry.ChineseName = SplitedLine(1)
If Entry.ChineseName.Contains("*") Then '处理 * If Entry.ChineseName.Contains("*") Then '处理 *
Entry.ChineseName = Entry.ChineseName.Replace("*", " (" & 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))) & ")") $" ({If(Entry.CurseForgeSlug, Entry.ModrinthSlug).Replace("-", " ").Capitalize})")
End If End If
End If End If
_CompDatabase.Add(Entry) _CompDatabase.Add(Entry)
@@ -491,6 +491,9 @@
Case "path-tracing" : Tags.Add("路径追踪") Case "path-tracing" : Tags.Add("路径追踪")
Case "pbr" : Tags.Add("PBR") Case "pbr" : Tags.Add("PBR")
Case "reflections" : Tags.Add("反射") Case "reflections" : Tags.Add("反射")
Case "iris" : Tags.Add("Iris")
Case "optifine" : Tags.Add("OptiFine")
Case "vanilla" : Tags.Add("原版可用") Case "vanilla" : Tags.Add("原版可用")
End Select End Select
Next Next
@@ -947,38 +950,39 @@ NoSubtitle:
''' 根据搜索请求获取一系列的工程列表。需要基于加载器运行。 ''' 根据搜索请求获取一系列的工程列表。需要基于加载器运行。
''' </summary> ''' </summary>
Public Sub CompProjectsGet(Task As LoaderTask(Of CompProjectRequest, Integer)) 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 If Request.Storage.Results.Count >= Request.TargetResultCount Then
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果,多于所需的 {Task.Input.TargetResultCount} 个结果,结束处理") Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果,多于所需的 {Request.TargetResultCount} 个结果,结束处理")
Exit Sub Return
ElseIf Not Task.Input.CanContinue Then ElseIf Not Request.CanContinue Then
If Not Task.Input.Storage.Results.Any() Then If Not Request.Storage.Results.Any() Then
Throw New Exception("没有符合条件的结果") Throw New Exception("没有符合条件的结果")
Else Else
Log($"[Comp] 已有 {Task.Input.Storage.Results.Count} 个结果,少于所需的 {Task.Input.TargetResultCount} 个结果,但无法继续获取,结束处理") Log($"[Comp] 已有 {Request.Storage.Results.Count} 个结果,少于所需的 {Request.TargetResultCount} 个结果,但无法继续获取,结束处理")
Exit Sub Return
End If End If
End If End If
#Region "拒绝 1.13- Quilt(这个版本根本没有 Quilt)" #Region "拒绝 1.13- Quilt(这个版本根本没有 Quilt)"
If Task.Input.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Task.Input.GameVersion, "1.15"), "1.14") = -1 Then If Request.ModLoader = CompModLoaderType.Quilt AndAlso VersionSortInteger(If(Request.GameVersion, "1.15"), "1.14") = -1 Then
Throw New Exception("Quilt 不支持 Minecraft " & Task.Input.GameVersion) Throw New Exception("Quilt 不支持 Minecraft " & Request.GameVersion)
End If End If
#End Region #End Region
#Region "处理搜索文本,赋值回 Task.Input.SearchText" #Region "处理搜索文本,赋值回 Task.Input.SearchText"
Dim RawFilter As String = If(Task.Input.SearchText, "").Trim Dim RawFilter As String = If(Request.SearchText, "").Trim
Task.Input.SearchText = RawFilter Request.SearchText = RawFilter
RawFilter = RawFilter.ToLower RawFilter = RawFilter.ToLower
Log("[Comp] 工程列表搜索原始文本:" & RawFilter) Log("[Comp] 工程列表搜索原始文本:" & RawFilter)
'中文请求关键字处理 '中文请求关键字处理
Dim IsChineseSearch As Boolean = RegexCheck(RawFilter, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawFilter) Dim IsChineseSearch As Boolean = RegexCheck(RawFilter, "[\u4e00-\u9fbb]") AndAlso Not String.IsNullOrEmpty(RawFilter)
If IsChineseSearch AndAlso (Task.Input.Type = CompType.Mod OrElse Task.Input.Type = CompType.DataPack) Then If IsChineseSearch AndAlso (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then
'构造搜索请求 '构造搜索请求
Dim SearchEntries As New List(Of SearchEntry(Of CompDatabaseEntry)) Dim SearchEntries As New List(Of SearchEntry(Of CompDatabaseEntry))
For Each Entry In CompDatabase For Each Entry In CompDatabase
@@ -991,7 +995,7 @@ NoSubtitle:
}) })
Next Next
'获取搜索结果 '获取搜索结果
Dim SearchResults = Search(SearchEntries, Task.Input.SearchText, 3) Dim SearchResults = Search(SearchEntries, Request.SearchText, 3)
If Not SearchResults.Any() Then Throw New Exception("无搜索结果,请尝试搜索英文名称") If Not SearchResults.Any() Then Throw New Exception("无搜索结果,请尝试搜索英文名称")
Dim SearchResult As String = "" Dim SearchResult As String = ""
For i = 0 To Math.Min(4, SearchResults.Count - 1) '就算全是准确的,也最多只要 5 个 For i = 0 To Math.Min(4, SearchResults.Count - 1) '就算全是准确的,也最多只要 5 个
@@ -1009,14 +1013,14 @@ NoSubtitle:
If SearchResult.Split(" ").Count > 3 AndAlso {"ftb"}.Contains(Word.ToLower) Then Continue For If SearchResult.Split(" ").Count > 3 AndAlso {"ftb"}.Contains(Word.ToLower) Then Continue For
RealFilter += Word.TrimStart("{[(").TrimEnd("}])") & " " RealFilter += Word.TrimStart("{[(").TrimEnd("}])") & " "
Next Next
Task.Input.SearchText = RealFilter Request.SearchText = RealFilter
Log("[Comp] 中文搜索最终关键词:" & RealFilter, LogLevel.Developer) Log("[Comp] 中文搜索最终关键词:" & RealFilter, LogLevel.Developer)
End If End If
'驼峰英文请求关键字处理 '驼峰英文请求关键字处理
Dim SpacedKeywords = Task.Input.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ") Dim SpacedKeywords = Request.SearchText.RegexReplace("([A-Z]+|[a-z]+?)(?=[A-Z]+[a-z]+[a-z ]*)", "$& ")
Dim ConnectedKeywords = Task.Input.SearchText.Replace(" ", "") Dim ConnectedKeywords = Request.SearchText.Replace(" ", "")
Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Task.Input.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower Dim AllPossibleKeywords = (SpacedKeywords & " " & If(IsChineseSearch, Request.SearchText, ConnectedKeywords & " " & RawFilter)).ToLower
'最终处理关键字:分割、去重 '最终处理关键字:分割、去重
Dim RightKeywords As New List(Of String) Dim RightKeywords As New List(Of String)
@@ -1030,15 +1034,15 @@ NoSubtitle:
RightKeywords.Add(Keyword) RightKeywords.Add(Keyword)
Next Next
If RawFilter.Length > 0 AndAlso Not RightKeywords.Any() Then If RawFilter.Length > 0 AndAlso Not RightKeywords.Any() Then
Task.Input.SearchText = RawFilter '全都被过滤掉了 Request.SearchText = RawFilter '全都被过滤掉了
Else Else
Task.Input.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower Request.SearchText = Join(RightKeywords.Distinct.ToList, " ").ToLower
End If End If
'例外项:OptiForge、OptiFabric(拆词后因为包含 Forge/Fabric 导致无法搜到实际的 Mod) '例外项:OptiForge、OptiFabric(拆词后因为包含 Forge/Fabric 导致无法搜到实际的 Mod)
If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Task.Input.SearchText = "optiforge" If RawFilter.Replace(" ", "").ContainsF("optiforge", True) Then Request.SearchText = "optiforge"
If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Task.Input.SearchText = "optifabric" If RawFilter.Replace(" ", "").ContainsF("optifabric", True) Then Request.SearchText = "optifabric"
Log("[Comp] 工程列表搜索最终文本:" & Task.Input.SearchText, LogLevel.Debug) Log("[Comp] 工程列表搜索最终文本:" & Request.SearchText, LogLevel.Debug)
Task.Progress = 0.1 Task.Progress = 0.1
#End Region #End Region
@@ -1054,10 +1058,17 @@ Retry:
Dim ModrinthThread As Thread = Nothing Dim ModrinthThread As Thread = Nothing
Dim ResultsLock As New Object 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 Try
'启动 CurseForge 线程 '启动 CurseForge 线程
Dim CurseForgeUrl As String = Task.Input.GetCurseForgeAddress()
Dim CurseForgeFailed As Boolean = False Dim CurseForgeFailed As Boolean = False
If CurseForgeUrl IsNot Nothing Then If CurseForgeUrl IsNot Nothing Then
CurseForgeThread = RunInNewThread( CurseForgeThread = RunInNewThread(
@@ -1065,12 +1076,12 @@ Retry:
Try Try
'获取工程列表 '获取工程列表
Log("[Comp] 开始从 CurseForge 获取工程列表:" & CurseForgeUrl) Log("[Comp] 开始从 CurseForge 获取工程列表:" & CurseForgeUrl)
Dim RequestResult As JObject = DlModRequest(CurseForgeUrl, IsJson:=True) Dim RequestResult As JObject = DlModRequest(CurseForgeUrl)
Task.Progress += 0.2 Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject) Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("data") For Each JsonEntry As JObject In RequestResult("data")
Dim Project As New CompProject(JsonEntry) Dim Project As New CompProject(JsonEntry)
If Task.Input.Type = CompType.ResourcePack AndAlso Project.Tags.Contains("数据包") Then Continue For 'CurseForge 将一些数据包分类成了资源包 If Request.Type = CompType.ResourcePack AndAlso Project.Tags.Contains("数据包") Then Continue For 'CurseForge 将一些数据包分类成了资源包
ProjectList.Add(Project) ProjectList.Add(Project)
Next Next
'更新结果 '更新结果
@@ -1090,14 +1101,13 @@ Retry:
End If End If
'启动 Modrinth 线程 '启动 Modrinth 线程
Dim ModrinthUrl As String = Task.Input.GetModrinthAddress()
Dim ModrinthFailed As Boolean = False Dim ModrinthFailed As Boolean = False
If ModrinthUrl IsNot Nothing Then If ModrinthUrl IsNot Nothing Then
ModrinthThread = RunInNewThread( ModrinthThread = RunInNewThread(
Sub() Sub()
Try Try
Log("[Comp] 开始从 Modrinth 获取工程列表:" & ModrinthUrl) Log("[Comp] 开始从 Modrinth 获取工程列表:" & ModrinthUrl)
Dim RequestResult As JObject = DlModRequest(ModrinthUrl, IsJson:=True) Dim RequestResult As JObject = DlModRequest(ModrinthUrl)
Task.Progress += 0.2 Task.Progress += 0.2
Dim ProjectList As New List(Of CompProject) Dim ProjectList As New List(Of CompProject)
For Each JsonEntry As JObject In RequestResult("hits") For Each JsonEntry As JObject In RequestResult("hits")
@@ -1123,9 +1133,14 @@ Retry:
'等待线程结束 '等待线程结束
If CurseForgeThread IsNot Nothing Then CurseForgeThread.Join() 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 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 Storage.ErrorMessage = Nothing
@@ -1133,11 +1148,11 @@ Retry:
If [Error] IsNot Nothing Then If [Error] IsNot Nothing Then
Throw [Error] Throw [Error]
Else Else
If IsChineseSearch AndAlso Not (Task.Input.Type = CompType.Mod OrElse Task.Input.Type = CompType.DataPack) Then If IsChineseSearch AndAlso Not (Request.Type = CompType.Mod OrElse Request.Type = CompType.DataPack) Then
Throw New Exception("没有搜索结果,请尝试使用英文搜索") Throw New Exception("没有搜索结果,请尝试使用英文搜索")
ElseIf Task.Input.Source = CompSourceType.CurseForge AndAlso Task.Input.Tag.StartsWithF("/") Then ElseIf Request.Source = CompSourceType.CurseForge AndAlso Request.Tag.StartsWithF("/") Then
Throw New Exception("CurseForge 不兼容所选的类型") 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 不兼容所选的类型") Throw New Exception("Modrinth 不兼容所选的类型")
Else Else
Throw New Exception("没有搜索结果") Throw New Exception("没有搜索结果")
@@ -1146,15 +1161,15 @@ Retry:
ElseIf [Error] IsNot Nothing Then ElseIf [Error] IsNot Nothing Then
'有结果但是有错误 '有结果但是有错误
If CurseForgeFailed Then If CurseForgeFailed Then
Storage.ErrorMessage = $"无法连接到 CurseForge,所以目前仅显示了来自 Modrinth 的内容,结果可能不全。{vbCrLf}请尝试使用 VPN 或加速器以改善网络。" Storage.ErrorMessage = $"无法连接到 CurseForge,所以目前仅显示了来自 Modrinth 的内容,搜索结果可能不全。{vbCrLf}请稍后重试,或使用 VPN 以改善网络环境。"
Else Else
Storage.ErrorMessage = $"无法连接到 Modrinth,所以目前仅显示了来自 CurseForge 的内容,结果可能不全。{vbCrLf}请尝试使用 VPN 或加速器以改善网络。" Storage.ErrorMessage = $"无法连接到 Modrinth,所以目前仅显示了来自 CurseForge 的内容,搜索结果可能不全。{vbCrLf}请稍后重试,或使用 VPN 以改善网络环境。"
End If End If
End If End If
Finally Finally
If CurseForgeThread IsNot Nothing Then CurseForgeThread.Interrupt() CurseForgeThread?.Interrupt()
If ModrinthThread IsNot Nothing Then ModrinthThread.Interrupt() ModrinthThread?.Interrupt()
End Try End Try
#End Region #End Region
@@ -1177,9 +1192,9 @@ Retry:
#Region "检查结果数量,如果不足且可继续,会继续加载下一页" #Region "检查结果数量,如果不足且可继续,会继续加载下一页"
If RealResults.Count + Storage.Results.Count < Task.Input.TargetResultCount Then If RealResults.Count + Storage.Results.Count < Request.TargetResultCount Then
Log($"[Comp] 总结果数需求最少 {Task.Input.TargetResultCount} 个,仅获得了 {RealResults.Count + Storage.Results.Count} 个") Log($"[Comp] 总结果数需求最少 {Request.TargetResultCount} 个,仅获得了 {RealResults.Count + Storage.Results.Count} 个")
If Task.Input.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试,这时候重试可能导致无限循环 If Request.CanContinue AndAlso [Error] Is Nothing Then '如果有下载源失败则不再重试,这时候重试可能导致无限循环
Log("[Comp] 将继续尝试加载下一页") Log("[Comp] 将继续尝试加载下一页")
GoTo Retry GoTo Retry
Else Else
@@ -1194,7 +1209,7 @@ Retry:
Dim Scores As New Dictionary(Of CompProject, Double) '排序分 Dim Scores As New Dictionary(Of CompProject, Double) '排序分
Dim GetDownloadCountMult = Dim GetDownloadCountMult =
Function(Project As CompProject) As Double Function(Project As CompProject) As Double
Select Case Task.Input.Type Select Case Request.Type
Case CompType.Mod, CompType.ModPack Case CompType.Mod, CompType.ModPack
Return If(Project.FromCurseForge, 1, 7) Return If(Project.FromCurseForge, 1, 7)
Case CompType.DataPack Case CompType.DataPack
@@ -1205,7 +1220,7 @@ Retry:
Return 1 Return 1
End Select End Select
End Function End Function
If String.IsNullOrEmpty(Task.Input.SearchText) Then If String.IsNullOrEmpty(Request.SearchText) Then
'如果没有搜索文本,按下载量将结果排序 '如果没有搜索文本,按下载量将结果排序
For Each Result As CompProject In RealResults For Each Result As CompProject In RealResults
Scores.Add(Result, Result.DownloadCount * GetDownloadCountMult(Result)) Scores.Add(Result, Result.DownloadCount * GetDownloadCountMult(Result))
@@ -1381,7 +1396,7 @@ Retry:
'DownloadAddress 'DownloadAddress
Dim Url = Data("downloadUrl").ToString 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}" 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)) '对文件名进行编码 Url = Url.Replace(FileName, WebUtility.UrlEncode(FileName)) '对文件名进行编码
DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正 DownloadUrls = HandleCurseForgeDownloadUrls(Url) '对脑残 CurseForge 的下载地址进行多种修正
DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源,这个写法是为了让镜像源排在后面 DownloadUrls.AddRange(DownloadUrls.Select(Function(u) DlSourceModGet(u)).ToList) '添加镜像源,这个写法是为了让镜像源排在后面
DownloadUrls = DownloadUrls.Distinct.ToList '最终去重 DownloadUrls = DownloadUrls.Distinct.ToList '最终去重
@@ -1475,9 +1490,10 @@ Retry:
''' </summary> ''' </summary>
Public Shared Function HandleCurseForgeDownloadUrls(Url As String) As List(Of String) Public Shared Function HandleCurseForgeDownloadUrls(Url As String) As List(Of String)
Return { 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("-service.overwolf.wtf", ".forgecdn.net"),
Url.Replace("://edge", "://media"), Url.Replace("://media.", "://edge."),
Url Url
}.Distinct.ToList }.Distinct.ToList
End Function End Function
@@ -1574,27 +1590,40 @@ Retry:
If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存 If CompProjectCache.ContainsKey(ProjectId) Then '存在缓存
TargetProject = CompProjectCache(ProjectId) TargetProject = CompProjectCache(ProjectId)
ElseIf FromCurseForge Then 'CurseForge 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 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 End If
'获取工程对象的文件列表 '获取工程对象的文件列表
If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回,这时候前置可能没获取(#5173) If Not CompFilesCache.ContainsKey(ProjectId) Then '有缓存也不能直接返回,这时候前置可能没获取(#5173)
Log("[Comp] 开始获取文件列表:" & ProjectId) Log("[Comp] 开始获取文件列表:" & ProjectId)
Dim ResultJsonArray As JArray Dim ResultJsonArray As JArray = Nothing
If FromCurseForge Then If FromCurseForge Then
'CurseForge 'CurseForge
'HMCL 一次性请求了 10000 个文件,虽然不知道会不会出问题但先这样吧……(#5522) For RetryCount As Integer = 0 To 2
ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=10000", IsJson:=True)("data") Dim ResultJson As JObject = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=" &
'之前只请求一部分文件的方法备份如下: (10000 + RetryCount)) '每次重试多请求一个文件,以避免触发 CDN 缓存
'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件 'HMCL 一次性请求了 10000 个文件,虽然不知道会不会出问题但先这样吧……(#5522)
' ResultJsonArray = GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json"))("data") '之前只请求一部分文件的方法备份如下:
'Else '否则使用全部文件 'If TargetProject.Type = CompType.Mod Then 'Mod 使用每个版本最新的文件
' ResultJsonArray = DlModRequest($"https://api.curseforge.com/v1/mods/{ProjectId}/files?pageSize=999", IsJson:=True)("data") ' ResultJsonArray = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post, "{""fileIds"": [" & Join(TargetProject.CurseForgeFileIds, ",") & "]}", "application/json")("data")
'End If '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 Else
'Modrinth '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 End If
CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)). CompFilesCache(ProjectId) = ResultJsonArray.Select(Function(a) New CompFile(a, TargetProject.Type)).
Where(Function(a) a.Available).ToList. Where(Function(a) a.Available).ToList.
@@ -1608,10 +1637,10 @@ Retry:
Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置:{Join(UndoneDeps, ",")}") Log($"[Comp] {ProjectId} 文件列表中还需要获取信息的前置:{Join(UndoneDeps, ",")}")
Dim Projects As JArray Dim Projects As JArray
If TargetProject.FromCurseForge Then If TargetProject.FromCurseForge Then
Projects = GetJson(DlModRequest("https://api.curseforge.com/v1/mods", Projects = DlModRequest("https://api.curseforge.com/v1/mods",
"POST", "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json"))("data") HttpMethod.Post, "{""modIds"": [" & Join(UndoneDeps, ",") & "]}", "application/json")("data")
Else 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 End If
For Each Project In Projects For Each Project In Projects
Dim Unused As New CompProject(Project) '在 New 的时候会添加缓存以便之后读取 Dim Unused As New CompProject(Project) '在 New 的时候会添加缓存以便之后读取
@@ -1638,7 +1667,7 @@ Retry:
'如果为整合包就不会有 Dependencies 信息,所以不用管 '如果为整合包就不会有 Dependencies 信息,所以不用管
Dim Deps As List(Of String) = Files.SelectMany(Function(f) f.Dependencies).Distinct.ToList() Dim Deps As List(Of String) = Files.SelectMany(Function(f) f.Dependencies).Distinct.ToList()
Deps.Sort() Deps.Sort()
If Not Deps.Any() Then Exit Sub If Not Deps.Any() Then Return
Deps = Deps.Where( Deps = Deps.Where(
Function(dep) Function(dep)
If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置信息", LogLevel.Debug) If Not CompProjectCache.ContainsKey(dep) Then Log($"[Comp] 未找到 ID {dep} 的前置信息", LogLevel.Debug)
@@ -2,7 +2,9 @@
'构造函数 '构造函数
Private TempFolder As String 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() TempFolder = RequestTaskTempFolder()
Directory.CreateDirectory(TempFolder & "Temp\") Directory.CreateDirectory(TempFolder & "Temp\")
@@ -71,11 +73,7 @@
'将可能可用的日志文件导出 '将可能可用的日志文件导出
For Each FilePath In RightLogs For Each FilePath In RightLogs
Try Try
If FilePath.Contains("crash-") Then AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Split(vbCrLf.ToCharArray)))
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
Catch ex As Exception Catch ex As Exception
Log(ex, "读取可能的崩溃日志文件失败(" & FilePath & ")") Log(ex, "读取可能的崩溃日志文件失败(" & FilePath & ")")
End Try End Try
@@ -117,11 +115,7 @@ Extracted:
If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For
Dim Ext As String = TargetFile.Extension.ToLower Dim Ext As String = TargetFile.Extension.ToLower
If Ext = ".log" OrElse Ext = ".txt" Then 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)))
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
Else Else
File.Delete(TargetFile.FullName) File.Delete(TargetFile.FullName)
End If End If
@@ -137,20 +131,21 @@ Extracted:
Private Enum AnalyzeFileType Private Enum AnalyzeFileType
HsErr HsErr
MinecraftLog MinecraftLog
ExtraLog ExtraLogFile
ExtraReportFile
CrashReport CrashReport
End Enum End Enum
Private DirectFile As KeyValuePair(Of String, String())? = Nothing '在弹窗中选择直接打开的文件 Private DirectFile As KeyValuePair(Of String, String())? = Nothing '在弹窗中选择直接打开的文件
''' <summary> ''' <summary>
''' 从 AnalyzeRawFiles 中提取实际有用的文本片段存储到 AnalyzeFiles,并整理可用于生成报告的文件。 ''' 从 AnalyzeRawFiles 中提取实际有用的文本片段存储到 AnalyzeFiles,并整理可用于生成报告的文件。
''' 返回找到的用于分析的项目数。 ''' 返回是否有足够信息可用于分析。
''' </summary> ''' </summary>
Public Function Prepare() As Integer Public Function Prepare() As Boolean
Log("[Crash] 步骤 2:准备日志文本") Log("[Crash] 步骤 2:准备日志文本")
'对日志文件进行分类 '对日志文件进行分类
DirectFile = Nothing 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 For Each LogFile In AnalyzeRawFiles
Dim MatchName As String = GetFileNameFromPath(LogFile.Key).ToLower Dim MatchName As String = GetFileNameFromPath(LogFile.Key).ToLower
Dim TargetType As AnalyzeFileType Dim TargetType As AnalyzeFileType
@@ -170,27 +165,35 @@ Extracted:
TargetType = AnalyzeFileType.MinecraftLog TargetType = AnalyzeFileType.MinecraftLog
If DirectFile Is Nothing Then DirectFile = LogFile If DirectFile Is Nothing Then DirectFile = LogFile
Else Else
TargetType = AnalyzeFileType.ExtraLog TargetType = AnalyzeFileType.ExtraLogFile
End If End If
ElseIf MatchName.EndsWithF(".log", True) OrElse MatchName.EndsWithF(".txt", True) Then ElseIf MatchName.EndsWithF(".log", True) Then
TargetType = AnalyzeFileType.ExtraLog TargetType = AnalyzeFileType.ExtraLogFile
ElseIf MatchName.EndsWithF(".txt", True) Then
TargetType = AnalyzeFileType.ExtraReportFile
Else Else
Log("[Crash] " & MatchName & " 分类为 Ignore") Log("[Crash] " & MatchName & " 分类为 Ignore")
Continue For Continue For
End If End If
If Not LogFile.Value.Any() Then If LogFile.Value.Any Then
Log("[Crash] " & MatchName & " 由于内容为空跳过") AllFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
Else
TotalFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
Log("[Crash] " & MatchName & " 分类为 " & GetStringFromEnum(TargetType)) Log("[Crash] " & MatchName & " 分类为 " & GetStringFromEnum(TargetType))
Else
Log("[Crash] " & MatchName & " 由于内容为空跳过")
End If End If
Next 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())) 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) If SelectType = File.Key Then SelectedFiles.Add(File.Value)
Next Next
If Not SelectedFiles.Any() Then Continue For If Not SelectedFiles.Any() Then Continue For
@@ -232,54 +235,59 @@ Extracted:
Next Next
'选择一份最佳的来自启动器的游戏日志 '选择一份最佳的来自启动器的游戏日志
For Each FileName As String In {"rawoutput.log", "启动器日志.txt", "log1.txt", "游戏崩溃前的输出.txt", "PCL2 启动器日志.txt", "PCL 启动器日志.txt"} For Each FileName As String In {"rawoutput.log", "启动器日志.txt", "log1.txt", "游戏崩溃前的输出.txt", "PCL2 启动器日志.txt", "PCL 启动器日志.txt"}
If FileNameDict.ContainsKey(FileName) Then If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName) Dim CurrentLog = FileNameDict(FileName)
'截取 “以下为游戏输出的最后一段内容” 后的内容 '截取 “以下为游戏输出的最后一段内容” 后的内容
Dim HasLauncherMark As Boolean = False Dim HasLauncherMark As Boolean = False
For Each Line In CurrentLog.Value For Each Line In CurrentLog.Value
If HasLauncherMark Then If HasLauncherMark Then
LogMc += Line & vbLf LogMc += Line & vbLf
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
HasLauncherMark = True HasLauncherMark = True
Log("[Crash] 找到 PCL 输出的游戏实时日志头") Log("[Crash] 找到 PCL 输出的游戏实时日志头")
End If End If
Next Next
'导入后 500 行 '导入后 500 行
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500) If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray) LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray)
Log("[Crash] 导入分析:" & CurrentLog.Key & ",作为启动器日志") Log("[Crash] 导入分析:" & CurrentLog.Key & ",作为启动器日志")
Exit For Exit For
End If
Next Next
'选择一份最佳的 Minecraft Log '选择一份最佳的 Minecraft Log
For Each FileName As String In {"latest.log", "latest log.txt", "debug.log", "debug log.txt"} For Each FileName As String In {"latest.log", "latest log.txt", "debug.log", "debug log.txt"}
If FileNameDict.ContainsKey(FileName) Then If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName) Dim CurrentLog = FileNameDict(FileName)
LogMc += GetHeadTailLines(CurrentLog.Value, 250, 500) LogMc += GetHeadTailLines(CurrentLog.Value, 1500, 500)
Log("[Crash] 导入分析:" & CurrentLog.Key & ",作为 Minecraft 日志") Log("[Crash] 导入分析:" & CurrentLog.Key & ",作为 Minecraft 日志")
Exit For Exit For
End If
Next Next
'查找 Debug Log '查找 Debug Log
For Each FileName As String In {"debug.log", "debug log.txt"} For Each FileName As String In {"debug.log", "debug log.txt"}
If FileNameDict.ContainsKey(FileName) Then If Not FileNameDict.ContainsKey(FileName) Then Continue For
Dim CurrentLog = FileNameDict(FileName) Dim CurrentLog = FileNameDict(FileName)
LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0) LogMcDebug += GetHeadTailLines(CurrentLog.Value, 1000, 0)
Log("[Crash] 导入分析:" & CurrentLog.Key & ",作为 Minecraft Debug 日志") Log("[Crash] 导入分析:" & CurrentLog.Key & ",作为 Minecraft Debug 日志")
Exit For Exit For
End If
Next Next
'检查错误 '兜底
If LogMc = "" Then If LogMc = "" Then
LogMc = Nothing If LogMcDebug <> "" Then '如果没有找到 Minecraft 日志,则使用 Debug 日志作为兜底
Throw New Exception("无法找到匹配的 Minecraft Log") 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 End If
If LogMcDebug = "" Then LogMcDebug = Nothing If LogMcDebug = "" Then LogMcDebug = Nothing
Case AnalyzeFileType.ExtraLog Case AnalyzeFileType.ExtraLogFile, AnalyzeFileType.ExtraReportFile
'全部丢过去 '全部丢过去
For Each SelectedFile In SelectedFiles For Each SelectedFile In SelectedFiles
OutputFiles.Add(SelectedFile.Key) OutputFiles.Add(SelectedFile.Key)
Log("[Crash] 输出报告:" & SelectedFile.Key & ",作为额外日志") Log("[Crash] 输出报告:" & SelectedFile.Key & ",不用作分析")
Next Next
End Select End Select
Catch ex As Exception Catch ex As Exception
@@ -287,15 +295,13 @@ Extracted:
End Try End Try
Next Next
'获取种类数 '结束
Dim ResultCount As Integer = If(LogMc Is Nothing, 0, 1) + If(LogHs Is Nothing, 0, 1) + If(LogCrash Is Nothing, 0, 1) Prepare = LogMc IsNot Nothing OrElse LogHs IsNot Nothing OrElse LogCrash IsNot Nothing
If ResultCount = 0 Then If Prepare Then
Log("[Crash] 步骤 2:准备日志文本完成,没有任何可供分析的日志")
Else
Log(("[Crash] 步骤 2:准备日志文本完成,找到" & If(LogMc Is Nothing, "", "游戏日志、") & If(LogMcDebug Is Nothing, "", "游戏 Debug 日志、") & If(LogHs Is Nothing, "", "虚拟机日志、") & If(LogCrash Is Nothing, "", "崩溃日志、")).TrimEnd("、") & "用作分析") 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 End If
Return ResultCount
End Function End Function
''' <summary> ''' <summary>
''' 输出字符串的前后某些行,并统一行尾为 vbLf (正则 \n)、删除空行和重复行。 ''' 输出字符串的前后某些行,并统一行尾为 vbLf (正则 \n)、删除空行和重复行。
@@ -386,7 +392,7 @@ Extracted:
''' </summary> ''' </summary>
Public Sub Analyze(Optional Version As McVersion = Nothing) Public Sub Analyze(Optional Version As McVersion = Nothing)
Log("[Crash] 步骤 3:分析崩溃原因") Log("[Crash] 步骤 3:分析崩溃原因")
LogAll = (If(LogMc, "") & If(LogMcDebug, "") & If(LogHs, "") & If(LogCrash, "")) LogAll = If(LogMc, If(LogMcDebug, "")) & If(LogHs, "") & If(LogCrash, "")
'1. 精准日志匹配,中/高优先级 '1. 精准日志匹配,中/高优先级
AnalyzeCrit1() AnalyzeCrit1()
@@ -472,7 +478,7 @@ Done:
'空白分析 '空白分析
If LogMc Is Nothing AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing Then If LogMc Is Nothing AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing Then
AppendReason(CrashReason.没有可用的分析文件) AppendReason(CrashReason.没有可用的分析文件)
Exit Sub Return
End If End If
'崩溃报告分析,高优先级 '崩溃报告分析,高优先级
@@ -504,7 +510,7 @@ Done:
If LogMc.Contains("Couldn't set pixel format") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式) 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.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.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("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("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("Maybe try a lower resolution resourcepack?") Then AppendReason(CrashReason.材质过大或显卡配置不足)
@@ -614,9 +620,9 @@ Done:
Dim IsMixin As Boolean = MixinAnalyze(LogMc) 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("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:") 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)((\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)(\s+ - [^\n]+\n)+"), ""), "(?<=\s+)[^\n]+"), vbLf))
If LogMc.Contains("确定了一种可能的解决方法,这样做可能会解决你的问题:") Then AppendReason(CrashReason.Fabric报错并给出解决方案, Join(RegexSearch(If(RegexSeek(LogMc, "(?<=确定了一种可能的解决方法,这样做可能会解决你的问题:\n)((\t)+ - [^\n]+\n)+"), ""), "(?<=(\t)+)[^\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 加载失败 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))) AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=due to errors, provided by ')[^']+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
End If End If
@@ -704,11 +710,12 @@ NextStack:
If Word.Length <= 2 OrElse Word.StartsWithF("func_") Then Continue For 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", 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", "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", "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", "preinit", "preload", "machine", "reflect", "channel", "general", "handler", "content", "systems", "modules", "service",
"fastutil", "optifine", "internal", "platform", "override", "fabricmc", "neoforge", "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"
}.Contains(Word.ToLower) Then Continue For }.Contains(Word.ToLower) Then Continue For
PossibleWords.Add(Word.Trim) PossibleWords.Add(Word.Trim)
Next Next
@@ -851,12 +858,13 @@ NextStack:
''' <summary> ''' <summary>
''' 弹出崩溃弹窗,并指导导出崩溃报告。 ''' 弹出崩溃弹窗,并指导导出崩溃报告。
''' </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() FrmMain.ShowWindowToTop()
Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"), Dim Detail As String = GetAnalyzeResult(IsManualAnalyze)
"确定", If(IsHandAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsHandAnalyze, "", "导出错误报告"), Select Case MyMsgBox(Detail, If(IsManualAnalyze, "错误报告分析结果", "Minecraft 出现错误"),
Button2Action:=If(IsHandAnalyze OrElse DirectFile Is Nothing, Nothing, "确定", If(IsManualAnalyze OrElse DirectFile Is Nothing, "", "查看日志"), If(IsManualAnalyze, "", "导出错误报告"),
Button2Action:=If(IsManualAnalyze OrElse DirectFile Is Nothing, Nothing,
Sub() Sub()
'弹窗选择:查看日志 '弹窗选择:查看日志
If File.Exists(DirectFile.Value.Key) Then If File.Exists(DirectFile.Value.Key) Then
@@ -873,7 +881,7 @@ NextStack:
Try Try
'获取文件路径 '获取文件路径
RunInUiWait(Sub() FileAddress = SelectSaveFile("选择保存位置", "错误报告-" & Date.Now.ToString("G").Replace("/", "-").Replace(":", ".").Replace(" ", "_") & ".zip", "Minecraft 错误报告(*.zip)|*.zip")) 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)) Directory.CreateDirectory(GetPathFromFullPath(FileAddress))
If File.Exists(FileAddress) Then File.Delete(FileAddress) If File.Exists(FileAddress) Then File.Delete(FileAddress)
'输出诊断信息 '输出诊断信息
@@ -896,9 +904,10 @@ NextStack:
End Select End Select
If File.Exists(OutputFile) Then If File.Exists(OutputFile) Then
If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile)) If FileEncoding Is Nothing Then FileEncoding = GetEncoding(ReadFileBytes(OutputFile))
WriteFile(TempFolder & "Report\" & FileName, Dim FileContent As String = ReadFile(OutputFile, FileEncoding)
SecretFilter(ReadFile(OutputFile, FileEncoding), If(FileName = "启动脚本.bat", "F", "*")), FileContent = FilterAccessToken(FileContent, If(FileName = "启动脚本.bat", "F", "*"))
Encoding:=FileEncoding) FileContent = FilterUserName(FileContent, "*")
WriteFile(TempFolder & "Report\" & FileName, FileContent, Encoding:=FileEncoding)
Log($"[Crash] 导出文件:{FileName},编码:{FileEncoding.HeaderName}") Log($"[Crash] 导出文件:{FileName},编码:{FileEncoding.HeaderName}")
End If End If
Next Next
@@ -908,10 +917,15 @@ NextStack:
Hint("错误报告已导出!", HintType.Finish) Hint("错误报告已导出!", HintType.Finish)
Catch ex As Exception Catch ex As Exception
Log(ex, "导出错误报告失败", LogLevel.Feedback) Log(ex, "导出错误报告失败", LogLevel.Feedback)
Exit Sub Return
End Try End Try
OpenExplorer(FileAddress) OpenExplorer(FileAddress)
End Select End Select
'上报
If IsManualAnalyze Then Return
Telemetry("Minecraft 崩溃",
"Version", If(TargetVersion Is Nothing, "null", TargetVersion.Version.ToString),
"Detail", FilterUserName(Detail, "*"))
End Sub End Sub
''' <summary> ''' <summary>
''' 获取崩溃分析的结果描述。 ''' 获取崩溃分析的结果描述。
@@ -937,7 +951,7 @@ NextStack:
Case CrashReason.内存不足 Case CrashReason.内存不足
Results.Add("Minecraft 内存不足,导致其无法继续运行。\n这很可能是因为电脑内存不足、游戏分配的内存不足,或是配置要求过高。\n\n你可以尝试在 更多 → 百宝箱 中选择 内存优化,然后再启动游戏。\n如果还是不行,请在启动设置中增加为游戏分配的内存,并删除配置要求较高的材质、Mod、光影。\n如果依然不奏效,请在开始游戏前尽量关闭其他软件,或者……换台电脑?\h") Results.Add("Minecraft 内存不足,导致其无法继续运行。\n这很可能是因为电脑内存不足、游戏分配的内存不足,或是配置要求过高。\n\n你可以尝试在 更多 → 百宝箱 中选择 内存优化,然后再启动游戏。\n如果还是不行,请在启动设置中增加为游戏分配的内存,并删除配置要求较高的材质、Mod、光影。\n如果依然不奏效,请在开始游戏前尽量关闭其他软件,或者……换台电脑?\h")
Case CrashReason.使用OpenJ9 Case CrashReason.使用OpenJ9
Results.Add("游戏因为使用 Open J9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java,然后再启动游戏。") Results.Add("游戏因为使用 OpenJ9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java,然后再启动游戏。")
Case CrashReason.使用JDK Case CrashReason.使用JDK
Results.Add("游戏似乎因为使用 JDK,或 Java 版本过高而崩溃了。\n请在启动设置的 Java 选择一项中改用 JRE 8(Java 8),然后再启动游戏。\n如果你没有安装 JRE 8,你可以从网络中下载、安装一个。") Results.Add("游戏似乎因为使用 JDK,或 Java 版本过高而崩溃了。\n请在启动设置的 Java 选择一项中改用 JRE 8(Java 8),然后再启动游戏。\n如果你没有安装 JRE 8,你可以从网络中下载、安装一个。")
Case CrashReason.Java版本过高 Case CrashReason.Java版本过高
@@ -1012,14 +1026,14 @@ NextStack:
End If End If
Case CrashReason.特定实体导致崩溃 Case CrashReason.特定实体导致崩溃
If Additional.Count = 1 Then If Additional.Count = 1 Then
Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界,并生成一个该实体,然后观察游戏的运行情况:\n - 若正常运行,则是该实体导致出错,你或许需要使用一些方式删除此实体。\n - 若仍然出错,问题就可能来自其他原因……\h") Results.Add("游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界,并生成一个该实体,然后观察游戏的运行情况。\h")
Else Else
Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界,并生成各种实体,观察游戏的运行情况:\n - 若正常运行,则是某些实体导致出错,你或许需要删除该世界。\n - 若仍然出错,问题就可能来自其他原因……\h") Results.Add("游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界,并生成各种实体,然后观察游戏的运行情况。\h")
End If End If
Case CrashReason.OptiFine与Forge不兼容 Case CrashReason.OptiFine与Forge不兼容
Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容,导致了游戏崩溃。\n\n请前往 OptiFine 官网(https://optifine.net/downloads)查看 OptiFine 所兼容的 Forge 版本,并严格按照对应版本重新安装游戏。") Results.Add("由于 OptiFine 与当前版本的 Forge 不兼容,导致了游戏崩溃。\n\n请前往 OptiFine 官网(https://optifine.net/downloads)查看 OptiFine 所兼容的 Forge 版本,并严格按照对应版本重新安装游戏。")
Case CrashReason.ShadersMod与OptiFine同时安装 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不兼容 Case CrashReason.低版本Forge与高版本Java不兼容
Results.Add("由于低版本 Forge 与当前 Java 不兼容,导致了游戏崩溃。\n\n请尝试以下解决方案:\n - 更新 Forge 到 36.2.26 或更高版本\n - 换用版本低于 1.8.0.320 的 Java") Results.Add("由于低版本 Forge 与当前 Java 不兼容,导致了游戏崩溃。\n\n请尝试以下解决方案:\n - 更新 Forge 到 36.2.26 或更高版本\n - 换用版本低于 1.8.0.320 的 Java")
Case CrashReason.版本Json中存在多个Forge Case CrashReason.版本Json中存在多个Forge
@@ -1096,7 +1110,7 @@ NextStack:
If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "", If(Not Results.Any(Function(r) r.EndsWithF("\h")) OrElse IsHandAnalyze, "",
vbCrLf & "如果要寻求帮助,请把错误报告文件发给对方,而不是发送这个窗口的照片或者截图。" & vbCrLf & "如果要寻求帮助,请把错误报告文件发给对方,而不是发送这个窗口的照片或者截图。" &
If(If(PageSetupSystem.IsLauncherNewest(), True), "", If(If(PageSetupSystem.IsLauncherNewest(), True), "",
vbCrLf & vbCrLf & "此外,你正在使用老版本 PCL,更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 设置 → 启动器 → 检查更新 来更新 PCL。")) vbCrLf & vbCrLf & "此外,你正在使用老版本 PCL,更新 PCL 或许也能解决这个问题。" & vbCrLf & "你可以点击 [设置 → 其他 → 启动器 → 检查更新] 更新 PCL。"))
End Function End Function
End Class End Class
@@ -198,7 +198,7 @@
Private IsNewClientVersionHinted As Boolean = False Private IsNewClientVersionHinted As Boolean = False
Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult)) Private Sub DlClientListMojangMain(Loader As LoaderTask(Of String, DlClientListResult))
Dim StartTime As Long = GetTimeTick() Dim StartTime As Long = GetTimeTick()
Dim Json As JObject = NetGetCodeByRequestRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json", IsJson:=True) Dim Json As JObject = GetJson(NetRequestByClientRetry("https://launchermeta.mojang.com/mc/game/version_manifest.json"))
Try Try
Dim Versions As JArray = Json("versions") Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")") If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")")
@@ -235,7 +235,7 @@
''' </summary> ''' </summary>
Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain) Public DlClientListBmclapiLoader As New LoaderTask(Of String, DlClientListResult)("DlClientList Bmclapi", AddressOf DlClientListBmclapiMain)
Private Sub DlClientListBmclapiMain(Loader As LoaderTask(Of String, DlClientListResult)) 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"))
Try Try
Dim Versions As JArray = Json("versions") Dim Versions As JArray = Json("versions")
If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")") If Versions.Count < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Json.ToString & ")")
@@ -244,7 +244,7 @@
'检查是否有要求的版本(#5195) '检查是否有要求的版本(#5195)
If Not String.IsNullOrEmpty(Loader.Input) Then If Not String.IsNullOrEmpty(Loader.Input) Then
Dim Id = Loader.Input 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) Throw New Exception("BMCLAPI 源未包含目标版本 " & Id)
End If End If
End If End If
@@ -377,7 +377,7 @@
''' </summary> ''' </summary>
Public DlOptiFineListOfficialLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Official", AddressOf DlOptiFineListOfficialMain) Public DlOptiFineListOfficialLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Official", AddressOf DlOptiFineListOfficialMain)
Private Sub DlOptiFineListOfficialMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult)) 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 & ")") If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Result & ")")
Try Try
'获取所有版本信息 '获取所有版本信息
@@ -413,7 +413,7 @@
''' </summary> ''' </summary>
Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain) Public DlOptiFineListBmclapiLoader As New LoaderTask(Of Integer, DlOptiFineListResult)("DlOptiFineList Bmclapi", AddressOf DlOptiFineListBmclapiMain)
Private Sub DlOptiFineListBmclapiMain(Loader As LoaderTask(Of Integer, DlOptiFineListResult)) 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"))
Try Try
Dim Versions As New List(Of DlOptiFineListEntry) Dim Versions As New List(Of DlOptiFineListEntry)
For Each Token As JObject In Json For Each Token As JObject In Json
@@ -483,7 +483,7 @@
''' </summary> ''' </summary>
Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain) Public DlForgeListOfficialLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Official", AddressOf DlForgeListOfficialMain)
Private Sub DlForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlForgeListResult)) 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", UseBrowserUserAgent:=True)
If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Result & ")") 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)") Dim Names As List(Of String) = RegexSearch(Result, "(?<=a href=""index_)[0-9.]+(_pre[0-9]?)?(?=.html)")
@@ -497,7 +497,7 @@
''' </summary> ''' </summary>
Public DlForgeListBmclapiLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Bmclapi", AddressOf DlForgeListBmclapiMain) Public DlForgeListBmclapiLoader As New LoaderTask(Of Integer, DlForgeListResult)("DlForgeList Bmclapi", AddressOf DlForgeListBmclapiMain)
Private Sub DlForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlForgeListResult)) 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 & ")") If Result.Length < 200 Then Throw New Exception("获取到的版本列表长度不足(" & Result & ")")
'获取所有版本信息 '获取所有版本信息
Dim Names As List(Of String) = RegexSearch(Result, "[0-9.]+(_pre[0-9]?)?") Dim Names As List(Of String) = RegexSearch(Result, "[0-9.]+(_pre[0-9]?)?")
@@ -594,7 +594,7 @@
VersionName = Version VersionName = Version
Me.Version = New Version(Version) Me.Version = New Version(Version)
Me.Inherit = Inherit Me.Inherit = Inherit
FileVersion = Version & If(Branch Is Nothing, "", "-" & Branch) FileVersion = Version & If(Branch Is Nothing, "", "-" & Branch)
End Sub End Sub
End Class End Class
@@ -629,7 +629,7 @@
Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry))) Public Sub DlForgeVersionOfficialMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Result As String Dim Result As String
Try 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 Loader.Input.Replace("-", "_") & '兼容 Forge 1.7.10-pre4,#4057
".html", UseBrowserUserAgent:=True) ".html", UseBrowserUserAgent:=True)
Catch ex As Exception Catch ex As Exception
@@ -700,9 +700,8 @@
''' Forge 版本列表,BMCLAPI。 ''' Forge 版本列表,BMCLAPI。
''' </summary> ''' </summary>
Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry))) Public Sub DlForgeVersionBmclapiMain(Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)))
Dim Json As JArray = NetGetCodeByRequestRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" & Dim Json As JArray = GetJson(NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/minecraft/" &
Loader.Input.Replace("-", "_"), '兼容 Forge 1.7.10-pre4,#4057 Loader.Input.Replace("-", "_"))) '兼容 Forge 1.7.10-pre4,#4057
IsJson:=True)
Dim Versions As New List(Of DlForgeVersionEntry) Dim Versions As New List(Of DlForgeVersionEntry)
Try Try
Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input) Dim Recommended As String = McDownloadForgeRecommendedGet(Loader.Input)
@@ -840,8 +839,8 @@
Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain) Public DlNeoForgeListOfficialLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Official", AddressOf DlNeoForgeListOfficialMain)
Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult)) Private Sub DlNeoForgeListOfficialMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON '获取版本列表 JSON
Dim ResultLatest As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True) Dim ResultLatest As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/neoforge")
Dim ResultLegacy As String = NetGetCodeByLoader("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True) Dim ResultLegacy As String = NetRequestByClientRetry("https://maven.neoforged.net/api/maven/versions/releases/net/neoforged/forge")
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足(" & ResultLatest & ")") If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足(" & ResultLatest & ")")
'解析 '解析
Try Try
@@ -858,8 +857,8 @@
Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain) Public DlNeoForgeListBmclapiLoader As New LoaderTask(Of Integer, DlNeoForgeListResult)("DlNeoForgeList Bmclapi", AddressOf DlNeoForgeListBmclapiMain)
Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult)) Public Sub DlNeoForgeListBmclapiMain(Loader As LoaderTask(Of Integer, DlNeoForgeListResult))
'获取版本列表 JSON '获取版本列表 JSON
Dim ResultLatest As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge", UseBrowserUserAgent:=True, IsJson:=True) Dim ResultLatest As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/neoforge")
Dim ResultLegacy As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge", UseBrowserUserAgent:=True, IsJson:=True) Dim ResultLegacy As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/neoforge/meta/api/maven/details/releases/net/neoforged/forge")
If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足(" & ResultLatest & ")") If ResultLatest.Length < 100 OrElse ResultLegacy.Length < 100 Then Throw New Exception("获取到的版本列表长度不足(" & ResultLatest & ")")
'解析 '解析
Try Try
@@ -964,7 +963,7 @@
''' </summary> ''' </summary>
Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain) Public DlLiteLoaderListOfficialLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Official", AddressOf DlLiteLoaderListOfficialMain)
Private Sub DlLiteLoaderListOfficialMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult)) 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"))
Try Try
Dim Json As JObject = Result("versions") Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry) Dim Versions As New List(Of DlLiteLoaderListEntry)
@@ -992,7 +991,7 @@
''' </summary> ''' </summary>
Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain) Public DlLiteLoaderListBmclapiLoader As New LoaderTask(Of Integer, DlLiteLoaderListResult)("DlLiteLoaderList Bmclapi", AddressOf DlLiteLoaderListBmclapiMain)
Private Sub DlLiteLoaderListBmclapiMain(Loader As LoaderTask(Of Integer, DlLiteLoaderListResult)) 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"))
Try Try
Dim Json As JObject = Result("versions") Dim Json As JObject = Result("versions")
Dim Versions As New List(Of DlLiteLoaderListEntry) Dim Versions As New List(Of DlLiteLoaderListEntry)
@@ -1063,7 +1062,7 @@
''' </summary> ''' </summary>
Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain) Public DlFabricListOfficialLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Official", AddressOf DlFabricListOfficialMain)
Private Sub DlFabricListOfficialMain(Loader As LoaderTask(Of Integer, DlFabricListResult)) 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"))
Try Try
Dim Output = New DlFabricListResult With {.IsOfficial = True, .SourceName = "Fabric 官方源", .Value = Result} 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("获取到的列表缺乏必要项") If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -1078,7 +1077,7 @@
''' </summary> ''' </summary>
Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain) Public DlFabricListBmclapiLoader As New LoaderTask(Of Integer, DlFabricListResult)("DlFabricList Bmclapi", AddressOf DlFabricListBmclapiMain)
Private Sub DlFabricListBmclapiMain(Loader As LoaderTask(Of Integer, DlFabricListResult)) 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"))
Try Try
Dim Output = New DlFabricListResult With {.IsOfficial = False, .SourceName = "BMCLAPI", .Value = Result} 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("获取到的列表缺乏必要项") If Output.Value("game") Is Nothing OrElse Output.Value("loader") Is Nothing OrElse Output.Value("installer") Is Nothing Then Throw New Exception("获取到的列表缺乏必要项")
@@ -1105,72 +1104,37 @@
#Region "DlMod | Mod 镜像源请求" #Region "DlMod | Mod 镜像源请求"
''' <summary> ''' <summary>
''' 对可能涉及 Mod 镜像源的请求进行处理,返回字符串或 JObject。 ''' 对可能涉及 Mod 镜像源的请求进行处理,返回 JToken。
''' 调用 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 镜像源的请求进行处理。
''' 调用 NetRequest,会进行重试。 ''' 调用 NetRequest,会进行重试。
''' </summary> ''' </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)) Dim Urls As New List(Of KeyValuePair(Of String, Integer))
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) Dim McimUrl As String = DlSourceModGet(Url)
Urls.Add(New KeyValuePair(Of String, Integer)(Url, 20)) If McimUrl <> Url Then
'Dim McimUrl As String = DlSourceModGet(Url) Select Case Setup.Get("ToolDownloadMod")
'If McimUrl <> Url Then Case 0
' Select Case Setup.Get("ToolDownloadMod") Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Case 0 Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5)) Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) Case 1
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10)) '至少 10s,要不然有时候远端服务器来不及完成
' Case 1 Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 5)) Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) Case Else
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10))
' Case Else Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 5)) Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 30))
' Urls.Add(New KeyValuePair(Of String, Integer)(Url, 15)) End Select
' Urls.Add(New KeyValuePair(Of String, Integer)(McimUrl, 10)) Else
' End Select Urls.Add(New KeyValuePair(Of String, Integer)(Url, 10))
'End If Urls.Add(New KeyValuePair(Of String, Integer)(Url, 30))
End If
Dim Exs As String = "" Dim Exs As String = ""
For Each Source In Urls For Each Source In Urls
Try 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))
Catch ex As Exception Catch ex As Exception
Exs += ex.Message + vbCrLf Exs += ex.Message + vbCrLf
End Try End Try
@@ -1273,7 +1237,14 @@
'Mod 下载源 'Mod 下载源
Public Function DlSourceModGet(Original As String) As String 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 End Function
'Loader 自动切换 'Loader 自动切换
@@ -1295,7 +1266,7 @@
'检查加载器成功 '检查加载器成功
MainLoader.Output = SubLoader.Key.Output MainLoader.Output = SubLoader.Key.Output
DlSourceLoaderAbort(LoaderList) DlSourceLoaderAbort(LoaderList)
Exit Sub Return
ElseIf BeforeLoadersAllFailed Then ElseIf BeforeLoadersAllFailed Then
'此前的加载器全部失败,直接启动后续加载器 '此前的加载器全部失败,直接启动后续加载器
If WaitCycle < SubLoader.Value * 100 Then WaitCycle = SubLoader.Value * 100 If WaitCycle < SubLoader.Value * 100 Then WaitCycle = SubLoader.Value * 100
@@ -1337,7 +1308,7 @@
'检查父加载器中断 '检查父加载器中断
If MainLoader.IsAborted Then If MainLoader.IsAborted Then
DlSourceLoaderAbort(LoaderList) DlSourceLoaderAbort(LoaderList)
Exit Sub Return
End If End If
Loop Loop
End Sub End Sub
@@ -98,7 +98,7 @@
''' 检查并获取 Java 详细信息。在 Java 存在异常时抛出错误。 ''' 检查并获取 Java 详细信息。在 Java 存在异常时抛出错误。
''' </summary> ''' </summary>
Public Sub Check() Public Sub Check()
If IsChecked Then Exit Sub If IsChecked Then Return
Dim Output As String = Nothing Dim Output As String = Nothing
Try Try
'确定文件存在 '确定文件存在
@@ -108,12 +108,16 @@
If Not File.Exists(PathFolder & "java.exe") Then If Not File.Exists(PathFolder & "java.exe") Then
Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe") Throw New FileNotFoundException("未找到 java.exe 文件", PathFolder & "java.exe")
End If End If
If File.Exists(PathFolder & "pdf-bookmark") Then
Throw New Exception("不兼容 PDF Bookmark 的 Java") '#5326
End If
IsJre = Not File.Exists(PathFolder & "javac.exe") IsJre = Not File.Exists(PathFolder & "javac.exe")
'运行 -version '运行 -version
Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower Output = ShellAndGetOutput(PathFolder & "java.exe", "-version", 15000).ToLower
If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败") If Output = "" Then Throw New ApplicationException("尝试运行该 Java 失败")
If ModeDebug Then Log("[Java] Java 检查输出:" & PathFolder & "java.exe" & vbCrLf & Output) If ModeDebug Then Log("[Java] Java 检查输出:" & PathFolder & "java.exe" & vbCrLf & Output)
If Output.Contains("/lib/ext exists") Then Throw New ApplicationException("无法运行该 Java,请在删除 Java 文件夹中的 /lib/ext 文件夹后再试") 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 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" If VersionString.Split(".").Count > 4 Then VersionString = VersionString.Replace(".0.", ".") '#3493,VersionString = "21.0.2.0.2"
@@ -456,10 +460,12 @@ NoUserJava:
''' 将 Java 按照适用性排序。 ''' 将 Java 按照适用性排序。
''' </summary> ''' </summary>
Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean Public Function JavaSorter(Left As JavaEntry, Right As JavaEntry) As Boolean
Dim PathInfo As New DirectoryInfo(ShortenPath(Path))
Dim PathMcInfo As New DirectoryInfo(ShortenPath(PathMcFolder))
'1. 尽量在当前文件夹或当前 Minecraft 文件夹 '1. 尽量在当前文件夹或当前 Minecraft 文件夹
Dim ProgramPathParent As String, MinecraftPathParent As String = "" Dim ProgramPathParent As String, MinecraftPathParent As String = ""
ProgramPathParent = If(New DirectoryInfo(Path).Parent, New DirectoryInfo(Path)).FullName ProgramPathParent = If(PathInfo.Parent, PathInfo).FullName
If PathMcFolder <> "" Then MinecraftPathParent = If(New DirectoryInfo(PathMcFolder).Parent, New DirectoryInfo(PathMcFolder)).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 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 Not Left.PathFolder.StartsWithF(ProgramPathParent) AndAlso Right.PathFolder.StartsWithF(ProgramPathParent) Then Return False
If PathMcFolder <> "" Then If PathMcFolder <> "" Then
@@ -526,6 +532,8 @@ NoUserJava:
If Disk.DriveType = DriveType.Network Then Continue For '跳过网络驱动器(#3705) If Disk.DriveType = DriveType.Network Then Continue For '跳过网络驱动器(#3705)
JavaSearchFolder(Disk.Name, JavaPreList, False) JavaSearchFolder(Disk.Name, JavaPreList, False)
Next Next
'查找 .jdks 文件夹中的 Java
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.UserProfile) & "\.jdks\", JavaPreList, False)
'查找 APPDATA 文件夹中的 Java '查找 APPDATA 文件夹中的 Java
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\", JavaPreList, False) JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\", JavaPreList, False)
JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\", JavaPreList, False) JavaSearchFolder(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\", JavaPreList, False)
@@ -668,14 +676,14 @@ Wait:
Private Sub JavaSearchFolder(OriginalPath As DirectoryInfo, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False) Private Sub JavaSearchFolder(OriginalPath As DirectoryInfo, ByRef Results As Dictionary(Of String, Boolean), Source As Boolean, Optional IsFullSearch As Boolean = False)
Try Try
'确认目录存在 '确认目录存在
If Not OriginalPath.Exists Then Exit Sub If Not OriginalPath.Exists Then Return
Dim Path As String = OriginalPath.FullName.Replace("\\", "\") Dim Path As String = OriginalPath.FullName.Replace("\\", "\")
If Not Path.EndsWithF("\") Then Path += "\" If Not Path.EndsWithF("\") Then Path += "\"
'若该目录有 Java,则加入结果 '若该目录有 Java,则加入结果
If File.Exists(Path & "javaw.exe") Then Results(Path) = Source If File.Exists(Path & "javaw.exe") Then Results(Path) = Source
'查找其下的所有文件夹 '查找其下的所有文件夹
'不应使用网易的 Java:https://github.com/Hex-Dragon/PCL2/issues/1279#issuecomment-2761489121 '不应使用网易的 Java:https://github.com/Meloong-Git/PCL/issues/1279#issuecomment-2761489121
Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon", Dim Keywords = {"java", "jdk", "env", "环境", "run", "软件", "jre", "mc", "dragon", "bin",
"soft", "cache", "temp", "corretto", "roaming", "users", "craft", "program", "世界", "net", "soft", "cache", "temp", "corretto", "roaming", "users", "craft", "program", "世界", "net",
"游戏", "oracle", "game", "file", "data", "jvm", "服务", "server", "客户", "client", "整合", "游戏", "oracle", "game", "file", "data", "jvm", "服务", "server", "客户", "client", "整合",
"应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot", "应用", "运行", "前置", "mojang", "官启", "新建文件夹", "eclipse", "microsoft", "hotspot",
@@ -742,7 +750,7 @@ Wait:
Private LastJavaBaseDir As String = Nothing '用于在下载中断或失败时删除未完成下载的 Java 文件夹,防止残留只下了一半但 -version 能跑的 Java Private LastJavaBaseDir As String = Nothing '用于在下载中断或失败时删除未完成下载的 Java 文件夹,防止残留只下了一半但 -version 能跑的 Java
Private Sub JavaFileList(Loader As LoaderTask(Of Integer, List(Of NetFile))) Private Sub JavaFileList(Loader As LoaderTask(Of Integer, List(Of NetFile)))
Log("[Java] 开始获取 Java 下载信息") Log("[Java] 开始获取 Java 下载信息")
Dim IndexFileStr As String = NetGetCodeByLoader(DlVersionListOrder( Dim IndexFileStr As String = NetRequestByLoader(DlVersionListOrder(
{"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"}, {"https://piston-meta.mojang.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"},
{"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"} {"https://bmclapi2.bangbang93.com/v1/products/java-runtime/2ec0cc96c44e5a76b9c8b7c39df7210883d12871/all.json"}
), IsJson:=True) ), IsJson:=True)
@@ -754,7 +762,7 @@ Wait:
Dim Address As String = TargetEntry.Value("manifest")("url") Dim Address As String = TargetEntry.Value("manifest")("url")
Log($"[Java] 准备下载 Java {TargetEntry.Value("version")("name")}({TargetEntry.Key}):{Address}") Log($"[Java] 准备下载 Java {TargetEntry.Value("version")("name")}({TargetEntry.Key}):{Address}")
'获取文件列表 '获取文件列表
Dim ListFileStr As String = NetGetCodeByLoader(DlSourceOrder({Address}, {Address.Replace("piston-meta.mojang.com", "bmclapi2.bangbang93.com")}), 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 & "\" LastJavaBaseDir = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\.minecraft\runtime\" & TargetEntry.Key & "\"
Dim Results As New List(Of NetFile) Dim Results As New List(Of NetFile)
For Each File As JProperty In CType(GetJson(ListFileStr), JObject)("files") For Each File As JProperty In CType(GetJson(ListFileStr), JObject)("files")
@@ -65,8 +65,8 @@ Public Module ModLaunch
''' 记录启动日志。 ''' 记录启动日志。
''' </summary> ''' </summary>
Public Sub McLaunchLog(Text As String) Public Sub McLaunchLog(Text As String)
Text = SecretFilter(Text, "*") Text = FilterUserName(FilterAccessToken(Text, "*"), "*")
RunInUi(Sub() FrmLaunchRight.LabLog.Text += vbCrLf & "[" & GetTimeNow() & "] " & Text) RunInUi(Sub() FrmLaunchRight.LabLog.Text += $"{vbCrLf}[{GetTimeNow()}] {Text}")
Log("[Launch] " & Text) Log("[Launch] " & Text)
End Sub End Sub
@@ -101,6 +101,8 @@ Public Module ModLaunch
If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical) If Not ex.Message.StartsWithF("$$") Then Hint(ex.Message, HintType.Critical)
Throw Throw
End Try End Try
Dim IsSavingBatch As Boolean = CurrentLaunchOptions?.SaveBatch IsNot Nothing
'正式加载 '正式加载
Try Try
'构造主加载器 '构造主加载器
@@ -145,9 +147,15 @@ Public Module ModLaunch
Select Case LaunchLoader.State Select Case LaunchLoader.State
Case LoadState.Finished Case LoadState.Finished
Hint(McVersionCurrent.Name & " 启动成功!", HintType.Finish) 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 Case LoadState.Aborted
If AbortHint Is Nothing Then If AbortHint Is Nothing Then
Hint(If(CurrentLaunchOptions?.SaveBatch Is Nothing, "已取消启动!", "已取消导出启动脚本!"), HintType.Info) Hint(If(IsSavingBatch, "已取消导出启动脚本!", "已取消启动!"), HintType.Info)
Else Else
Hint(AbortHint, HintType.Finish) Hint(AbortHint, HintType.Finish)
End If End If
@@ -162,7 +170,7 @@ NextInner:
If CurrentEx.Message.StartsWithF("$") Then 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 Throw
ElseIf CurrentEx.InnerException IsNot Nothing Then ElseIf CurrentEx.InnerException IsNot Nothing Then
'检查下一级错误 '检查下一级错误
@@ -172,8 +180,15 @@ NextInner:
'没有特殊处理过的错误信息 '没有特殊处理过的错误信息
McLaunchLog("错误:" & GetExceptionDetail(ex)) McLaunchLog("错误:" & GetExceptionDetail(ex))
Log(ex, Log(ex,
If(CurrentLaunchOptions?.SaveBatch Is Nothing, "Minecraft 启动失败", "导出启动脚本失败"), LogLevel.Msgbox, If(IsSavingBatch, "导出启动脚本失败", "Minecraft 启动失败"), LogLevel.Msgbox,
If(CurrentLaunchOptions?.SaveBatch Is Nothing, "启动失败", "导出启动脚本失败")) If(IsSavingBatch, "导出启动脚本失败", "启动失败"))
'上报
If Not IsSavingBatch Then
Telemetry("Minecraft 启动失败",
"Version", McVersionCurrent.Version.ToString,
"LoginType", GetStringFromEnum(CType(Setup.Get("LoginType"), McLoginType)),
"Exception", FilterUserName(FilterAccessToken(GetExceptionDetail(ex), "*"), "*"))
End If
Throw Throw
End If End If
End Try End Try
@@ -578,11 +593,7 @@ SkipLogin:
Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult)) Private Sub McLoginServerStart(Data As LoaderTask(Of McLoginServer, McLoginResult))
Dim Input As McLoginServer = Data.Input Dim Input As McLoginServer = Data.Input
Dim NeedRefresh As Boolean = False, WasRefreshed As Boolean = False Dim NeedRefresh As Boolean = False, WasRefreshed As Boolean = False
Dim LogUsername As String = Input.UserName McLaunchLog("登录方式:" & Input.Description)
If LogUsername.Contains("@") AndAlso Setup.Get("UiLauncherEmail") Then
LogUsername = AccountFilter(LogUsername)
End If
McLaunchLog("登录方式:" & Input.Description & "(" & LogUsername & ")")
Data.Progress = 0.05 Data.Progress = 0.05
'尝试登录 '尝试登录
If (Not Data.Input.ForceReselectProfile) AndAlso If (Not Data.Input.ForceReselectProfile) AndAlso
@@ -602,7 +613,7 @@ SkipLogin:
McLaunchLog("验证登录失败:" & AllMessage) McLaunchLog("验证登录失败:" & AllMessage)
If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then If (AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout")) AndAlso Not AllMessage.Contains("403") Then
McLaunchLog("已触发超时登录失败") McLaunchLog("已触发超时登录失败")
Throw New Exception("$登录失败:连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好,或尝试使用 VPN!") Throw New Exception("$登录失败:你的网络环境不佳,导致难以连接到海外服务器。" & vbCrLf & "请稍后重试,或使用加速器或 VPN 以改善网络环境。")
End If End If
End Try End Try
Data.Progress = 0.25 Data.Progress = 0.25
@@ -688,11 +699,10 @@ LoginFinish:
'发送登录请求 '发送登录请求
Dim RequestData As New JObject( Dim RequestData As New JObject(
New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True)) New JProperty("accessToken", AccessToken), New JProperty("clientToken", ClientToken), New JProperty("requestUser", True))
NetRequestRetry( NetRequestByClientRetry(
Url:=Data.Input.BaseUrl & "/validate", Data.Input.BaseUrl & "/validate", HttpMethod.Post,
Method:="POST", Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Data:=RequestData.ToString(0), Headers:={{"Accept-Language", "zh-CN"}},
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8") '没有返回值的 ContentType:="application/json; charset=utf-8") '没有返回值的
'将登录结果输出 '将登录结果输出
Data.Output.AccessToken = AccessToken Data.Output.AccessToken = AccessToken
@@ -705,10 +715,9 @@ LoginFinish:
End Sub End Sub
Private Sub McLoginRequestRefresh(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult), RequestUser As Boolean) Private Sub McLoginRequestRefresh(ByRef Data As LoaderTask(Of McLoginServer, McLoginResult), RequestUser As Boolean)
McLaunchLog("刷新登录开始(Refresh, " & Data.Input.Token & ")") McLaunchLog("刷新登录开始(Refresh, " & Data.Input.Token & ")")
Dim LoginJson As JObject = GetJson(NetRequestRetry( Dim LoginJson As JObject = GetJson(NetRequestByClientRetry(
Url:=Data.Input.BaseUrl & "/refresh", Data.Input.BaseUrl & "/refresh", HttpMethod.Post,
Method:="POST", Content:=New JObject(
Data:=New JObject(
New JProperty("selectedProfile", New JObject( New JProperty("selectedProfile", New JObject(
New JProperty("name", Setup.Get($"Cache{Data.Input.Token}Name")), New JProperty("name", Setup.Get($"Cache{Data.Input.Token}Name")),
New JProperty("id", Setup.Get($"Cache{Data.Input.Token}Uuid")) New JProperty("id", Setup.Get($"Cache{Data.Input.Token}Uuid"))
@@ -716,7 +725,7 @@ LoginFinish:
New JProperty("accessToken", Setup.Get($"Cache{Data.Input.Token}Access")), New JProperty("accessToken", Setup.Get($"Cache{Data.Input.Token}Access")),
New JProperty("requestUser", True) New JProperty("requestUser", True)
).ToString(Newtonsoft.Json.Formatting.None), ).ToString(Newtonsoft.Json.Formatting.None),
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}}, Headers:={{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8")) ContentType:="application/json; charset=utf-8"))
'将登录结果输出 '将登录结果输出
If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效!") If LoginJson("selectedProfile") Is Nothing Then Throw New Exception("选择的角色 " & Setup.Get("Cache" & Data.Input.Token & "Name") & " 无效!")
@@ -743,11 +752,10 @@ LoginFinish:
New JProperty("username", Data.Input.UserName), New JProperty("username", Data.Input.UserName),
New JProperty("password", Data.Input.Password), New JProperty("password", Data.Input.Password),
New JProperty("requestUser", True)) New JProperty("requestUser", True))
Dim LoginJson As JObject = GetJson(NetRequestRetry( Dim LoginJson As JObject = GetJson(NetRequestByClientRetry(
Url:=Data.Input.BaseUrl & "/authenticate", Data.Input.BaseUrl & "/authenticate", HttpMethod.Post,
Method:="POST", Content:=RequestData.ToString(Newtonsoft.Json.Formatting.None),
Data:=RequestData.ToString(0), Headers:={{"Accept-Language", "zh-CN"}},
Headers:=New Dictionary(Of String, String) From {{"Accept-Language", "zh-CN"}},
ContentType:="application/json; charset=utf-8")) ContentType:="application/json; charset=utf-8"))
'检查登录结果 '检查登录结果
If LoginJson("availableProfiles").Count = 0 Then If LoginJson("availableProfiles").Count = 0 Then
@@ -845,7 +853,7 @@ LoginFinish:
" - 只注册了账号,但没有加入对应服务器。") " - 只注册了账号,但没有加入对应服务器。")
End Select End Select
ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then ElseIf AllMessage.Contains("超时") OrElse AllMessage.Contains("imeout") OrElse AllMessage.Contains("网络请求失败") Then
Throw New Exception("$登录失败:连接登录服务器超时。" & vbCrLf & "请检查你的网络状况是否良好,或尝试使用 VPN!") Throw New Exception("$登录失败:你的网络环境不佳,导致难以连接到海外服务器。" & vbCrLf & "请稍后重试,或使用加速器或 VPN 以改善网络环境。")
ElseIf ex.Message.StartsWithF("$") Then ElseIf ex.Message.StartsWithF("$") Then
Throw Throw
Else Else
@@ -862,8 +870,9 @@ LoginFinish:
'初始请求 '初始请求
Retry: Retry:
McLaunchLog("开始微软登录步骤 1/6(原始登录)") McLaunchLog("开始微软登录步骤 1/6(原始登录)")
Dim PrepareJson As JObject = GetJson(NetRequestRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", "POST", Dim PrepareJson As JObject = GetJson(NetRequestByClientRetry("https://login.microsoftonline.com/consumers/oauth2/v2.0/devicecode", HttpMethod.Post,
$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access", "application/x-www-form-urlencoded")) Content:=$"client_id={OAuthClientId}&tenant=/consumers&scope=XboxLive.signin%20offline_access",
ContentType:="application/x-www-form-urlencoded"))
McLaunchLog("网页登录地址:" & PrepareJson("verification_uri").ToString) McLaunchLog("网页登录地址:" & PrepareJson("verification_uri").ToString)
'弹窗 '弹窗
@@ -892,12 +901,14 @@ Retry:
Dim Result As String Dim Result As String
Try Try
Result = NetRequestMultiple("https://login.live.com/oauth20_token.srf", "POST", Result = NetRequestByClientMultiple("https://login.live.com/oauth20_token.srf", HttpMethod.Post,
$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access", Content:=$"client_id={OAuthClientId}&refresh_token={Uri.EscapeDataString(Code)}&grant_type=refresh_token&scope=XboxLive.signin%20offline_access",
"application/x-www-form-urlencoded", 2) ContentType:="application/x-www-form-urlencoded",
Catch ex As Exception Headers:={{"Accept-Language", "en-US,en;q=0.5"}, {"X-Requested-With", "XMLHttpRequest"}},
If ex.Message.ContainsF("must sign in again", True) OrElse ex.Message.ContainsF("password expired", True) OrElse ThreadCount:=2)
(ex.Message.Contains("refresh_token") AndAlso ex.Message.Contains("is not valid")) Then '#269 Catch ex As ResponsedWebException
If ex.Response.ContainsF("must sign in again", True) OrElse ex.Response.ContainsF("password expired", True) OrElse
(ex.Response.Contains("refresh_token") AndAlso ex.Response.Contains("is not valid")) Then '#269
Return {"Relogin", ""} Return {"Relogin", ""}
Else Else
Throw Throw
@@ -922,8 +933,8 @@ Retry:
""RelyingParty"": ""http://auth.xboxlive.com"", ""RelyingParty"": ""http://auth.xboxlive.com"",
""TokenType"": ""JWT"" ""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")
Dim ResultJson As JObject = GetJson(Result) Dim ResultJson As JObject = GetJson(Result)
Dim XBLToken As String = ResultJson("Token").ToString Dim XBLToken As String = ResultJson("Token").ToString
Return XBLToken Return XBLToken
@@ -944,21 +955,22 @@ Retry:
}" }"
Dim Result As String Dim Result As String
Try Try
Result = NetRequestMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", "POST", Request, "application/json", 3) Result = NetRequestByClientMultiple("https://xsts.auth.xboxlive.com/xsts/authorize", HttpMethod.Post,
Catch ex As Net.WebException Content:=Request, ContentType:="application/json")
Catch ex As ResponsedWebException
'参考 https://github.com/PrismarineJS/prismarine-auth/blob/master/src/common/Constants.js '参考 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) MyMsgBox("该账号似乎已被微软封禁,无法登录。", "登录失败", "我知道了", IsWarn:=True)
Throw New Exception("$$") Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916233") Then ElseIf ex.Response.Contains("2148916233") Then
If MyMsgBox("你尚未注册 Xbox 账户,请在注册后再登录。", "登录提示", "注册", "取消") = 1 Then If MyMsgBox("你尚未注册 Xbox 账户,请在注册后再登录。", "登录提示", "注册", "取消") = 1 Then
OpenWebsite("https://signup.live.com/signup") OpenWebsite("https://signup.live.com/signup")
End If End If
Throw New Exception("$$") Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916235") Then ElseIf ex.Response.Contains("2148916235") Then
MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请尝试使用加速器或 VPN。", "登录失败", "我知道了") MyMsgBox($"你的网络所在的国家或地区无法登录微软账号。{vbCrLf}请使用加速器或 VPN。", "登录失败", "我知道了")
Throw New Exception("$$") Throw New Exception("$$")
ElseIf ex.Message.Contains("2148916238") Then ElseIf ex.Response.Contains("2148916238") Then
If MyMsgBox("该账号年龄不足,你需要先修改出生日期,然后才能登录。" & vbCrLf & If MyMsgBox("该账号年龄不足,你需要先修改出生日期,然后才能登录。" & vbCrLf &
"该账号目前填写的年龄是否在 13 岁以上?", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then "该账号目前填写的年龄是否在 13 岁以上?", "登录提示", "13 岁以上", "12 岁以下", "我不知道") = 1 Then
OpenWebsite("https://account.live.com/editprof.aspx") OpenWebsite("https://account.live.com/editprof.aspx")
@@ -975,10 +987,15 @@ Retry:
End If End If
End Try End Try
Dim ResultJson As JObject = GetJson(Result) Try '这个 Try 块仅为了追踪 #6683 而添加
Dim XSTSToken As String = ResultJson("Token").ToString Dim ResultJson As JObject = GetJson(Result)
Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString Dim XSTSToken As String = ResultJson("Token").ToString
Return {XSTSToken, UHS} Dim UHS As String = ResultJson("DisplayClaims")("xui")(0)("uhs").ToString
Return {XSTSToken, UHS}
Catch
Log("[Launch] 返回内容:" & vbCrLf & Result)
Throw
End Try
End Function End Function
'微软登录步骤 4:从 {XSTSToken, UHS} 获取 Minecraft AccessToken '微软登录步骤 4:从 {XSTSToken, UHS} 获取 Minecraft AccessToken
Private Function MsLoginStep4(Tokens As String()) As String Private Function MsLoginStep4(Tokens As String()) As String
@@ -987,14 +1004,15 @@ Retry:
Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0) Dim Request As String = New JObject(New JProperty("identityToken", $"XBL3.0 x={Tokens(1)};{Tokens(0)}")).ToString(0)
Dim Result As String Dim Result As String
Try 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")
Catch ex As Net.WebException Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex) Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then If Message.Contains("(429)") Then
Log(ex, "微软登录第 5 步汇报 429") Log(ex, "微软登录第 4 步汇报 429")
Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!") Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
ElseIf Message.Contains("(403)") Then ElseIf Message.Contains("(403)") Then
Log(ex, "微软登录第 5 步汇报 403") Log(ex, "微软登录第 4 步汇报 403")
Throw New Exception("$当前 IP 的登录尝试异常。" & vbCrLf & "如果你使用了 VPN 或加速器,请把它们关掉或更换节点后再试!") Throw New Exception("$当前 IP 的登录尝试异常。" & vbCrLf & "如果你使用了 VPN 或加速器,请把它们关掉或更换节点后再试!")
Else Else
Throw Throw
@@ -1009,7 +1027,8 @@ Retry:
Private Sub MsLoginStep5(AccessToken As String) Private Sub MsLoginStep5(AccessToken As String)
McLaunchLog("开始微软登录步骤 5/6") 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}})
Try Try
Dim ResultJson As JObject = GetJson(Result) Dim ResultJson As JObject = GetJson(Result)
If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then If Not (ResultJson.ContainsKey("items") AndAlso ResultJson("items").Any) Then
@@ -1020,7 +1039,7 @@ Retry:
Throw New Exception("$$") Throw New Exception("$$")
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "微软登录第 6 步异常:" & Result) Log(ex, "微软登录第 5 步异常:" & Result)
Throw Throw
End Try End Try
End Sub End Sub
@@ -1030,14 +1049,15 @@ Retry:
Dim Result As String Dim Result As String
Try Try
Result = NetRequestMultiple("https://api.minecraftservices.com/minecraft/profile", "GET", "", "application/json", 2, New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}}) Result = NetRequestByClientMultiple("https://api.minecraftservices.com/minecraft/profile",
ContentType:="application/json", ThreadCount:=2, Headers:={{"Authorization", "Bearer " & AccessToken}})
Catch ex As Net.WebException Catch ex As Net.WebException
Dim Message As String = GetExceptionSummary(ex) Dim Message As String = GetExceptionSummary(ex)
If Message.Contains("(429)") Then If Message.Contains("(429)") Then
Log(ex, "微软登录第 7 步汇报 429") Log(ex, "微软登录第 6 步汇报 429")
Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!") Throw New Exception("$登录尝试太过频繁,请等待几分钟后再试!")
ElseIf Message.Contains("(404)") Then ElseIf Message.Contains("(404)") Then
Log(ex, "微软登录第 7 步汇报 404") Log(ex, "微软登录第 6 步汇报 404")
RunInNewThread( RunInNewThread(
Sub() Sub()
Select Case MyMsgBox("请先创建 Minecraft 玩家档案,然后再重新登录。", "登录失败", "创建档案", "取消") Select Case MyMsgBox("请先创建 Minecraft 玩家档案,然后再重新登录。", "登录失败", "创建档案", "取消")
@@ -1084,8 +1104,7 @@ Retry:
Uuid = McLoginMojangUuid(SkinName, False) Uuid = McLoginMojangUuid(SkinName, False)
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "离线启动时使用的正版皮肤获取失败") Log(ex, "皮肤信息获取失败,游戏将以无皮肤的方式启动", LogLevel.Hint)
MyMsgBox("由于设置的离线启动时使用的正版皮肤获取失败,游戏将以无皮肤的方式启动。" & vbCrLf & "请检查你的网络是否通畅,或尝试使用 VPN!" & vbCrLf & vbCrLf & "详细的错误信息:" & ex.Message, "皮肤获取失败")
End Try End Try
Case 4 Case 4
'自定义 '自定义
@@ -1104,7 +1123,7 @@ Retry:
If Len(Uuid) = 32 Then Return Uuid If Len(Uuid) = 32 Then Return Uuid
'从官网获取 '从官网获取
Try 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))
If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在(" & Name & ")") If GotJson Is Nothing Then Throw New FileNotFoundException("正版玩家档案不存在(" & Name & ")")
Uuid = If(GotJson("id"), "") Uuid = If(GotJson("id"), "")
Catch ex As Exception Catch ex As Exception
@@ -1210,6 +1229,12 @@ Retry:
End If End If
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 If Setup.Get("LoginType") = McLoginType.Nide Then
'至少 Java 8u101 '至少 Java 8u101
@@ -1221,14 +1246,14 @@ Retry:
'选择 Java '选择 Java
McLaunchLog("Java 版本需求:最低 " & MinVer.ToString & ",最高 " & MaxVer.ToString) McLaunchLog("Java 版本需求:最低 " & MinVer.ToString & ",最高 " & MaxVer.ToString)
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent) McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
If Task.IsAborted Then Exit Sub If Task.IsAborted Then Return
If McLaunchJavaSelected IsNot Nothing Then If McLaunchJavaSelected IsNot Nothing Then
McLaunchLog("选择的 Java:" & McLaunchJavaSelected.ToString) McLaunchLog("选择的 Java:" & McLaunchJavaSelected.ToString)
Exit Sub Return
End If End If
'无合适的 Java '无合适的 Java
If Task.IsAborted Then Exit Sub '中断加载会导致 JavaSelect 异常地返回空值,误判找不到 Java If Task.IsAborted Then Return '中断加载会导致 JavaSelect 异常地返回空值,误判找不到 Java
McLaunchLog("无合适的 Java,需要确认是否自动下载") McLaunchLog("无合适的 Java,需要确认是否自动下载")
Dim JavaCode As String Dim JavaCode As String
If MinVer >= New Version(1, 22) Then '潜在的向后兼容 If MinVer >= New Version(1, 22) Then '潜在的向后兼容
@@ -1276,7 +1301,7 @@ Retry:
'检查下载结果 '检查下载结果
If JavaSearchLoader.State <> LoadState.Loading Then JavaSearchLoader.State = LoadState.Waiting '2872# If JavaSearchLoader.State <> LoadState.Loading Then JavaSearchLoader.State = LoadState.Waiting '2872#
McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent) McLaunchJavaSelected = JavaSelect("$$", MinVer, MaxVer, McVersionCurrent)
If Task.IsAborted Then Exit Sub If Task.IsAborted Then Return
If McLaunchJavaSelected IsNot Nothing Then If McLaunchJavaSelected IsNot Nothing Then
McLaunchLog("选择的 Java:" & McLaunchJavaSelected.ToString) McLaunchLog("选择的 Java:" & McLaunchJavaSelected.ToString)
Else Else
@@ -1354,23 +1379,13 @@ Retry:
McLaunchLog("新版 Game 参数获取成功") McLaunchLog("新版 Game 参数获取成功")
End If End If
'编码参数(#4700、#5892、#5909) '编码参数(#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 McLaunchJavaSelected.VersionCode > 8 Then
If Not Arguments.Contains("-Dstdout.encoding=") Then Arguments += " -Dstdout.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" If Not Arguments.Contains("-Dstderr.encoding=") Then Arguments = "-Dstderr.encoding=UTF-8 " & Arguments
End If End If
If McLaunchJavaSelected.VersionCode >= 18 Then
If Not Arguments.Contains("-Dfile.encoding=") Then Arguments += " -Dfile.encoding=COMPAT"
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 'MJSB
Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""") Arguments = Arguments.Replace(" -Dos.name=Windows 10", " -Dos.name=""Windows 10""")
'全屏 '全屏
@@ -1379,31 +1394,47 @@ Retry:
For Each Arg In CurrentLaunchOptions.ExtraArgs For Each Arg In CurrentLaunchOptions.ExtraArgs
Arguments += " " & Arg.Trim Arguments += " " & Arg.Trim
Next 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) Dim Server As String = If(String.IsNullOrEmpty(CurrentLaunchOptions.ServerIp), Setup.Get("VersionServerEnter", McVersionCurrent), CurrentLaunchOptions.ServerIp)
If Server.Length > 0 Then If Server.Length > 0 Then
If McVersionCurrent.ReleaseTime > New Date(2023, 4, 4) Then If McVersionCurrent.ReleaseTime > New Date(2023, 4, 4) Then
'QuickPlay 'QuickPlay
Arguments += $" --quickPlayMultiplayer ""{Server}""" FinalArguments += $" --quickPlayMultiplayer ""{Server}"""
Else Else
'老版本 '老版本
If Server.Contains(":") Then If Server.Contains(":") Then
'包含端口号 '包含端口号
Arguments += " --server " & Server.Split(":")(0) & " --port " & Server.Split(":")(1) FinalArguments += $" --server {Server.Split(":")(0)} --port {Server.Split(":")(1)}"
Else Else
'不包含端口号 '不包含端口号
Arguments += " --server " & Server & " --port 25565" FinalArguments += $" --server {Server} --port 25565"
End If End If
If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容,有概率导致材质丢失甚至游戏崩溃!", HintType.Critical) If McVersionCurrent.Version.HasOptiFine Then Hint("OptiFine 与自动进入服务器可能不兼容,有概率导致材质丢失甚至游戏崩溃!", HintType.Critical)
End If End If
End If End If
'自定义
Dim ArgumentGame As String = Setup.Get("VersionAdvanceGame", Version:=McVersionCurrent)
Arguments += " " & If(ArgumentGame = "", Setup.Get("LaunchAdvanceGame"), ArgumentGame)
'输出 '输出
McLaunchLog("Minecraft 启动参数:") McLaunchLog("Minecraft 启动参数:")
McLaunchLog(Arguments) McLaunchLog(FinalArguments)
McLaunchArgument = Arguments McLaunchArgument = FinalArguments
End Sub End Sub
'Jvm 部分(第一段) 'Jvm 部分(第一段)
@@ -1429,11 +1460,12 @@ Retry:
End If End If
'Authlib-Injector 'Authlib-Injector
If McLoginLoader.Output.Type = "Auth" Then 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, Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录 "http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
Setup.Get("VersionServerAuthServer", McVersionCurrent)) Setup.Get("VersionServerAuthServer", McVersionCurrent))
Try 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 & DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
" -Dauthlibinjector.side=client" & " -Dauthlibinjector.side=client" &
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response))) " -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
@@ -1498,11 +1530,12 @@ NextVersion:
End If End If
'Authlib-Injector 'Authlib-Injector
If McLoginLoader.Output.Type = "Auth" Then 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, Dim Server As String = If(McLoginLoader.Input.Type = McLoginType.Legacy,
"http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录 "http://hiperauth.tech/api/yggdrasil-hiper/", 'HiPer 登录
Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent)) Setup.Get("VersionServerAuthServer", Version:=McVersionCurrent))
Try 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 & DataList.Insert(0, "-javaagent:""" & PathPure & "authlib-injector.jar""=" & Server &
" -Dauthlibinjector.side=client" & " -Dauthlibinjector.side=client" &
" -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response))) " -Dauthlibinjector.yggdrasil.prefetched=" & Convert.ToBase64String(Encoding.UTF8.GetBytes(Response)))
@@ -1536,10 +1569,8 @@ NextVersion:
DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu=")) DeDuplicateDataList.Add(CurrentEntry.Trim.Replace("McEmu= ", "McEmu="))
Next Next
'#3511 的清理
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M")
'去重 '去重
DeDuplicateDataList.Remove("-XX:MaxDirectMemorySize=256M") '#3511 的清理
Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ") Dim Result As String = Join(DeDuplicateDataList.Distinct.ToList, " ")
'添加 MainClass '添加 MainClass
@@ -1676,6 +1707,7 @@ NextVersion:
GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken) GameArguments.Add("${access_token}", McLoginLoader.Output.AccessToken)
GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken) GameArguments.Add("${auth_session}", McLoginLoader.Output.AccessToken)
GameArguments.Add("${user_type}", "msa") '#1221 GameArguments.Add("${user_type}", "msa") '#1221
GameArguments.Add("${primary_jar}", Version.Path & Version.Name & ".jar") '#6942
'窗口尺寸参数 '窗口尺寸参数
Dim GameSize As Size Dim GameSize As Size
@@ -1688,7 +1720,7 @@ NextVersion:
Case 3 '自定义 Case 3 '自定义
GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth")), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight"))) GameSize = New Size(Math.Max(100, Setup.Get("LaunchArgumentWindowWidth")), Math.Max(100, Setup.Get("LaunchArgumentWindowHeight")))
Case Else Case Else
GameSize = New Size(875, 540) GameSize = New Size(854, 480)
End Select End Select
If McVersionCurrent.Version.McCodeMain <= 12 AndAlso If McVersionCurrent.Version.McCodeMain <= 12 AndAlso
McLaunchJavaSelected.VersionCode <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso McLaunchJavaSelected.VersionCode <= 8 AndAlso McLaunchJavaSelected.Version.Revision >= 200 AndAlso McLaunchJavaSelected.Version.Revision <= 321 AndAlso
@@ -1785,7 +1817,7 @@ NextVersion:
Catch ex As UnauthorizedAccessException Catch ex As UnauthorizedAccessException
McLaunchLog("删除多余文件访问被拒绝,跳过删除步骤") McLaunchLog("删除多余文件访问被拒绝,跳过删除步骤")
McLaunchLog("实际的错误信息:" & GetExceptionSummary(ex)) McLaunchLog("实际的错误信息:" & GetExceptionSummary(ex))
Exit Sub Return
End Try End Try
Next Next
@@ -2100,25 +2132,24 @@ IgnoreCustomSkin:
'输出 bat '输出 bat
Try Try
Dim CmdString As String = Dim CmdString As String =
$"{If(McLaunchJavaSelected.VersionCode > 8 AndAlso McLaunchJavaSelected.VersionCode < 18, "chcp 65001>nul" & vbCrLf, "")}" & $"{If(McLaunchJavaSelected.VersionCode > 8, "chcp 65001>nul" & vbCrLf, "")}" &
"@echo off" & vbCrLf & "@echo off" & vbCrLf &
$"title 启动 - {McVersionCurrent.Name}" & vbCrLf & $"title 启动 - {McVersionCurrent.Name}" & vbCrLf &
"echo 游戏正在启动,请稍候。" & vbCrLf & "echo 游戏正在启动,请稍候。" & vbCrLf &
$"set APPDATA=""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf &
$"cd /D ""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf & $"cd /D ""{ShortenPath(McVersionCurrent.PathIndie)}""" & vbCrLf &
CustomCommandGlobal & vbCrLf & CustomCommandGlobal & vbCrLf &
CustomCommandVersion & vbCrLf & CustomCommandVersion & vbCrLf &
$"""{McLaunchJavaSelected.PathJava}"" {McLaunchArgument}" & vbCrLf & $"""{McLaunchJavaSelected.PathJava}"" {McLaunchArgument}" & vbCrLf &
"echo 游戏已退出。" & vbCrLf & "echo 游戏已退出。" & vbCrLf &
"pause" "pause"
WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), SecretFilter(CmdString, "F"), WriteFile(If(CurrentLaunchOptions.SaveBatch, Path & "PCL\LatestLaunch.bat"), FilterAccessToken(CmdString, "F"),
Encoding:=If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Encoding.Default)) Encoding:=If(McLaunchJavaSelected.VersionCode > 8, Encoding.UTF8, Encoding.Default))
If CurrentLaunchOptions.SaveBatch IsNot Nothing Then If CurrentLaunchOptions.SaveBatch IsNot Nothing Then
McLaunchLog("导出启动脚本完成,强制结束启动过程") McLaunchLog("导出启动脚本完成,强制结束启动过程")
AbortHint = "导出启动脚本成功!" AbortHint = "导出启动脚本成功!"
OpenExplorer(CurrentLaunchOptions.SaveBatch) OpenExplorer(CurrentLaunchOptions.SaveBatch)
Loader.Parent.Abort() Loader.Parent.Abort()
Exit Sub '导出脚本完成 Return '导出脚本完成
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "输出启动脚本失败") Log(ex, "输出启动脚本失败")
@@ -2189,8 +2220,6 @@ IgnoreCustomSkin:
StartInfo.EnvironmentVariables("appdata") = ShortenPath(PathMcFolder) 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 = ShortenPath(McVersionCurrent.PathIndie)
StartInfo.UseShellExecute = False StartInfo.UseShellExecute = False
StartInfo.RedirectStandardOutput = True StartInfo.RedirectStandardOutput = True
@@ -2205,7 +2234,7 @@ IgnoreCustomSkin:
If Loader.IsAborted Then If Loader.IsAborted Then
McLaunchLog("由于取消启动,已强制结束游戏进程") '#1631 McLaunchLog("由于取消启动,已强制结束游戏进程") '#1631
GameProcess.Kill() GameProcess.Kill()
Exit Sub Return
End If End If
Loader.Output = GameProcess Loader.Output = GameProcess
McLaunchProcess = GameProcess McLaunchProcess = GameProcess
@@ -127,7 +127,7 @@ Public Module ModMinecraft
''' </summary> ''' </summary>
Public Sub McFolderLauncherProfilesJsonCreate(Folder As String) Public Sub McFolderLauncherProfilesJsonCreate(Folder As String)
Try Try
If File.Exists(Folder & "launcher_profiles.json") Then Exit Sub If File.Exists(Folder & "launcher_profiles.json") Then Return
Dim ResultJson As String = Dim ResultJson As String =
"{ "{
""profiles"": { ""profiles"": {
@@ -165,12 +165,12 @@ Public Module ModMinecraft
Return _McVersionCurrent Return _McVersionCurrent
End Get End Get
Set(value As McVersion) Set(value As McVersion)
If ReferenceEquals(_McVersionLast, value) Then Exit Property If ReferenceEquals(_McVersionLast, value) Then Return
_McVersionCurrent = value '由于有可能是 Nothing,导致无法初始化,才得这样弄一圈 _McVersionCurrent = value '由于有可能是 Nothing,导致无法初始化,才得这样弄一圈
_McVersionLast = value _McVersionLast = value
If value Is Nothing Then Exit Property If value Is Nothing Then Return
'重置缓存的 Mod 文件夹 '重置缓存的下载文件夹
PageDownloadCompDetail.CachedFolder = Nothing PageDownloadCompDetail.CachedFolder.Clear()
'统一通行证重判 '统一通行证重判
If AniControlEnabled = 0 AndAlso If AniControlEnabled = 0 AndAlso
Setup.Get("VersionServerNide", Version:=value) <> Setup.Get("CacheNideServer") AndAlso Setup.Get("VersionServerNide", Version:=value) <> Setup.Get("CacheNideServer") AndAlso
@@ -208,6 +208,7 @@ Public Module ModMinecraft
Public ReadOnly Property PathIndie As String Public ReadOnly Property PathIndie As String
Get Get
If Setup.IsUnset("VersionArgumentIndieV2", Version:=Me) Then If Setup.IsUnset("VersionArgumentIndieV2", Version:=Me) Then
If Not IsLoaded Then Load()
'决定该版本是否应该被隔离 '决定该版本是否应该被隔离
Dim ShouldBeIndie = Dim ShouldBeIndie =
Function() As Boolean Function() As Boolean
@@ -224,17 +225,17 @@ Public Module ModMinecraft
Return True Return True
End If End If
'根据全局的默认设置决定是否隔离 '根据全局的默认设置决定是否隔离
Log($"[Minecraft] 版本隔离初始化({Name}):从全局默认设置中({Setup.Get("LaunchArgumentIndieV2")})判断") Dim IsRelease As Boolean = State <> McVersionState.Fool AndAlso State <> McVersionState.Old AndAlso State <> McVersionState.Snapshot
Dim IsRelease As Boolean = State = McVersionState.Fool OrElse State = McVersionState.Old OrElse State = McVersionState.Snapshot Log($"[Minecraft] 版本隔离初始化({Name}):从全局默认设置中({Setup.Get("LaunchArgumentIndieV2")})判断,State {GetStringFromEnum(State)},IsRelease {IsRelease},Modable {Modable}")
Select Case Setup.Get("LaunchArgumentIndieV2") Select Case Setup.Get("LaunchArgumentIndieV2")
Case 0 '关闭 Case 0 '关闭
Return False Return False
Case 1 '仅隔离可安装 Mod 的版本 Case 1 '仅隔离可安装 Mod 的版本
Return Modable Return Modable
Case 2 '仅隔离非正式版 Case 2 '仅隔离非正式版
Return IsRelease Return Not IsRelease
Case 3 '隔离非正式版与可安装 Mod 的版本 Case 3 '隔离非正式版与可安装 Mod 的版本
Return Modable OrElse IsRelease Return Not IsRelease OrElse Modable
Case Else '隔离所有版本 Case Else '隔离所有版本
Return True Return True
End Select End Select
@@ -439,6 +440,33 @@ VersionSearchFinish:
''' </summary> ''' </summary>
Public ReleaseTime As New Date(1970, 1, 1, 15, 0, 0) 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> ''' <summary>
''' 该版本的 Json 文本。 ''' 该版本的 Json 文本。
''' </summary> ''' </summary>
@@ -451,17 +479,7 @@ VersionSearchFinish:
Return TrimedJson.StartsWithF("{") AndAlso TrimedJson.EndsWithF("}") Return TrimedJson.StartsWithF("{") AndAlso TrimedJson.EndsWithF("}")
End Function End Function
If _JsonText Is Nothing Then If _JsonText Is Nothing Then
Dim JsonPath As String = Path & Name & ".json" Dim JsonPath As String = GetJsonPath()
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
_JsonText = ReadFile(JsonPath) _JsonText = ReadFile(JsonPath)
'如果 ReadFile 失败会返回空字符串;这可能是由于文件被临时占用,故延时后重试 '如果 ReadFile 失败会返回空字符串;这可能是由于文件被临时占用,故延时后重试
If Not FastJsonCheck(_JsonText) Then If Not FastJsonCheck(_JsonText) Then
@@ -539,9 +557,15 @@ Recheck:
'继续循环 '继续循环
If Inherit.InheritVersion = InheritVersion Then Throw New Exception("版本依赖项出现嵌套:" & InheritVersion) If Inherit.InheritVersion = InheritVersion Then Throw New Exception("版本依赖项出现嵌套:" & InheritVersion)
InheritVersion = Inherit.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) Inherit.JsonObject.Merge(_JsonObject)
_JsonObject = Inherit.JsonObject _JsonObject = Inherit.JsonObject
_JsonObject("libraries") = CurrentLib
GoTo Recheck GoTo Recheck
End If End If
Catch ex As Exception Catch ex As Exception
@@ -579,20 +603,18 @@ Recheck:
Get Get
If Not JsonVersionInited Then If Not JsonVersionInited Then
JsonVersionInited = True JsonVersionInited = True
If File.Exists(Path & Name & ".jar") Then Try
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)) Using JarArchive As New ZipArchive(New FileStream(Path & Name & ".jar", FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json") Dim VersionJson As ZipArchiveEntry = JarArchive.GetEntry("version.json")
If VersionJson IsNot Nothing Then If VersionJson Is Nothing Then Exit Try
Using VersionJsonStream As New StreamReader(VersionJson.Open) Using VersionJsonStream As New StreamReader(VersionJson.Open)
_JsonVersion = GetJson(VersionJsonStream.ReadToEnd) _JsonVersion = GetJson(VersionJsonStream.ReadToEnd)
End Using
End If
End Using End Using
Catch ex As Exception End Using
Log(ex, "从版本 jar 中读取 version.json 失败") Catch ex As Exception
End Try Log(ex, $"从版本 jar 中读取 version.json 失败({Path}{Name}.jar)")
End If End Try
End If End If
Return _JsonVersion Return _JsonVersion
End Get End Get
@@ -967,7 +989,7 @@ ExitDataLoad:
If ToString = "" Then If ToString = "" Then
Return "原版 " & McName Return "原版 " & McName
Else Else
Return McName & ToString & If(ModeDebug, " (" & SortCode & "#)", "") Return McName & ToString
End If End If
End Function End Function
@@ -1133,7 +1155,7 @@ Reload:
'改变当前选择的版本 '改变当前选择的版本
OnLoaded: OnLoaded:
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then If McVersionList.Any(Function(v) v.Key <> McVersionCardType.Error) Then
'尝试读取已储存的选择 '尝试读取已储存的选择
Dim SavedSelection As String = ReadIni(Path & "PCL.ini", "Version") Dim SavedSelection As String = ReadIni(Path & "PCL.ini", "Version")
@@ -1145,7 +1167,7 @@ OnLoaded:
McVersionCurrent = Version McVersionCurrent = Version
Setup.Set("LaunchVersionSelect", McVersionCurrent.Name) Setup.Set("LaunchVersionSelect", McVersionCurrent.Name)
Log("[Minecraft] 选择该文件夹储存的 Minecraft 版本:" & McVersionCurrent.Path) Log("[Minecraft] 选择该文件夹储存的 Minecraft 版本:" & McVersionCurrent.Path)
Exit Sub Return
End If End If
Next Next
Next Next
@@ -1537,7 +1559,7 @@ OnLoaded:
''' 要求玩家选择一个皮肤文件,并进行相关校验。 ''' 要求玩家选择一个皮肤文件,并进行相关校验。
''' </summary> ''' </summary>
Public Function McSkinSelect() As McSkinInfo 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} If FileName = "" Then Return New McSkinInfo With {.IsVaild = False}
@@ -1588,7 +1610,7 @@ OnLoaded:
Case Else Case Else
Throw New ArgumentException("皮肤地址种类无效:" & If(Type, "null")) Throw New ArgumentException("皮肤地址种类无效:" & If(Type, "null"))
End Select End Select
Dim SkinString = NetGetCodeByRequestRetry(Url & Uuid) Dim SkinString = NetRequestByClientRetry(Url & Uuid)
If SkinString = "" Then Throw New Exception("皮肤返回值为空,可能是未设置自定义皮肤的用户") If SkinString = "" Then Throw New Exception("皮肤返回值为空,可能是未设置自定义皮肤的用户")
'处理皮肤地址 '处理皮肤地址
Dim SkinValue As String Dim SkinValue As String
@@ -1609,7 +1631,8 @@ OnLoaded:
If SkinJson("textures") Is Nothing OrElse SkinJson("textures")("skin") Is Nothing OrElse SkinJson("textures")("skin")("url") Is Nothing Then If SkinJson("textures") Is Nothing OrElse SkinJson("textures")("skin") Is Nothing OrElse SkinJson("textures")("skin")("url") Is Nothing Then
Throw New Exception("用户未设置自定义皮肤") Throw New Exception("用户未设置自定义皮肤")
Else 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 End If
'保存缓存 '保存缓存
WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue) WriteIni(PathTemp & "Cache\Skin\Index" & Type & ".ini", Uuid, SkinValue)
@@ -1626,9 +1649,9 @@ OnLoaded:
Dim FileAddress As String = PathTemp & "Cache\Skin\" & GetHash(Address) & ".png" Dim FileAddress As String = PathTemp & "Cache\Skin\" & GetHash(Address) & ".png"
SyncLock McSkinDownloadLock SyncLock McSkinDownloadLock
If Not File.Exists(FileAddress) Then If Not File.Exists(FileAddress) Then
NetDownloadByClient(Address, FileAddress & NetDownloadEnd) NetDownloadByClient(Address, FileAddress & ".PCLDownloading")
File.Delete(FileAddress) File.Delete(FileAddress)
FileSystem.Rename(FileAddress & NetDownloadEnd, FileAddress) FileSystem.Rename(FileAddress & ".PCLDownloading", FileAddress)
Log("[Minecraft] 皮肤下载成功:" & FileAddress) Log("[Minecraft] 皮肤下载成功:" & FileAddress)
End If End If
Return FileAddress Return FileAddress
@@ -1771,61 +1794,60 @@ OnLoaded:
'获取当前支持库列表 '获取当前支持库列表
Log("[Minecraft] 获取支持库列表:" & Version.Name) Log("[Minecraft] 获取支持库列表:" & Version.Name)
McLibListGet = McLibListGetWithJson(Version.JsonObject) Dim Result = McLibListGetWithJson(Version.JsonObject)
If Not IncludeVersionJar Then Return McLibListGet
'需要添加原版 Jar '需要添加原版 Jar
Dim RealVersion As McVersion If IncludeVersionJar Then
Dim RequiredJar As String = Version.JsonObject("jar")?.ToString Dim RealVersion As McVersion
If Version.IsHmclFormatJson OrElse RequiredJar Is Nothing Then Dim RequiredJar As String = Version.JsonObject("jar")?.ToString
'HMCL 项直接使用自身的 Jar If Version.IsHmclFormatJson OrElse RequiredJar Is Nothing Then
'根据 Inherit 获取最深层版本 'HMCL 项直接使用自身的 Jar
Dim OriginalVersion As McVersion = Version '根据 Inherit 获取最深层版本
'1.17+ 的 Forge 不寻找 Inherit Dim OriginalVersion As McVersion = Version
If Not ((Version.Version.HasForge OrElse Version.Version.HasNeoForge) AndAlso Version.Version.McCodeMain >= 17) Then '1.17+ 的 Forge 不寻找 Inherit
Do Until OriginalVersion.InheritVersion = "" If Not ((Version.Version.HasForge OrElse Version.Version.HasNeoForge) AndAlso Version.Version.McCodeMain >= 17) Then
If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do Do Until OriginalVersion.InheritVersion = ""
OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\") If OriginalVersion.InheritVersion = OriginalVersion.Name Then Exit Do
Loop OriginalVersion = New McVersion(PathMcFolder & "versions\" & OriginalVersion.InheritVersion & "\")
Loop
End If
'需要新建对象,否则后面的 Check 会导致 McVersionCurrent 的 State 变回 Original
'复现:启动一个 Snapshot 版本
RealVersion = New McVersion(OriginalVersion.Path)
Else
'Json 已提供 Jar 字段,使用该字段的信息
RealVersion = New McVersion(RequiredJar)
End If End If
'需要新建对象,否则后面的 Check 会导致 McVersionCurrent 的 State 变回 Original Dim ClientUrl As String, ClientSHA1 As String
'复现:启动一个 Snapshot 版本 '判断需求的版本是否存在
RealVersion = New McVersion(OriginalVersion.Path) '不能调用 RealVersion.Check(),可能会莫名其妙地触发 CheckPermission 正被另一进程使用,导致误判前置不存在
Else If Not File.Exists(RealVersion.Path & RealVersion.Name & ".json") Then
'Json 已提供 Jar 字段,使用该字段的信息 RealVersion = Version
RealVersion = New McVersion(RequiredJar) Log("[Minecraft] 可能缺少前置版本 " & RealVersion.Name & ",找不到对应的 json 文件", LogLevel.Debug)
End If
'获取详细下载信息
If RealVersion.JsonObject("downloads") IsNot Nothing AndAlso RealVersion.JsonObject("downloads")("client") IsNot Nothing Then
ClientUrl = RealVersion.JsonObject("downloads")("client")("url")
ClientSHA1 = RealVersion.JsonObject("downloads")("client")("sha1")
Else
ClientUrl = Nothing
ClientSHA1 = Nothing
End If
'把所需的原版 Jar 添加进去
Result.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1})
End If End If
Dim ClientUrl As String, ClientSHA1 As String
'判断需求的版本是否存在
'不能调用 RealVersion.Check(),可能会莫名其妙地触发 CheckPermission 正被另一进程使用,导致误判前置不存在
If Not File.Exists(RealVersion.Path & RealVersion.Name & ".json") Then
RealVersion = Version
Log("[Minecraft] 可能缺少前置版本 " & RealVersion.Name & ",找不到对应的 json 文件", LogLevel.Debug)
End If
'获取详细下载信息
If RealVersion.JsonObject("downloads") IsNot Nothing AndAlso RealVersion.JsonObject("downloads")("client") IsNot Nothing Then
ClientUrl = RealVersion.JsonObject("downloads")("client")("url")
ClientSHA1 = RealVersion.JsonObject("downloads")("client")("sha1")
Else
ClientUrl = Nothing
ClientSHA1 = Nothing
End If
'把所需的原版 Jar 添加进去
McLibListGet.Add(New McLibToken With {.LocalPath = RealVersion.Path & RealVersion.Name & ".jar", .Size = 0, .IsNatives = False, .Url = ClientUrl, .SHA1 = ClientSHA1})
Return Result
End Function End Function
''' <summary> ''' <summary>
''' 获取 Minecraft 某一版本忽视继承的支持库列表,即结果中没有继承项。 ''' 获取 Minecraft 某一版本忽视继承的支持库列表,即结果中没有继承项。
''' </summary> ''' </summary>
Public Function McLibListGetWithJson(JsonObject As JObject, Optional KeepSameNameDifferentVersionResult As Boolean = False, Optional CustomMcFolder 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) CustomMcFolder = If(CustomMcFolder, PathMcFolder)
Dim BasicArray As New List(Of McLibToken)
'添加基础 Json 项
Dim AllLibs As JArray = JsonObject("libraries")
'转换为 LibToken '转换为 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) '清理 null 项(BakaXL 会把没有的项序列化为 null,但会被 Newtonsoft 转换为 JValue,导致 Is Nothing = false;这导致了 #409)
For i = Library.Properties.Count - 1 To 0 Step -1 For i = Library.Properties.Count - 1 To 0 Step -1
@@ -1944,8 +1966,7 @@ OnLoaded:
Try Try
Log("[Minecraft] 开始获取统一通行证下载信息") Log("[Minecraft] 开始获取统一通行证下载信息")
'测试链接:https://auth.mc-user.com:233/00000000000000000000000000000000/ '测试链接:https://auth.mc-user.com:233/00000000000000000000000000000000/
DownloadInfo = GetJson(NetGetCodeByLoader({ DownloadInfo = GetJson(NetRequestByClientRetry("https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)))
"https://auth.mc-user.com:233/" & Setup.Get("VersionServerNide", Version:=Version)}, IsJson:=True))
Catch ex As Exception Catch ex As Exception
Log(ex, "获取统一通行证下载信息失败") Log(ex, "获取统一通行证下载信息失败")
End Try End Try
@@ -1967,10 +1988,9 @@ OnLoaded:
'获取下载信息 '获取下载信息
Try Try
Log("[Minecraft] 开始获取 Authlib-Injector 下载信息") Log("[Minecraft] 开始获取 Authlib-Injector 下载信息")
DownloadInfo = GetJson(NetGetCodeByLoader({ DownloadInfo = GetJson(NetRequestByClientRetry(
"https://authlib-injector.yushi.moe/artifact/latest.json", "https://authlib-injector.yushi.moe/artifact/latest.json",
"https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json" BackupUrl:="https://bmclapi2.bangbang93.com/mirrors/authlib-injector/artifact/latest.json"))
}, IsJson:=True))
Catch ex As Exception Catch ex As Exception
Log(ex, "获取 Authlib-Injector 下载信息失败") Log(ex, "获取 Authlib-Injector 下载信息失败")
End Try End Try
@@ -2015,12 +2035,16 @@ OnLoaded:
'获取 '获取
For Each Token As McLibToken In Libs 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 If Checker.Check(Token.LocalPath) Is Nothing Then Continue For
'文件不符合,添加下载 '文件不符合,添加下载
Dim Urls As New List(Of String) Dim Urls As New List(Of String)
If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then If Token.Url Is Nothing AndAlso Token.Name = "net.minecraftforge:forge:universal" Then '特判修复 Forge 部分 universal 文件缺失 URL(#5455)
'特判修复 Forge 部分 universal 文件缺失 URL(#5455)
Token.Url = "https://maven.minecraftforge.net" & Token.LocalPath.Replace(CustomMcFolder & "libraries", "").Replace("\", "/") Token.Url = "https://maven.minecraftforge.net" & Token.LocalPath.Replace(CustomMcFolder & "libraries", "").Replace("\", "/")
End If End If
If Token.Url IsNot Nothing Then If Token.Url IsNot Nothing Then
@@ -2192,16 +2216,16 @@ OnLoaded:
Dim LocalPath As String Dim LocalPath As String
If Json("map_to_resources") IsNot Nothing AndAlso Json("map_to_resources").ToObject(Of Boolean) Then If Json("map_to_resources") IsNot Nothing AndAlso Json("map_to_resources").ToObject(Of Boolean) Then
'Remap '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 ElseIf Json("virtual") IsNot Nothing AndAlso Json("virtual").ToObject(Of Boolean) Then
'Virtual 'Virtual
LocalPath = PathMcFolder & "assets\virtual\legacy\" & File.Name.Replace("/", "\") LocalPath = $"{PathMcFolder}assets\virtual\legacy\{File.Name}"
Else 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 End If
Result.Add(New McAssetsToken With { Result.Add(New McAssetsToken With {
.LocalPath = LocalPath, .LocalPath = LocalPath.Replace("/", "\"),
.SourcePath = File.Name, .SourcePath = File.Name,
.Hash = File.Value("hash").ToString, .Hash = File.Value("hash").ToString,
.Size = File.Value("size").ToString .Size = File.Value("size").ToString
@@ -2263,7 +2287,7 @@ OnLoaded:
End If End If
Next Next
'进行提示 '进行提示
If Version Is Nothing Then Exit Sub If Version Is Nothing Then Return
Dim Time As Date = Version("releaseTime") Dim Time As Date = Version("releaseTime")
Dim MsgBoxText As String = $"新版本:{VersionName}{vbCrLf}" & Dim MsgBoxText As String = $"新版本:{VersionName}{vbCrLf}" &
If((Date.Now - Time).TotalDays > 1, "更新时间:" & Time.ToString, "更新于:" & GetTimeSpanString(Time - Date.Now, False)) If((Date.Now - Time).TotalDays > 1, "更新时间:" & Time.ToString, "更新于:" & GetTimeSpanString(Time - Date.Now, False))
@@ -2368,26 +2392,33 @@ NextEntry:
End Function End Function
''' <summary> ''' <summary>
''' 为邮箱地址或手机号账号进行部分打码。 ''' 打码字符串中的 AccessToken。
''' </summary> ''' </summary>
Public Function AccountFilter(Account As String) As String Public Function FilterAccessToken(Raw As String, FilterChar As Char) As String
If Account.Contains("@") Then '打码 "accessToken " 后的内容
'是邮箱 If Raw.Contains("accessToken ") Then
Dim Splits = Account.Split("@") For Each Token In RegexSearch(Raw, "(?<=accessToken ([^ ]{5}))[^ ]+(?=[^ ]{5})")
'If Splits(0).Count >= 6 Then Raw = Raw.Replace(Token, New String(FilterChar, Token.Count))
' '前半部分至少 6 位,屏蔽后 4 位 Next
' 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, "*")
End If 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("\" & Token, "\" & New String(FilterChar, Token.Count))
Next
End If
Return Raw
End Function End Function
End Module End Module
@@ -1,7 +1,7 @@
Imports System.IO.Compression Imports System.IO.Compression
Public Module ModMod Public Module ModMod
Private Const LocalModCacheVersion As Integer = 7 Private Const LocalModCacheVersion As Integer = 8
Public Class McMod Public Class McMod
@@ -188,9 +188,9 @@ Public Module ModMod
Private _Dependencies As New Dictionary(Of String, String) Private _Dependencies As New Dictionary(Of String, String)
Private Sub AddDependency(ModID As String, Optional VersionRequirement As String = Nothing) 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 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 If VersionRequirement Is Nothing OrElse ((Not VersionRequirement.Contains(".")) AndAlso (Not VersionRequirement.Contains("-"))) OrElse VersionRequirement.Contains("$") Then
VersionRequirement = Nothing VersionRequirement = Nothing
Else Else
@@ -279,7 +279,7 @@ Public Module ModMod
''' 进行文件可用性检查与 .class 以外的信息获取。 ''' 进行文件可用性检查与 .class 以外的信息获取。
''' </summary> ''' </summary>
Public Sub Load(Optional ForceReload As Boolean = False) Public Sub Load(Optional ForceReload As Boolean = False)
If IsLoaded AndAlso Not ForceReload Then Exit Sub If IsLoaded AndAlso Not ForceReload Then Return
'初始化 '初始化
Init() Init()
Dim Jar As ZipArchive = Nothing Dim Jar As ZipArchive = Nothing
@@ -819,7 +819,7 @@ Finished:
Try Try
RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在更新 Mod") RunInUiWait(Sub() If FrmVersionMod IsNot Nothing Then FrmVersionMod.Load.Text = "正在更新 Mod")
Do Until Not PageVersionMod.UpdatingVersions.Contains(Loader.Input) Do Until Not PageVersionMod.UpdatingVersions.Contains(Loader.Input)
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
Thread.Sleep(100) Thread.Sleep(100)
Loop Loop
Finally Finally
@@ -872,7 +872,7 @@ Finished:
Dim ModUpdateList As New List(Of McMod) Dim ModUpdateList As New List(Of McMod)
For Each ModFile As FileInfo In ModFileList For Each ModFile As FileInfo In ModFileList
Loader.Progress += 0.94 / ModFileList.Count Loader.Progress += 0.94 / ModFileList.Count
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
'加载 McMod 对象 '加载 McMod 对象
Dim ModEntry As New McMod(ModFile.FullName) Dim ModEntry As New McMod(ModFile.FullName)
ModEntry.Load() ModEntry.Load()
@@ -912,7 +912,7 @@ Finished:
End Function) End Function)
'回设 '回设
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
Loader.Output = ModList Loader.Output = ModList
'开始联网加载 '开始联网加载
@@ -939,18 +939,18 @@ Finished:
'开始网络获取 '开始网络获取
Log($"[Mod] 目标加载器:{ModLoaders.Join("/")},版本:{McVersion}") Log($"[Mod] 目标加载器:{ModLoaders.Join("/")},版本:{McVersion}")
Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False Dim EndedThreadCount As Integer = 0, IsFailed As Boolean = False
Dim MainThread As Thread = Thread.CurrentThread Dim CurrentTaskThread As Thread = Thread.CurrentThread
'从 Modrinth 获取信息 '从 Modrinth 获取信息
RunInNewThread( RunInNewThread(
Sub() Sub()
Try Try
'步骤 1:获取 Hash 与对应的工程 ID '步骤 1:获取 Hash 与对应的工程 ID
Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList() Dim ModrinthHashes = Mods.Select(Function(m) m.ModrinthHash).ToList()
Dim ModrinthVersion = CType(GetJson(DlModRequest("https://api.modrinth.com/v2/version_files", "POST", Dim ModrinthVersion As JObject = DlModRequest("https://api.modrinth.com/v2/version_files", HttpMethod.Post,
$"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")), JObject) $"{{""hashes"": [""{ModrinthHashes.Join(""",""")}""], ""algorithm"": ""sha1""}}", "application/json")
Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息") Log($"[Mod] 从 Modrinth 获取到 {ModrinthVersion.Count} 个本地 Mod 的对应信息")
'步骤 2:尝试读取工程信息缓存,构建其他 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)) Dim ModrinthMapping As New Dictionary(Of String, List(Of McMod))
For Each Entry In Mods For Each Entry In Mods
If Not ModrinthVersion.ContainsKey(Entry.ModrinthHash) Then Continue For If Not ModrinthVersion.ContainsKey(Entry.ModrinthHash) Then Continue For
@@ -963,13 +963,12 @@ Finished:
Dim File As New CompFile(ModrinthVersion(Entry.ModrinthHash), CompType.Mod) 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 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] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息") Log($"[Mod] 需要从 Modrinth 获取 {ModrinthMapping.Count} 个本地 Mod 的工程信息")
'步骤 3:获取工程信息 '步骤 3:获取工程信息
If Not ModrinthMapping.Any() Then Exit Sub If Not ModrinthMapping.Any() Then Return
Dim ModrinthProject = CType(GetJson(DlModRequest( Dim ModrinthProject As JArray = DlModRequest(
$"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]", $"https://api.modrinth.com/v2/projects?ids=[""{ModrinthMapping.Keys.Join(""",""")}""]")
"GET", "", "application/json")), JArray)
For Each ProjectJson In ModrinthProject For Each ProjectJson In ModrinthProject
Dim Project As New CompProject(ProjectJson) Dim Project As New CompProject(ProjectJson)
For Each Entry In ModrinthMapping(Project.Id) For Each Entry In ModrinthMapping(Project.Id)
@@ -978,9 +977,9 @@ Finished:
Next Next
Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息,继续获取更新信息") Log($"[Mod] 已从 Modrinth 获取本地 Mod 信息,继续获取更新信息")
'步骤 4:获取更新信息 '步骤 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"", $"{{""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 For Each Entry In Mods
If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.CompFile Is Nothing Then Continue For If Not ModrinthUpdate.ContainsKey(Entry.ModrinthHash) OrElse Entry.CompFile Is Nothing Then Continue For
Dim UpdateFile As New CompFile(ModrinthUpdate(Entry.ModrinthHash), CompType.Mod) Dim UpdateFile As New CompFile(ModrinthUpdate(Entry.ModrinthHash), CompType.Mod)
@@ -1013,13 +1012,13 @@ Finished:
Dim CurseForgeHashes As New List(Of UInteger) Dim CurseForgeHashes As New List(Of UInteger)
For Each Entry In Mods For Each Entry In Mods
CurseForgeHashes.Add(Entry.CurseForgeHash) CurseForgeHashes.Add(Entry.CurseForgeHash)
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
Next Next
Dim CurseForgeRaw = CType(CType(GetJson(DlModRequest("https://api.curseforge.com/v1/fingerprints/432", "POST", Dim CurseForgeRaw As JContainer = DlModRequest("https://api.curseforge.com/v1/fingerprints/432", HttpMethod.Post,
$"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")), JObject)("data")("exactMatches"), JContainer) $"{{""fingerprints"": [{CurseForgeHashes.Join(",")}]}}", "application/json")("data")("exactMatches")
Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息") Log($"[Mod] 从 CurseForge 获取到 {CurseForgeRaw.Count} 个本地 Mod 的对应信息")
'步骤 2:尝试读取工程信息缓存,构建其他 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)) Dim CurseForgeMapping As New Dictionary(Of Integer, List(Of McMod))
For Each Project In CurseForgeRaw For Each Project In CurseForgeRaw
Dim ProjectId = Project("id").ToString 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 If Entry.CompFile Is Nothing OrElse Entry.CompFile.ReleaseDate < File.ReleaseDate Then Entry.CompFile = File
Next Next
Next Next
If Loader.IsAbortedWithThread(MainThread) Then Exit Sub If Loader.IsAbortedWithThread(CurrentTaskThread) Then Return
Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息") Log($"[Mod] 需要从 CurseForge 获取 {CurseForgeMapping.Count} 个本地 Mod 的工程信息")
'步骤 3:获取工程信息 '步骤 3:获取工程信息
If Not CurseForgeMapping.Any() Then Exit Sub If Not CurseForgeMapping.Any() Then Return
Dim CurseForgeProject = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods", "POST", Dim CurseForgeProject = DlModRequest("https://api.curseforge.com/v1/mods", HttpMethod.Post,
$"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")), JObject)("data") $"{{""modIds"": [{CurseForgeMapping.Keys.Join(",")}]}}", "application/json")("data")
Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表 Dim UpdateFileIds As New Dictionary(Of Integer, List(Of McMod)) 'FileId -> 本地 Mod 文件列表
Dim FileIdToProjectSlug As New Dictionary(Of Integer, String) Dim FileIdToProjectSlug As New Dictionary(Of Integer, String)
For Each ProjectJson In CurseForgeProject For Each ProjectJson In CurseForgeProject
@@ -1078,9 +1077,9 @@ Finished:
Next Next
Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息,需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息") Log($"[Mod] 已从 CurseForge 获取本地 Mod 信息,需要获取 {UpdateFileIds.Count} 个用于检查更新的文件信息")
'步骤 4:获取更新文件信息 '步骤 4:获取更新文件信息
If Not UpdateFileIds.Any() Then Exit Sub If Not UpdateFileIds.Any() Then Return
Dim CurseForgeFiles = CType(GetJson(DlModRequest("https://api.curseforge.com/v1/mods/files", "POST", Dim CurseForgeFiles = DlModRequest("https://api.curseforge.com/v1/mods/files", HttpMethod.Post,
$"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")), JObject)("data") $"{{""fileIds"": [{UpdateFileIds.Keys.Join(",")}]}}", "application/json")("data")
Dim UpdateFiles As New Dictionary(Of McMod, CompFile) Dim UpdateFiles As New Dictionary(Of McMod, CompFile)
For Each FileJson In CurseForgeFiles For Each FileJson In CurseForgeFiles
Dim File As New CompFile(FileJson, CompType.Mod) Dim File As New CompFile(FileJson, CompType.Mod)
@@ -1114,13 +1113,13 @@ Finished:
End Sub, "Mod List Detail Loader CurseForge") End Sub, "Mod List Detail Loader CurseForge")
'等待线程结束 '等待线程结束
Do Until EndedThreadCount = 2 Do Until EndedThreadCount = 2
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
Thread.Sleep(10) Thread.Sleep(10)
Loop Loop
'保存缓存 '保存缓存
Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList() Mods = Mods.Where(Function(m) m.Comp IsNot Nothing).ToList()
Log($"[Mod] 联网获取本地 Mod 信息完成,为 {Mods.Count} 个 Mod 更新缓存") Log($"[Mod] 联网获取本地 Mod 信息完成,为 {Mods.Count} 个 Mod 更新缓存")
If Not Mods.Any() Then Exit Sub If Not Mods.Any() Then Return
For Each Entry In Mods For Each Entry In Mods
Entry.CompLoaded = Not IsFailed Entry.CompLoaded = Not IsFailed
Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson() Cache(Entry.ModrinthHash & McVersion & ModLoaders.Join("")) = Entry.ToJson()
@@ -8,7 +8,7 @@ Public Module ModModpack
''' </summary> ''' </summary>
Public Sub ModpackInstall() Public Sub ModpackInstall()
Dim File As String = SelectFile("整合包文件(*.rar;*.zip;*.mrpack)|*.rar;*.zip;*.mrpack", "选择整合包压缩文件") '选择整合包文件 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( RunInThread(
Sub() Sub()
Try Try
@@ -128,7 +128,7 @@ Retry:
'完全不知道为啥会出现文件正在被另一进程使用的问题,总之加个重试 '完全不知道为啥会出现文件正在被另一进程使用的问题,总之加个重试
If RetryCount < 5 Then If RetryCount < 5 Then
Thread.Sleep(RetryCount * 2000) 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 RetryCount += 1
GoTo Retry GoTo Retry
Else Else
@@ -244,7 +244,7 @@ Retry:
'获取 Mod 下载信息 '获取 Mod 下载信息
ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息", ModDownloadLoaders.Add(New LoaderTask(Of Integer, JArray)("获取 Mod 下载信息",
Sub(Task As LoaderTask(Of Integer, JArray)) 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 会跳过那一项 '如果文件已被删除,则 API 会跳过那一项
If ModList.Count > Task.Output.Count Then Throw New Exception("整合包中的部分 Mod 版本已被 Mod 作者删除,所以没法继续安装了,请向整合包作者反馈该问题") If ModList.Count > Task.Output.Count Then Throw New Exception("整合包中的部分 Mod 版本已被 Mod 作者删除,所以没法继续安装了,请向整合包作者反馈该问题")
End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s End Sub) With {.ProgressWeight = ModList.Count / 10}) '每 10 Mod 需要 1s
@@ -258,8 +258,7 @@ Retry:
If FileList.ContainsKey(Id) Then Continue For If FileList.ContainsKey(Id) Then Continue For
'可选 Mod 提示 '可选 Mod 提示
If ModOptionalList.Contains(Id) Then If ModOptionalList.Contains(Id) Then
If MyMsgBox("是否要下载整合包中的可选文件 " & ModJson("displayName").ToString & "?", If MyMsgBox("是否要下载整合包中的可选文件 " & ModJson("displayName").ToString & "?", "下载可选文件", "是", "否") = 2 Then
"下载可选文件", "是", "否") = 2 Then
Continue For Continue For
End If End If
End If End If
@@ -423,7 +422,7 @@ Retry:
End Select End Select
End If 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.AddRange(Urls.Select(Function(u) DlSourceModGet(u)).ToList)
Urls = Urls.Distinct.ToList() Urls = Urls.Distinct.ToList()
Dim TargetPath As String = $"{PathMcFolder}versions\{VersionName}\{File("path")}" Dim TargetPath As String = $"{PathMcFolder}versions\{VersionName}\{File("path")}"
@@ -693,6 +692,7 @@ Retry:
End If End If
'解压 '解压
Dim InstallTemp As String = RequestTaskTempFolder() Dim InstallTemp As String = RequestTaskTempFolder()
Dim SetupFile As String = $"{PathMcFolder}versions\{VersionName}\PCL\Setup.ini"
Dim InstallLoaders As New List(Of LoaderBase) Dim InstallLoaders As New List(Of LoaderBase)
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件", InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
Sub(Task As LoaderTask(Of String, Integer)) Sub(Task As LoaderTask(Of String, Integer))
@@ -701,6 +701,12 @@ Retry:
InstallTemp & ArchiveBaseFolder & "overrides", InstallTemp & ArchiveBaseFolder & "overrides",
PathMcFolder & "versions\" & VersionName, PathMcFolder & "versions\" & VersionName,
Task, 0.4) 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
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s 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 整合包未提供游戏版本附加信息,无法安装!") If Json("addons") Is Nothing Then Throw New Exception("该 MCBBS 整合包未提供游戏版本附加信息,无法安装!")
@@ -15,7 +15,7 @@
TriggerLauncherShutdown = False TriggerLauncherShutdown = False
End If End If
Next Next
If IsWatcherRunning = IsRunning Then Exit Sub If IsWatcherRunning = IsRunning Then Return
IsWatcherRunning = IsRunning IsWatcherRunning = IsRunning
If IsWatcherRunning Then If IsWatcherRunning Then
MinecraftStart() MinecraftStart()
@@ -81,7 +81,7 @@
WatcherStateChanged() WatcherStateChanged()
'初始化进程与日志读取 '初始化进程与日志读取
Me.GameProcess = Loader.Input GameProcess = Loader.Input
GameProcess.BeginOutputReadLine() GameProcess.BeginOutputReadLine()
GameProcess.BeginErrorReadLine() GameProcess.BeginErrorReadLine()
AddHandler GameProcess.OutputDataReceived, AddressOf LogReceived AddHandler GameProcess.OutputDataReceived, AddressOf LogReceived
@@ -118,7 +118,7 @@
Return _State Return _State
End Get End Get
Set(value As MinecraftState) Set(value As MinecraftState)
If _State = value Then Exit Property If _State = value Then Return
_State = value _State = value
WatcherStateChanged() WatcherStateChanged()
End Set End Set
@@ -144,7 +144,7 @@
'输出文本 '输出文本
Dim Copyed As New List(Of String) Dim Copyed As New List(Of String)
SyncLock WaitingLogLock SyncLock WaitingLogLock
If Not WaitingLog.Any() Then Exit Sub If Not WaitingLog.Any() Then Return
Copyed = WaitingLog Copyed = WaitingLog
WaitingLog = New List(Of String)(1000) WaitingLog = New List(Of String)(1000)
End SyncLock End SyncLock
@@ -180,8 +180,9 @@
Public LatestLog As New Queue(Of String) Public LatestLog As New Queue(Of String)
Private Sub GameLog(Text As 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) Text = Text.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf)
'If Text.Contains("�����") Then Hint("检测到错误的日志编码:" & Text)
'加入预存储 '加入预存储
LatestLog.Enqueue(Text) LatestLog.Enqueue(Text)
If LatestLog.Count >= 501 Then LatestLog.Dequeue() If LatestLog.Count >= 501 Then LatestLog.Dequeue()
@@ -256,8 +257,8 @@
Private WindowHandle As IntPtr Private WindowHandle As IntPtr
Private Sub TimerWindow() Private Sub TimerWindow()
Try Try
If GameProcess.HasExited Then Exit Sub If GameProcess.HasExited Then Return
If IsWindowFinished Then Exit Sub If IsWindowFinished Then Return
'获取全部窗口,检查是否有新增的 '获取全部窗口,检查是否有新增的
Dim MinecraftWindow As KeyValuePair(Of IntPtr, String)? = Nothing Dim MinecraftWindow As KeyValuePair(Of IntPtr, String)? = Nothing
Try Try
@@ -267,10 +268,10 @@
Log(ex, "由于反作弊或安全软件拦截,PCL 无法操作游戏窗口", LogLevel.Hint) Log(ex, "由于反作弊或安全软件拦截,PCL 无法操作游戏窗口", LogLevel.Hint)
IsWindowFinished = True IsWindowFinished = True
End Try End Try
If MinecraftWindow Is Nothing Then Exit Sub If MinecraftWindow Is Nothing Then Return
Dim MinecraftWindowName = MinecraftWindow.Value.Value, MinecraftWindowHandle = MinecraftWindow.Value.Key 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 窗口 '已找到 Minecraft 窗口
WindowHandle = MinecraftWindowHandle WindowHandle = MinecraftWindowHandle
WatcherLog($"Minecraft 窗口已加载:{MinecraftWindowName}({MinecraftWindowHandle.ToInt64})") WatcherLog($"Minecraft 窗口已加载:{MinecraftWindowName}({MinecraftWindowHandle.ToInt64})")
@@ -291,8 +292,8 @@
End Sub, "MinecraftWindowMaximize") End Sub, "MinecraftWindowMaximize")
End If End If
ElseIf Not IsWindowAppeared Then ElseIf Not IsWindowAppeared Then
'已找到 FML 窗口 '已找到 Mod Loader 窗口
WatcherLog("FML 窗口已加载:" & MinecraftWindowName & "(" & MinecraftWindowHandle.ToInt64 & ")") WatcherLog("Mod Loader 窗口已加载:" & MinecraftWindowName & "(" & MinecraftWindowHandle.ToInt64 & ")")
End If End If
IsWindowAppeared = True IsWindowAppeared = True
Catch ex As Exception Catch ex As Exception
@@ -307,27 +308,27 @@
TryGetMinecraftWindow = Nothing TryGetMinecraftWindow = Nothing
EnumWindows( EnumWindows(
Sub(hwnd As IntPtr, lParam As Integer) 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) Dim str As New StringBuilder(512)
GetClassName(hwnd, str, str.Capacity) GetClassName(hwnd, str, str.Capacity)
Dim ClassName As String = str.ToString 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) str = New StringBuilder(512)
GetWindowText(hwnd, str, str.Capacity) GetWindowText(hwnd, str, str.Capacity)
Dim WindowText As String = str.ToString Dim WindowText As String = str.ToString
'有的 Mod 可以修改窗口标题,所以不能检测是否为 Minecraft 打头,这并不准确 '有的 Mod 可以修改窗口标题,所以不能检测是否为 Minecraft 打头,这并不准确
'部分版本会搞个 GLFW message window 出来所以得反选 '部分版本会搞个 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 Dim ProcessId As Integer
GetWindowThreadProcessId(hwnd, ProcessId) GetWindowThreadProcessId(hwnd, ProcessId)
Try Try
If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Exit Sub '需要是此后启动的进程 If Process.GetProcessById(ProcessId).StartTime < GameProcess.StartTime Then Return '需要是此后启动的进程
Catch ex As Exception Catch ex As Exception
Log(ex, "枚举 Minecraft 窗口进程失败") Log(ex, "枚举 Minecraft 窗口进程失败")
Exit Sub Return
End Try End Try
'返回 '返回
TryGetMinecraftWindow = New KeyValuePair(Of IntPtr, String)(hwnd, WindowText) TryGetMinecraftWindow = New KeyValuePair(Of IntPtr, String)(hwnd, WindowText)
@@ -344,18 +345,18 @@
'崩溃处理 '崩溃处理
Private Sub Crashed() 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 State = MinecraftState.Crashed
'崩溃分析 '崩溃分析
WatcherLog("Minecraft 已崩溃,将在 2 秒后开始崩溃分析") WatcherLog("Minecraft 已崩溃,将在 2 秒后开始崩溃分析")
Hint("检测到 Minecraft 出现错误,错误分析已开始……") Hint("检测到 Minecraft 出现错误,错误分析已开始……", HintType.Critical)
FeedbackInfo() FeedbackInfo()
RunInNewThread( RunInNewThread(
Sub() Sub()
Try Try
Thread.Sleep(2000) Thread.Sleep(2000)
WatcherLog("崩溃分析开始") WatcherLog("崩溃分析开始")
Dim Analyzer As New CrashAnalyzer(PID) Dim Analyzer As New CrashAnalyzer(Version)
Analyzer.Collect(Version.PathIndie, LatestLog.ToList) Analyzer.Collect(Version.PathIndie, LatestLog.ToList)
Analyzer.Prepare() Analyzer.Prepare()
Analyzer.Analyze(Version) Analyzer.Analyze(Version)
+9 -5
View File
@@ -1,7 +1,7 @@
Public Module ModEvent Public Module ModEvent
Public Sub TryStartEvent(Type As String, Data As String) Public Sub TryStartEvent(Type As String, Data As String)
If String.IsNullOrWhiteSpace(Type) Then Exit Sub If String.IsNullOrWhiteSpace(Type) Then Return
Dim RealData As String() = {""} Dim RealData As String() = {""}
If Data IsNot Nothing Then RealData = Data.Split("|") If Data IsNot Nothing Then RealData = Data.Split("|")
StartEvent(Type, RealData) StartEvent(Type, RealData)
@@ -15,7 +15,7 @@
Data(0) = Data(0).Replace("\", "/") Data(0) = Data(0).Replace("\", "/")
If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议(#2200) If Not Data(0).Contains("://") OrElse Data(0).StartsWithF("file", True) Then '为了支持更多协议(#2200)
MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序,请将 EventType 改为 打开文件。", "事件执行失败") MyMsgBox("EventData 必须为一个网址。" & vbCrLf & "如果想要启动程序,请将 EventType 改为 打开文件。", "事件执行失败")
Exit Sub Return
End If End If
Hint("正在开启中,请稍候……") Hint("正在开启中,请稍候……")
OpenWebsite(Data(0)) OpenWebsite(Data(0))
@@ -39,7 +39,7 @@
Case 2 Case 2
Setup.Set("HintCustomCommand", True) Setup.Set("HintCustomCommand", True)
Case 3 Case 3
Exit Sub Return
End Select End Select
End If End If
Dim Info As New ProcessStartInfo With { Dim Info As New ProcessStartInfo With {
@@ -58,7 +58,7 @@
If Data(0) = "\current" Then If Data(0) = "\current" Then
If McVersionCurrent Is Nothing Then If McVersionCurrent Is Nothing Then
Hint("请先选择一个 Minecraft 版本!", HintType.Critical) Hint("请先选择一个 Minecraft 版本!", HintType.Critical)
Exit Sub Return
Else Else
Data(0) = McVersionCurrent.Name Data(0) = McVersionCurrent.Name
End If End If
@@ -100,7 +100,7 @@
Data(0) = Data(0).Replace("\", "/") Data(0) = Data(0).Replace("\", "/")
If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then If Not (Data(0).StartsWithF("http://", True) OrElse Data(0).StartsWithF("https://", True)) Then
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败") MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL 不支持其他乱七八糟的下载协议。", "事件执行失败")
Exit Sub Return
End If End If
Try Try
Select Case Data.Length Select Case Data.Length
@@ -115,6 +115,10 @@
PageOtherTest.StartCustomDownload(Data(0), "未知") PageOtherTest.StartCustomDownload(Data(0), "未知")
End Try End Try
Case "修改设置"
Setup.Set(Data(0), Data(1))
Hint($"已写入设置:{Data(0)} → {Data(1)}", HintType.Finish)
Case Else Case Else
MyMsgBox("未知的事件类型:" & Type & vbCrLf & "请检查事件类型填写是否正确,或者 PCL 是否为最新版本。", "事件执行失败") MyMsgBox("未知的事件类型:" & Type & vbCrLf & "请检查事件类型填写是否正确,或者 PCL 是否为最新版本。", "事件执行失败")
End Select End Select
+19 -18
View File
@@ -34,12 +34,12 @@ Public Module ModMain
''' <summary> ''' <summary>
''' 等待弹出的提示列表。以 {String, HintType, Log As Boolean} 形式存储为数组。 ''' 等待弹出的提示列表。以 {String, HintType, Log As Boolean} 形式存储为数组。
''' </summary> ''' </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>
''' 在窗口左下角弹出提示文本。 ''' 在窗口左下角弹出提示文本。
''' </summary> ''' </summary>
Public Sub Hint(Text As String, Optional Type As HintType = HintType.Info, Optional Log As Boolean = True) 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}) HintWaiting.Add(New HintMessage With {.Text = If(Text, ""), .Type = Type, .Log = Log})
End Sub End Sub
@@ -47,7 +47,7 @@ Public Module ModMain
Try Try
'Tag 存储了:{ 是否可以重用, Uuid } 'Tag 存储了:{ 是否可以重用, Uuid }
If Not HintWaiting.Any() Then Exit Sub If Not HintWaiting.Any() Then Return
Do While HintWaiting.Any Do While HintWaiting.Any
''清除空提示 ''清除空提示
'If IsNothing(HintWaiting(0)) OrElse IsNothing(HintWaiting(0)(0)) Then '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 WaitingMyMsgBox As List(Of MyMsgBoxConverter) = If(WaitingMyMsgBox, New List(Of MyMsgBoxConverter))
Public Sub MyMsgBoxTick() Public Sub MyMsgBoxTick()
Try 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 If FrmMain.PanMsg.Children.Count > 0 Then
'弹窗中 '弹窗中
FrmMain.PanMsg.Visibility = Visibility.Visible FrmMain.PanMsg.Visibility = Visibility.Visible
@@ -637,7 +637,7 @@ NextFile:
Catch ex As Exception Catch ex As Exception
Log(ex, "检查帮助文件夹失败", LogLevel.Msgbox) Log(ex, "检查帮助文件夹失败", LogLevel.Msgbox)
End Try End Try
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
'将文件实例化 '将文件实例化
Dim Dict As New List(Of HelpEntry) Dim Dict As New List(Of HelpEntry)
@@ -653,7 +653,7 @@ NextFile:
'回设 '回设
If Not Dict.Any() Then Throw New Exception("未找到可用的帮助;若不需要帮助页面,可以在 设置 → 个性化 → 功能隐藏 中将其隐藏") If Not Dict.Any() Then Throw New Exception("未找到可用的帮助;若不需要帮助页面,可以在 设置 → 个性化 → 功能隐藏 中将其隐藏")
If Loader.IsAborted Then Exit Sub If Loader.IsAborted Then Return
Loader.Output = Dict Loader.Output = Dict
Catch ex As Exception Catch ex As Exception
@@ -696,8 +696,8 @@ NextFile:
Private AprilDistance As Integer = 0 Private AprilDistance As Integer = 0
Private Sub TimerFool() Private Sub TimerFool()
Try Try
If FrmLaunchLeft Is Nothing OrElse FrmLaunchLeft.AprilPosTrans Is Nothing OrElse FrmMain.lastMouseArg Is Nothing 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 Exit Sub If IsAprilGiveup OrElse FrmMain.PageCurrent <> FormMain.PageType.Launch OrElse AniControlEnabled <> 0 OrElse Not FrmLaunchLeft.BtnLaunch.IsLoaded Then Return
'计算是否空闲 '计算是否空闲
Dim MousePos = FrmMain.lastMouseArg.GetPosition(FrmMain) Dim MousePos = FrmMain.lastMouseArg.GetPosition(FrmMain)
@@ -766,7 +766,7 @@ NextFile:
'移动 '移动
AprilSpeed = AprilSpeed * 0.8 + Acc AprilSpeed = AprilSpeed * 0.8 + Acc
Dim SpeedValue = Math.Min(60, AprilSpeed.Length) Dim SpeedValue = Math.Min(60, AprilSpeed.Length)
If SpeedValue < 0.01 Then Exit Sub If SpeedValue < 0.01 Then Return
AprilSpeed.Normalize() AprilSpeed.Normalize()
AprilSpeed *= SpeedValue AprilSpeed *= SpeedValue
AprilDistance += SpeedValue AprilDistance += SpeedValue
@@ -913,7 +913,7 @@ NextFile:
If ThemeDontClick = 2 Then ThemeRefresh() If ThemeDontClick = 2 Then ThemeRefresh()
#End Region #End Region
Catch ex As Exception Catch ex As Exception
Log(ex, "短程主时钟执行异常", LogLevel.Assert) Log(ex, "短程主时钟执行异常", LogLevel.Critical)
End Try End Try
Timer4Count += 1 Timer4Count += 1
If Timer4Count = 4 Then If Timer4Count = 4 Then
@@ -933,15 +933,16 @@ NextFile:
#Region "每 7.5s 执行一次的代码" #Region "每 7.5s 执行一次的代码"
If FrmMain.BtnExtraApril_ShowCheck AndAlso AprilDistance <> 0 Then FrmMain.BtnExtraApril.Ribble() If FrmMain.BtnExtraApril_ShowCheck AndAlso AprilDistance <> 0 Then FrmMain.BtnExtraApril.Ribble()
'以未知原因窗口被丢到一边去的修复(Top、Left = -25600),还有 #745 '以未知原因窗口被丢到一边去的修复(Top、Left = -25600),还有 #745
RunInUi(Sub() RunInUi(
If Not FrmMain.Hidden Then Sub()
If FrmMain.Top < -9000 Then FrmMain.Top = 100 If Not FrmMain.Hidden Then
If FrmMain.Left < -9000 Then FrmMain.Left = 100 '窗口拉至最大时 Left = -18.8 If FrmMain.Top < -9000 Then FrmMain.Top = 100
End If If FrmMain.Left < -9000 Then FrmMain.Left = 100 '窗口拉至最大时 Left = -18.8
End Sub) End If
End Sub)
#End Region #End Region
Catch ex As Exception Catch ex As Exception
Log(ex, "长程主时钟执行异常", LogLevel.Assert) Log(ex, "长程主时钟执行异常", LogLevel.Critical)
End Try End Try
End If End If
End Sub End Sub
@@ -957,7 +958,7 @@ NextFile:
Log(ex, "程序主时钟出错", LogLevel.Feedback) Log(ex, "程序主时钟出错", LogLevel.Feedback)
End Try End Try
End Sub, "Timer Main") End Sub, "Timer Main")
If Not IsAprilEnabled Then Exit Sub If Not IsAprilEnabled Then Return
RunInNewThread( RunInNewThread(
Sub() Sub()
Try Try
+1 -1
View File
@@ -247,7 +247,7 @@
Log("[Music] 已恢复播放") Log("[Music] 已恢复播放")
Try Try
MusicNAudio?.Play() 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?.Stop()
MusicNAudio?.Play() MusicNAudio?.Play()
End Try End Try
+64 -71
View File
@@ -9,9 +9,11 @@ Friend Module ModSecret
'在开源版的注册表与常规版的注册表隔离,以防数据冲突 '在开源版的注册表与常规版的注册表隔离,以防数据冲突
Public Const RegFolder As String = "PCLDebug" Public Const RegFolder As String = "PCLDebug"
'用于微软登录的 ClientId '用于微软登录的 ClientId
Public Const OAuthClientId As String = "" Public OAuthClientId As String = If(Environment.GetEnvironmentVariable("PCL_MS_CLIENT_ID"), "")
'CurseForge API Key '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() Friend Sub SecretOnApplicationStart()
'提升 UI 线程优先级 '提升 UI 线程优先级
@@ -67,61 +69,27 @@ Friend Module ModSecret
If Not DataList.Any(Function(d) d.Contains("-Dlog4j2.formatMsgNoLookups=true")) Then DataList.Add("-Dlog4j2.formatMsgNoLookups=true") If Not DataList.Any(Function(d) d.Contains("-Dlog4j2.formatMsgNoLookups=true")) Then DataList.Add("-Dlog4j2.formatMsgNoLookups=true")
End Sub 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 #End Region
#Region "网络鉴权" #Region "网络鉴权"
Friend Function SecretCdnSign(UrlWithMark As String) Friend Function SecretCdnSign(UrlWithMark As String) As String
If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark If Not UrlWithMark.EndsWithF("{CDN}") Then Return UrlWithMark
Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20") Return UrlWithMark.Replace("{CDN}", "").Replace(" ", "%20")
End Function End Function
''' <summary> ''' <summary>
''' 设置 Headers 的 UA、Referer。 ''' 设置 Headers 的 UA、Referer。
''' </summary> ''' </summary>
Friend Sub SecretHeadersSign(Url As String, ByRef Client As WebClient, Optional UseBrowserUserAgent As Boolean = False) Friend Sub SecretHeadersSign(Url As String, ByRef Req As HttpRequestMessage, Optional UseBrowserUserAgent As Boolean = False)
If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then If Url.Contains("baidupcs.com") OrElse Url.Contains("baidu.com") Then
Client.Headers("User-Agent") = "LogStatistic" '#4951 Req.Headers.Add("User-Agent", "LogStatistic") '#4951
ElseIf UseBrowserUserAgent Then ElseIf UseBrowserUserAgent Then
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode & " Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36" Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode} Mozilla/5.0 AppleWebKit/537.36 Chrome/63.0.3239.132 Safari/537.36")
Else Else
Client.Headers("User-Agent") = "PCL2/" & VersionStandardCode Req.Headers.Add("User-Agent", $"PCL2/{VersionStandardCode}")
End If End If
Client.Headers("Referer") = "http://" & VersionCode & ".open.pcl2.server/" Req.Headers.Add("Referer", $"http://{VersionCode}.open.pcl2.server/")
If Url.Contains("api.curseforge.com") Then Client.Headers("x-api-key") = CurseForgeAPIKey If Url.Contains("api.curseforge.com") Then Req.Headers.Add("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
End Sub End Sub
#End Region #End Region
@@ -198,45 +166,70 @@ Friend Module ModSecret
Public ThemeDontClick As Integer = 0 Public ThemeDontClick As Integer = 0
Public Sub ThemeRefresh(Optional NewTheme As Integer = -1) 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 End Sub
Public Sub ThemeRefreshMain() Public Sub ThemeRefreshMain()
RunInUi( RunInUi(
Sub() 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)} Dim Brush = New LinearGradientBrush With {.EndPoint = New Point(1, 0), .StartPoint = New Point(0, 0)}
If ThemeNow = 5 Then If TypeOf ColorHueTopbarDelta Is Integer Then
Brush.GradientStops.Add(New GradientStop With {.Offset = 0, .Color = New MyColor().FromHSL2(ColorHue, ColorSat, 25)}) 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, 15)}) 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, ColorSat, 25)}) Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta, ColorSat, 48 + ColorLightAdjust)})
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()
Else 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, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(0), ColorSat, 48 + 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.5, .Color = New MyColor().FromHSL2(ColorHue + ColorHueTopbarDelta(1), ColorSat, 54 + 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 + ColorHueTopbarDelta(2), ColorSat, 48 + ColorLightAdjust)})
Brush.GradientStops.Add(New GradientStop With {.Offset = 1, .Color = New MyColor().FromHSL2(ColorHue + 21, ColorSat, 53 + ColorLightAdjust)})
FrmMain.PanTitle.Background = Brush
End If End If
FrmMain.PanTitle.Background = Brush
FrmMain.PanTitle.Background.Freeze()
'主页面背景 '主页面背景
If Setup.Get("UiBackgroundColorful") Then If Setup.Get("UiBackgroundColorful") Then
Brush = New LinearGradientBrush With {.EndPoint = New Point(0.1, 1), .StartPoint = New Point(0.9, 0)} 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.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.9, 90)}) 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 + 20, Math.Min(60, ColorSat) * 0.5, 80)}) Brush.GradientStops.Add(New GradientStop With {.Offset = 1.1, .Color = New MyColor().FromHSL2(ColorHue + 15, ColorSat * 0.8, 91)})
FrmMain.PanForm.Background = Brush FrmMain.PanForm.Background = Brush
Else Else
FrmMain.PanForm.Background = New MyColor(245, 245, 245) 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
+151
View File
@@ -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
@@ -51,6 +51,6 @@ Imports System.Runtime.InteropServices
' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号 ' 可以指定所有值,也可以使用以下所示的 "*" 预置版本号和修订号
' 方法是按如下所示使用“*” ' 方法是按如下所示使用“*”
<Assembly: AssemblyVersion("2.10.0.0")> <Assembly: AssemblyVersion("2.10.6.0")>
<Assembly: AssemblyFileVersion("2.10.0.0")> <Assembly: AssemblyFileVersion("2.10.6.0")>
<Assembly: NeutralResourcesLanguage("")> <Assembly: NeutralResourcesLanguage("")>
+55 -15
View File
@@ -63,9 +63,9 @@ Namespace My.Resources
'''<summary> '''<summary>
''' 查找 System.Byte[] 类型的本地化资源。 ''' 查找 System.Byte[] 类型的本地化资源。
'''</summary> '''</summary>
Friend ReadOnly Property Custom() As Byte() Friend ReadOnly Property CacheCow_Client() As Byte()
Get Get
Dim obj As Object = ResourceManager.GetObject("Custom", resourceCulture) Dim obj As Object = ResourceManager.GetObject("CacheCow.Client", resourceCulture)
Return CType(obj,Byte()) Return CType(obj,Byte())
End Get End Get
End Property End Property
@@ -73,9 +73,29 @@ Namespace My.Resources
'''<summary> '''<summary>
''' 查找 System.Byte[] 类型的本地化资源。 ''' 查找 System.Byte[] 类型的本地化资源。
'''</summary> '''</summary>
Friend ReadOnly Property Dialogs() As Byte() Friend ReadOnly Property CacheCow_Client_FileStore() As Byte()
Get Get
Dim obj As Object = ResourceManager.GetObject("Dialogs", resourceCulture) Dim obj As Object = ResourceManager.GetObject("CacheCow.Client.FileStore", resourceCulture)
Return CType(obj,Byte())
End Get
End Property
'''<summary>
''' 查找 System.Byte[] 类型的本地化资源。
'''</summary>
Friend ReadOnly Property CacheCow_Common() As Byte()
Get
Dim obj As Object = ResourceManager.GetObject("CacheCow.Common", resourceCulture)
Return CType(obj,Byte())
End Get
End Property
'''<summary>
''' 查找 System.Byte[] 类型的本地化资源。
'''</summary>
Friend ReadOnly Property Custom() As Byte()
Get
Dim obj As Object = ResourceManager.GetObject("Custom", resourceCulture)
Return CType(obj,Byte()) Return CType(obj,Byte())
End Get End Get
End Property End Property
@@ -105,7 +125,7 @@ Namespace My.Resources
'''</summary> '''</summary>
Friend ReadOnly Property Imazen_WebP() As Byte() Friend ReadOnly Property Imazen_WebP() As Byte()
Get Get
Dim obj As Object = ResourceManager.GetObject("Imazen_WebP", resourceCulture) Dim obj As Object = ResourceManager.GetObject("Imazen.WebP", resourceCulture)
Return CType(obj,Byte()) Return CType(obj,Byte())
End Get End Get
End Property End Property
@@ -120,16 +140,6 @@ Namespace My.Resources
End Get End Get
End Property End Property
'''<summary>
''' 查找 System.Byte[] 类型的本地化资源。
'''</summary>
Friend ReadOnly Property Json() As Byte()
Get
Dim obj As Object = ResourceManager.GetObject("Json", resourceCulture)
Return CType(obj,Byte())
End Get
End Property
'''<summary> '''<summary>
''' 查找 System.Byte[] 类型的本地化资源。 ''' 查找 System.Byte[] 类型的本地化资源。
'''</summary> '''</summary>
@@ -160,6 +170,36 @@ Namespace My.Resources
End Get End Get
End Property End Property
'''<summary>
''' 查找 System.Byte[] 类型的本地化资源。
'''</summary>
Friend ReadOnly Property Newtonsoft_Json() As Byte()
Get
Dim obj As Object = ResourceManager.GetObject("Newtonsoft.Json", resourceCulture)
Return CType(obj,Byte())
End Get
End Property
'''<summary>
''' 查找 System.Byte[] 类型的本地化资源。
'''</summary>
Friend ReadOnly Property Ookii_Dialogs_Wpf() As Byte()
Get
Dim obj As Object = ResourceManager.GetObject("Ookii.Dialogs.Wpf", resourceCulture)
Return CType(obj,Byte())
End Get
End Property
'''<summary>
''' 查找 System.Byte[] 类型的本地化资源。
'''</summary>
Friend ReadOnly Property System_Net_Http_Formatting() As Byte()
Get
Dim obj As Object = ResourceManager.GetObject("System.Net.Http.Formatting", resourceCulture)
Return CType(obj,Byte())
End Get
End Property
'''<summary> '''<summary>
''' 查找 System.Byte[] 类型的本地化资源。 ''' 查找 System.Byte[] 类型的本地化资源。
'''</summary> '''</summary>
@@ -118,27 +118,30 @@
<value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>System.Resources.ResXResourceWriter, System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</resheader> </resheader>
<assembly alias="System.Windows.Forms" name="System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089" /> <assembly alias="System.Windows.Forms" name="System.Windows.Forms, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089" />
<data name="CacheCow.Client" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\CacheCow.Client.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="CacheCow.Client.FileStore" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\CacheCow.Client.FileStore.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="CacheCow.Common" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\CacheCow.Common.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="Custom" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="Custom" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\resources\custom.xaml;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\resources\custom.xaml;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
<data name="Dialogs" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\resources\ookii.dialogs.wpf.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="ForgeInstaller" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="ForgeInstaller" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\forge-installer.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\forge-installer.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
<data name="Help" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="Help" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\Help.zip;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\Help.zip;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
<data name="Imazen_WebP" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="Imazen.WebP" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\Imazen.WebP.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\Imazen.WebP.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
<data name="JavaWrapper" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="JavaWrapper" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\java-wrapper.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\java-wrapper.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
<data name="Json" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\Newtonsoft.Json.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="libwebp64" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="libwebp64" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\libwebp64.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\libwebp64.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
@@ -148,6 +151,15 @@
<data name="NAudio" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="NAudio" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\NAudio.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\NAudio.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
<data name="Newtonsoft.Json" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\Newtonsoft.Json.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="Ookii.Dialogs.Wpf" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\resources\ookii.dialogs.wpf.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="System.Net.Http.Formatting" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\System.Net.Http.Formatting.dll;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data>
<data name="Transformer" type="System.Resources.ResXFileRef, System.Windows.Forms"> <data name="Transformer" type="System.Resources.ResXFileRef, System.Windows.Forms">
<value>..\Resources\transformer.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value> <value>..\Resources\transformer.jar;System.Byte[], mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089</value>
</data> </data>
@@ -19,7 +19,7 @@
Return LabTitle.Text Return LabTitle.Text
End Get End Get
Set(value As String) Set(value As String)
If LabTitle.Text = value Then Exit Property If LabTitle.Text = value Then Return
LabTitle.Text = value LabTitle.Text = value
End Set End Set
End Property End Property
@@ -30,7 +30,7 @@
Return If(LabTitleRaw?.Text, "") Return If(LabTitleRaw?.Text, "")
End Get End Get
Set(value As String) Set(value As String)
If LabTitleRaw.Text = value Then Exit Property If LabTitleRaw.Text = value Then Return
LabTitleRaw.Text = value LabTitleRaw.Text = value
LabTitleRaw.Visibility = If(value = "", Visibility.Collapsed, Visibility.Visible) LabTitleRaw.Visibility = If(value = "", Visibility.Collapsed, Visibility.Visible)
End Set End Set
@@ -42,7 +42,7 @@
Return LabInfo.Text Return LabInfo.Text
End Get End Get
Set(value As String) Set(value As String)
If LabInfo.Text = value Then Exit Property If LabInfo.Text = value Then Return
LabInfo.Text = value LabInfo.Text = value
End Set End Set
End Property End Property
@@ -88,7 +88,7 @@
Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp
If IsMouseDown Then If IsMouseDown Then
RaiseEvent Click(sender, e) RaiseEvent Click(sender, e)
If e.Handled Then Exit Sub If e.Handled Then Return
Log("[Control] 按下资源工程列表项:" & LabTitle.Text) Log("[Control] 按下资源工程列表项:" & LabTitle.Text)
End If End If
End Sub End Sub
@@ -97,7 +97,7 @@
Dim Titles As New List(Of String) Dim Titles As New List(Of String)
If FrmMain.PageCurrent.Page = FormMain.PageType.CompDetail Then If FrmMain.PageCurrent.Page = FormMain.PageType.CompDetail Then
For Each Card As MyCard In FrmDownloadCompDetail.PanResults.Children For Each Card As MyCard In FrmDownloadCompDetail.PanResults.Children
If Card.Title <> "" AndAlso Not Card.IsSwaped Then Titles.Add(Card.Title) If Card.Title <> "" AndAlso Not Card.IsSwapped Then Titles.Add(Card.Title)
Next Next
Log("[Comp] 记录当前已展开的卡片:" & String.Join("、", Titles)) Log("[Comp] 记录当前已展开的卡片:" & String.Join("、", Titles))
FrmMain.PageCurrent.Additional(1) = Titles FrmMain.PageCurrent.Additional(1) = Titles
@@ -185,7 +185,7 @@
''' </summary> ''' </summary>
Public Property CanInteraction As Boolean = True Public Property CanInteraction As Boolean = True
Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp
If Not CanInteraction Then Exit Sub If Not CanInteraction Then Return
'判断当前颜色 '判断当前颜色
Dim StateNew As String, Time As Integer Dim StateNew As String, Time As Integer
If IsMouseOver Then If IsMouseOver Then
@@ -200,7 +200,7 @@
StateNew = "Idle" StateNew = "Idle"
Time = 180 Time = 180
End If End If
If StateLast = StateNew Then Exit Sub If StateLast = StateNew Then Return
StateLast = StateNew StateLast = StateNew
'触发颜色动画 '触发颜色动画
If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画
@@ -34,7 +34,7 @@
<TextBlock VerticalAlignment="Center" Grid.Row="2" HorizontalAlignment="Left" Text="版本" Margin="0,0,18,0" /> <TextBlock VerticalAlignment="Center" Grid.Row="2" HorizontalAlignment="Left" Text="版本" Margin="0,0,18,0" />
<local:MyComboBox x:Name="TextSearchVersion" Grid.Row="2" Grid.Column="1" Grid.ColumnSpan="2" IsEditable="True" MaxDropDownHeight="320"> <local:MyComboBox x:Name="TextSearchVersion" Grid.Row="2" Grid.Column="1" Grid.ColumnSpan="2" IsEditable="True" MaxDropDownHeight="320">
<local:MyComboBoxItem Content="全部 (也可自行输入)" IsSelected="True" /> <local:MyComboBoxItem Content="全部 (也可自行输入)" IsSelected="True" />
<local:MyComboBoxItem Content="1.21.5" /> <local:MyComboBoxItem Content="1.21.8" />
<local:MyComboBoxItem Content="1.21.1" /> <local:MyComboBoxItem Content="1.21.1" />
<local:MyComboBoxItem Content="1.20.6" /> <local:MyComboBoxItem Content="1.20.6" />
<local:MyComboBoxItem Content="1.20.1" /> <local:MyComboBoxItem Content="1.20.1" />
@@ -71,7 +71,7 @@
</StackPanel> </StackPanel>
</local:MyCard> </local:MyCard>
<StackPanel x:Name="PanContent"> <StackPanel x:Name="PanContent">
<local:MyHint x:Name="HintError" Text="无法连接到 Modrinth,所以目前仅显示了来自 CurseForge 的内容,结果可能不全。&#xa;请尝试使用 VPN 或加速器以改善网络。" IsWarn="True" Margin="0,0,0,15" /> <local:MyHint x:Name="HintError" HasBorder="True" Text="无法连接到 Modrinth,所以目前仅显示了来自 CurseForge 的内容,搜索结果可能不全。&#xa;请稍后重试,或使用 VPN 以改善网络环境。" Theme="Yellow" Margin="0,0,0,15" />
<local:MyCard x:Name="CardProjects" UseAnimation="False"> <local:MyCard x:Name="CardProjects" UseAnimation="False">
<StackPanel x:Name="PanProjects" Margin="12" /> <StackPanel x:Name="PanProjects" Margin="12" />
</local:MyCard> </local:MyCard>
@@ -68,6 +68,10 @@ Public Class PageComp
''' 在切换到页面时,应自动将筛选项设置为与该目标 MC 版本和加载器相同。 ''' 在切换到页面时,应自动将筛选项设置为与该目标 MC 版本和加载器相同。
''' </summary> ''' </summary>
Public Shared TargetVersion As McVersion = Nothing Public Shared TargetVersion As McVersion = Nothing
''' <summary>
''' 在切换到该页面时自动设置的搜索框内的内容。
''' </summary>
Public Shared TargetName As String = Nothing
'在点击 MyCompItem 时会获取 Loader 的输入,以使资源详情页面可以应用相同的筛选项 '在点击 MyCompItem 时会获取 Loader 的输入,以使资源详情页面可以应用相同的筛选项
Public Loader As New LoaderTask(Of CompProjectRequest, Integer)("社区资源获取:XXX", AddressOf CompProjectsGet, AddressOf LoaderInput) With {.ReloadTimeout = 60 * 1000} Public Loader As New LoaderTask(Of CompProjectRequest, Integer)("社区资源获取:XXX", AddressOf CompProjectsGet, AddressOf LoaderInput) With {.ReloadTimeout = 60 * 1000}
@@ -94,6 +98,10 @@ Public Class PageComp
ComboSearchLoader.SelectedItem = GetTargetItemByName("NeoForge") ComboSearchLoader.SelectedItem = GetTargetItemByName("NeoForge")
End If End If
TargetVersion = Nothing TargetVersion = Nothing
If TargetName IsNot Nothing Then
TextSearchName.Text = TargetName
TargetName = Nothing
End If
'如果已经完成请求,则重新开始 '如果已经完成请求,则重新开始
If IsLoaderInited Then StartNewSearch() If IsLoaderInited Then StartNewSearch()
ScrollToHome() ScrollToHome()
@@ -108,19 +116,11 @@ Public Class PageComp
Dim Request As New CompProjectRequest(PageType, Storage, (Page + 1) * PageSize) Dim Request As New CompProjectRequest(PageType, Storage, (Page + 1) * PageSize)
Dim GameVersion As String = If(TextSearchVersion.Text = "全部 (也可自行输入)", Nothing, Dim GameVersion As String = If(TextSearchVersion.Text = "全部 (也可自行输入)", Nothing,
If(TextSearchVersion.Text.Contains(".") OrElse TextSearchVersion.Text.Contains("w"), TextSearchVersion.Text, Nothing)) If(TextSearchVersion.Text.Contains(".") OrElse TextSearchVersion.Text.Contains("w"), TextSearchVersion.Text, Nothing))
Dim ModLoader As CompModLoaderType = CompModLoaderType.Any
If PageType = CompType.Mod Then '只有 Mod 考虑加载器
ModLoader = Val(ComboSearchLoader.SelectedItem.Tag)
If GameVersion IsNot Nothing AndAlso GameVersion.Contains(".") AndAlso Val(GameVersion.Split(".")(1)) < 14 AndAlso '1.14-
ModLoader = CompModLoaderType.Forge Then '选择了 Forge
ModLoader = CompModLoaderType.Any '此时,视作没有筛选 Mod Loader(因为部分老 Mod 没有设置自己支持的加载器)
End If
End If
With Request With Request
.SearchText = TextSearchName.Text .SearchText = TextSearchName.Text
.GameVersion = GameVersion .GameVersion = GameVersion
.Tag = ComboSearchTag.SelectedItem.Tag .Tag = ComboSearchTag.SelectedItem.Tag
.ModLoader = ModLoader .ModLoader = If(PageType = CompType.Mod, Val(ComboSearchLoader.SelectedItem.Tag), CompModLoaderType.Any)
.Source = CType(Val(ComboSearchSource.SelectedItem.Tag), CompSourceType) .Source = CType(Val(ComboSearchSource.SelectedItem.Tag), CompSourceType)
End With End With
Return Request Return Request
@@ -188,7 +188,6 @@ Public Class PageComp
End Sub End Sub
'切换页码 '切换页码
Private Sub BtnPageFirst_Click(sender As Object, e As RoutedEventArgs) Handles BtnPageFirst.Click Private Sub BtnPageFirst_Click(sender As Object, e As RoutedEventArgs) Handles BtnPageFirst.Click
ChangePage(0) ChangePage(0)
End Sub End Sub
@@ -7,7 +7,9 @@
"Comp File", "Comp File",
Sub(Task) Sub(Task)
LoadTargetFromAdditional() LoadTargetFromAdditional()
Task.Output = CompFilesGet(Project.Id, Project.FromCurseForge) Dim Result = CompFilesGet(Project.Id, Project.FromCurseForge)
If Task.IsAborted Then Return
Task.Output = Result
End Sub) End Sub)
'初始化加载器信息 '初始化加载器信息
@@ -71,11 +73,14 @@
'筛选类型相同的结果(Modrinth 会返回 Mod、服务端插件、数据包混合的列表) '筛选类型相同的结果(Modrinth 会返回 Mod、服务端插件、数据包混合的列表)
Private Function GetResults() As List(Of CompFile) Private Function GetResults() As List(Of CompFile)
Dim Results As List(Of CompFile) = CompFileLoader.Output Dim Results As List(Of CompFile) = CompFileLoader.Output
If PageType = CompType.Any Then Select Case PageType
Results = Results.Where(Function(r) r.Type <> CompType.Plugin).ToList Case CompType.Any
Else Results = Results.Where(Function(r) r.Type <> CompType.Plugin).ToList
Results = Results.Where(Function(r) r.Type = PageType).ToList Case CompType.Shader, CompType.ResourcePack
End If '不筛选光影和资源包,否则原版光影会因为是资源包格式而被过滤(#6473)
Case Else
Results = Results.Where(Function(r) r.Type = PageType).ToList
End Select
Return Results Return Results
End Function End Function
Private Sub Load_OnFinish() Private Sub Load_OnFinish()
@@ -200,16 +205,16 @@
CType(FrmMain.PageCurrent.Additional(1), List(Of String)).Contains(NewCard.Title)) Then CType(FrmMain.PageCurrent.Additional(1), List(Of String)).Contains(NewCard.Title)) Then
MyCard.StackInstall(NewStack, If(PageType = CompType.ModPack, 9, 8), Pair.Key) '9 是安装,8 是另存为 MyCard.StackInstall(NewStack, If(PageType = CompType.ModPack, 9, 8), Pair.Key) '9 是安装,8 是另存为
Else Else
NewCard.IsSwaped = True NewCard.IsSwapped = True
End If End If
'增加提示 '增加提示
If Pair.Key = "其他版本" Then If Pair.Key = "其他版本" Then
NewStack.Children.Add(New MyHint With {.Text = "由于版本信息更新缓慢,可能无法识别刚更新的 MC 版本,只需等待几天即可自动恢复正常。", .IsWarn = False, .Margin = New Thickness(0, 0, 0, 7)}) NewStack.Children.Add(New MyHint With {.Text = "由于版本信息更新缓慢,可能无法识别刚更新的 MC 版本。几天后即可正常识别。", .Theme = MyHint.Themes.Yellow, .Margin = New Thickness(5, 0, 0, 8)})
End If End If
Next Next
'如果只有一张卡片,展开第一张卡片 '如果只有一张卡片,展开第一张卡片
If PanResults.Children.Count = 1 Then If PanResults.Children.Count = 1 Then
CType(PanResults.Children(0), MyCard).IsSwaped = False CType(PanResults.Children(0), MyCard).IsSwapped = False
End If End If
Catch ex As Exception Catch ex As Exception
Log(ex, "可视化工程下载列表出错", LogLevel.Feedback) Log(ex, "可视化工程下载列表出错", LogLevel.Feedback)
@@ -270,7 +275,7 @@
Dim Validate As New ValidateFolderName(PathMcFolder & "versions") Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
If Validate.Validate(PackName) <> "" Then PackName = "" If Validate.Validate(PackName) <> "" Then PackName = ""
Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate}) Dim VersionName As String = MyMsgBoxInput("输入版本名称", "", PackName, New ObjectModel.Collection(Of Validate) From {Validate})
If String.IsNullOrEmpty(VersionName) Then Exit Sub If String.IsNullOrEmpty(VersionName) Then Return
'构造步骤加载器 '构造步骤加载器
Dim Loaders As New List(Of LoaderBase) Dim Loaders As New List(Of LoaderBase)
@@ -289,7 +294,7 @@
Case LoadState.Aborted Case LoadState.Aborted
Hint(MyLoader.Name & "已取消!", HintType.Info) Hint(MyLoader.Name & "已取消!", HintType.Info)
Case LoadState.Loading Case LoadState.Loading
Exit Sub '不重新加载版本列表 Return '不重新加载版本列表
End Select End Select
McInstallFailedClearFolder(MyLoader) McInstallFailedClearFolder(MyLoader)
End Sub} End Sub}
@@ -303,7 +308,7 @@
End Try End Try
End Sub End Sub
'资源下载;整合包另存为 '资源下载;整合包另存为
Public Shared CachedFolder As String = Nothing '仅在本次缓存的下载文件夹 Public Shared CachedFolder As New Dictionary(Of CompType, String) '仅在本次缓存的下载文件夹
Public Sub Save_Click(sender As Object, e As EventArgs) Public Sub Save_Click(sender As Object, e As EventArgs)
Dim File As CompFile = If(TypeOf sender Is MyListItem, sender, sender.Parent).Tag Dim File As CompFile = If(TypeOf sender Is MyListItem, sender, sender.Parent).Tag
RunInNewThread( RunInNewThread(
@@ -319,67 +324,72 @@
End Select End Select
'确认默认保存位置 '确认默认保存位置
Dim DefaultFolder As String = Nothing Dim DefaultFolder As String = Nothing
If File.Type = CompType.Mod Then If File.Type <> CompType.ModPack Then
'获取 Mod 所需的加载器种类 Dim SubFolder As String = Nothing
Dim AllowForge As Boolean? = Nothing, AllowFabric As Boolean? = Nothing Select Case Project.Type
If File.ModLoaders.Any Then '从文件中获取 Case CompType.Mod : SubFolder = "mods\"
AllowForge = File.ModLoaders.Contains(CompModLoaderType.Forge) OrElse File.ModLoaders.Contains(CompModLoaderType.NeoForge) Case CompType.ResourcePack : SubFolder = "resourcepacks\"
AllowFabric = File.ModLoaders.Contains(CompModLoaderType.Fabric) Case CompType.Shader : SubFolder = "shaderpacks\"
ElseIf Project.ModLoaders.Any Then '从工程中获取 Case CompType.DataPack : SubFolder = "" '导航到版本根目录
AllowForge = Project.ModLoaders.Contains(CompModLoaderType.Forge) OrElse File.ModLoaders.Contains(CompModLoaderType.NeoForge) End Select
AllowFabric = Project.ModLoaders.Contains(CompModLoaderType.Fabric) Dim IsVersionSuitable As Func(Of McVersion, Boolean) = Nothing
'获取资源所需的加载器
Dim AllowedLoaders As New List(Of CompModLoaderType)
If File.ModLoaders.Any Then
AllowedLoaders = File.ModLoaders
ElseIf Project.ModLoaders.Any Then
AllowedLoaders = Project.ModLoaders
End If End If
If AllowForge IsNot Nothing AndAlso Not AllowForge AndAlso Log($"[Comp] {Desc}要求的加载器种类:" & If(AllowedLoaders.Any(), AllowedLoaders.Join(" / "), "无要求"))
AllowFabric IsNot Nothing AndAlso Not AllowFabric Then '判断某个版本是否符合资源要求
AllowForge = Nothing : AllowFabric = Nothing IsVersionSuitable =
End If
Log("[Comp] 允许 Forge:" & If(AllowForge, "未知") & ",允许 Fabric:" & If(AllowFabric, "未知"))
'判断某个版本是否符合要求
Dim IsVersionSuitable As Func(Of McVersion, Boolean) =
Function(Version) Function(Version)
If Not Version.IsLoaded Then Version.Load() If Not Version.IsLoaded Then Version.Load()
If Not Version.Modable Then Return False '只对 Mod 和数据包进行版本检测
If File.GameVersions.Any(Function(v) v.Contains(".")) AndAlso If Project.Type = CompType.Mod OrElse Project.Type = CompType.DataPack Then
Not File.GameVersions.Any(Function(v) v.Contains(".") AndAlso v = Version.Version.McName) Then Return False If File.GameVersions.Any(Function(v) v.Contains(".")) AndAlso
If AllowForge Is Nothing OrElse AllowFabric Is Nothing Then Return True Not File.GameVersions.Any(Function(v) v.Contains(".") AndAlso v = Version.Version.McName) Then Return False
If AllowForge AndAlso (Version.Version.HasForge OrElse Version.Version.HasNeoForge) Then Return True End If
If AllowFabric AndAlso Version.Version.HasFabric Then Return True '加载器
If Not AllowedLoaders.Any() Then Return True '无要求
If AllowedLoaders.Contains(CompModLoaderType.Forge) AndAlso Version.Version.HasForge Then Return True
If AllowedLoaders.Contains(CompModLoaderType.Fabric) AndAlso Version.Version.HasFabric Then Return True
If AllowedLoaders.Contains(CompModLoaderType.NeoForge) AndAlso Version.Version.HasNeoForge Then Return True
If AllowedLoaders.Contains(CompModLoaderType.LiteLoader) AndAlso Version.Version.HasLiteLoader Then Return True
Return False Return False
End Function End Function
'获取 Mod 默认下载位置 '获取常规资源默认下载位置
If CachedFolder IsNot Nothing Then If CachedFolder.ContainsKey(Project.Type) Then
DefaultFolder = CachedFolder DefaultFolder = CachedFolder(Project.Type)
Log("[Comp] 使用上次下载时的文件夹作为默认下载位置") Log($"[Comp] 使用上次下载时的文件夹作为默认下载位置:{DefaultFolder}")
ElseIf McVersionCurrent IsNot Nothing AndAlso IsVersionSuitable(McVersionCurrent) Then ElseIf McVersionCurrent IsNot Nothing AndAlso IsVersionSuitable(McVersionCurrent) Then
DefaultFolder = McVersionCurrent.PathIndie & "mods\" DefaultFolder = $"{McVersionCurrent.PathIndie}{SubFolder}"
Directory.CreateDirectory(DefaultFolder) Directory.CreateDirectory(DefaultFolder)
Log("[Comp] 使用当前版本的 mods 文件夹作为默认下载位置(" & McVersionCurrent.Name & ")") Log($"[Comp] 使用当前版本作为默认下载位置:{DefaultFolder}")
Else Else
'查找所有可能的版本
Dim NeedLoad As Boolean = McVersionListLoader.State <> LoadState.Finished Dim NeedLoad As Boolean = McVersionListLoader.State <> LoadState.Finished
If NeedLoad Then If NeedLoad Then
Hint("正在查找适合的游戏版本……") Hint("正在查找适合的游戏版本……")
LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True) LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\", WaitForExit:=True)
End If End If
Dim SuitableVersions As New List(Of McVersion) Dim SuitableVersions = McVersionList.Values.SelectMany(Function(l) l).Where(Function(v) IsVersionSuitable(v)).
For Each Version As McVersion In McVersionList.Values.SelectMany(Function(l) l) Select(Function(v) New DirectoryInfo($"{v.PathIndie}{SubFolder}"))
If IsVersionSuitable(Version) Then SuitableVersions.Add(Version) If SuitableVersions.Any Then
Next Dim SelectedVersion = SuitableVersions.
If Not SuitableVersions.Any() Then OrderByDescending(Function(Dir) If(Dir.Exists, Dir.LastWriteTimeUtc, Date.MinValue)). '先按文件夹更改时间降序
ThenByDescending(Function(Dir) If(Dir.Exists, Dir.GetFiles().Length, -1)). '再按文件夹中的文件数量降序
First()
DefaultFolder = SelectedVersion.FullName
Directory.CreateDirectory(DefaultFolder)
Log($"[Comp] 使用适合的游戏版本作为默认下载位置:{DefaultFolder}")
Else
DefaultFolder = PathMcFolder DefaultFolder = PathMcFolder
If NeedLoad Then If NeedLoad Then
Hint("当前 MC 文件夹中没有找到适合这个 Mod 的版本!") Hint("当前 MC 文件夹中没有找到适合此资源的版本!")
Else Else
Log("[Comp] 由于当前版本不兼容,使用当前的 MC 文件夹作为默认下载位置") Log("[Comp] 由于当前版本不兼容,使用当前的 MC 文件夹作为默认下载位置")
End If End If
Else '选择 Mod 数量最多的版本
Dim SelectedVersion = SuitableVersions.OrderBy(
Function(v)
Dim Info As New DirectoryInfo(v.PathIndie & "mods\")
Return If(Info.Exists, Info.GetFiles().Length, -1)
End Function).LastOrDefault()
DefaultFolder = SelectedVersion.PathIndie & "mods\"
Directory.CreateDirectory(DefaultFolder)
Log("[Comp] 使用适合的游戏版本作为默认下载位置(" & SelectedVersion.Name & ")")
End If End If
End If End If
End If End If
@@ -412,10 +422,10 @@
If(File.Type = CompType.Mod, If(File.Type = CompType.Mod,
If(File.FileName.EndsWith(".litemod"), "*.litemod", "*.jar"), If(File.FileName.EndsWith(".litemod"), "*.litemod", "*.jar"),
If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder) If(File.FileName.EndsWith(".mrpack"), "*.mrpack", "*.zip")), DefaultFolder)
If Not Target.Contains("\") Then Exit Sub If Not Target.Contains("\") Then Return
'构造步骤加载器 '构造步骤加载器
Dim LoaderName As String = Desc & "下载:" & GetFileNameWithoutExtentionFromPath(Target) & " " Dim LoaderName As String = Desc & "下载:" & GetFileNameWithoutExtentionFromPath(Target) & " "
If Target <> DefaultFolder AndAlso File.Type = CompType.Mod Then CachedFolder = GetPathFromFullPath(Target) If Target <> DefaultFolder Then CachedFolder(Project.Type) = GetPathFromFullPath(Target)
Dim Loaders As New List(Of LoaderBase) Dim Loaders As New List(Of LoaderBase)
Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True}) Loaders.Add(New LoaderDownload("下载文件", New List(Of NetFile) From {File.ToNetFile(Target)}) With {.ProgressWeight = 6, .Block = True})
'启动 '启动
@@ -19,7 +19,7 @@
<local:MyComboBoxItem Margin="15,0,0,0" Content="战斗" Tag="/combat" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="战斗" Tag="/combat" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="实用" Tag="/utility" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="实用" Tag="/utility" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="改良" Tag="/tweaks" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="改良" Tag="/tweaks" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="神经病" Tag="/cursed" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="鬼畜" Tag="/cursed" />
<local:MyComboBoxItem Content="特性" IsEnabled="False" /> <local:MyComboBoxItem Content="特性" IsEnabled="False" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="含实体" Tag="/entities" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="含实体" Tag="/entities" />
@@ -15,7 +15,6 @@
<local:MyComboBoxItem Margin="15,0,0,0" Content="卡通风" Tag="/cartoon" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="卡通风" Tag="/cartoon" />
<local:MyComboBoxItem Content="特性" IsEnabled="False" /> <local:MyComboBoxItem Content="特性" IsEnabled="False" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="原版可用" Tag="/vanilla" ToolTip="作为资源包加载,可以直接在原版游戏里使用。" ToolTipService.HorizontalOffset="70" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="彩色光照" Tag="/colored-lighting" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="彩色光照" Tag="/colored-lighting" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="路径追踪" Tag="/path-tracing" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="路径追踪" Tag="/path-tracing" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="PBR" Tag="/pbr" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="PBR" Tag="/pbr" />
@@ -26,6 +25,10 @@
<local:MyComboBoxItem Margin="15,0,0,0" Content="低" Tag="/low" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="低" Tag="/low" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="中" Tag="/medium" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="中" Tag="/medium" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="高" Tag="/high" /> <local:MyComboBoxItem Margin="15,0,0,0" Content="高" Tag="/high" />
<local:MyComboBoxItem Content="加载器" IsEnabled="False" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="原版可用" Tag="/vanilla" ToolTip="作为资源包加载,可以直接在原版游戏里使用。" ToolTipService.HorizontalOffset="70" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="Iris" Tag="/iris" />
<local:MyComboBoxItem Margin="15,0,0,0" Content="OptiFine" Tag="/optifine" />
</local:PageComp> </local:PageComp>
</local:MyPageRight> </local:MyPageRight>
@@ -217,14 +217,14 @@ Public Module ModDownloadLib
Dim Id = Version.Title Dim Id = Version.Title
Dim JsonUrl = Version.Tag("url").ToString Dim JsonUrl = Version.Tag("url").ToString
Dim VersionFolder As String = SelectFolder() Dim VersionFolder As String = SelectFolder()
If Not VersionFolder.Contains("\") Then Exit Sub If Not VersionFolder.Contains("\") Then Return
VersionFolder = VersionFolder & Id & "\" VersionFolder = VersionFolder & Id & "\"
'重复任务检查 '重复任务检查
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"Minecraft {Id} 服务端下载" Then Continue For If OngoingLoader.Name <> $"Minecraft {Id} 服务端下载" Then Continue For
Hint("该服务端正在下载中!", HintType.Critical) Hint("该服务端正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
Dim Loaders As New List(Of LoaderBase) Dim Loaders As New List(Of LoaderBase)
@@ -244,7 +244,7 @@ Public Module ModDownloadLib
Hint($"Mojang 没有给 Minecraft {Id} 提供官方服务端下载,没法下,撤退!", HintType.Critical) Hint($"Mojang 没有给 Minecraft {Id} 提供官方服务端下载,没法下,撤退!", HintType.Critical)
Thread.Sleep(2000) '等玩家把上一个提示看完 Thread.Sleep(2000) '等玩家把上一个提示看完
Task.Abort() Task.Abort()
Exit Sub Return
End If End If
Dim JarUrl As String = McVersion.JsonObject("downloads")("server")("url") Dim JarUrl As String = McVersion.JsonObject("downloads")("server")("url")
Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(McVersion.JsonObject("downloads")("server")("size"), -1), Hash:=McVersion.JsonObject("downloads")("server")("sha1")) Dim Checker As New FileChecker(MinSize:=1024, ActualSize:=If(McVersion.JsonObject("downloads")("server")("size"), -1), Hash:=McVersion.JsonObject("downloads")("server")("sha1"))
@@ -294,14 +294,14 @@ pause"
Dim Id = Version.Title Dim Id = Version.Title
Dim JsonUrl = Version.Tag("url").ToString Dim JsonUrl = Version.Tag("url").ToString
Dim VersionFolder As String = SelectFolder() Dim VersionFolder As String = SelectFolder()
If Not VersionFolder.Contains("\") Then Exit Sub If Not VersionFolder.Contains("\") Then Return
VersionFolder = VersionFolder & Id & "\" VersionFolder = VersionFolder & Id & "\"
'重复任务检查 '重复任务检查
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"Minecraft {Id} 下载" Then Continue For If OngoingLoader.Name <> $"Minecraft {Id} 下载" Then Continue For
Hint("该版本正在下载中!", HintType.Critical) Hint("该版本正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
Dim Loaders As New List(Of LoaderBase) Dim Loaders As New List(Of LoaderBase)
@@ -383,7 +383,7 @@ pause"
WikiName = "Java版Pre-classic_" & Id WikiName = "Java版Pre-classic_" & Id
Else Else
Log("[Error] 未知的版本格式:" & Id & "。", LogLevel.Feedback) Log("[Error] 未知的版本格式:" & Id & "。", LogLevel.Feedback)
Exit Sub Return
End If End If
OpenWebsite("https://zh.minecraft.wiki/w/" & WikiName.Replace("_experimental-snapshot-", "-exp")) OpenWebsite("https://zh.minecraft.wiki/w/" & WikiName.Replace("_experimental-snapshot-", "-exp"))
End Sub End Sub
@@ -396,13 +396,13 @@ pause"
Try Try
Dim Id As String = DownloadInfo.NameVersion Dim Id As String = DownloadInfo.NameVersion
Dim Target As String = SelectSaveFile("选择保存位置", DownloadInfo.NameFile, "OptiFine Jar (*.jar)|*.jar") Dim Target As String = SelectSaveFile("选择保存位置", DownloadInfo.NameFile, "OptiFine Jar (*.jar)|*.jar")
If Not Target.Contains("\") Then Exit Sub If Not Target.Contains("\") Then Return
'重复任务检查 '重复任务检查
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"OptiFine {DownloadInfo.NameDisplay} 下载" Then Continue For If OngoingLoader.Name <> $"OptiFine {DownloadInfo.NameDisplay} 下载" Then Continue For
Hint("该版本正在下载中!", HintType.Critical) Hint("该版本正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
Dim Loader As New LoaderCombo(Of DlOptiFineListEntry)("OptiFine " & DownloadInfo.NameDisplay & " 下载", McDownloadOptiFineSaveLoader(DownloadInfo, Target)) With {.OnStateChanged = AddressOf LoaderStateChangedHintOnly} Dim Loader As New LoaderCombo(Of DlOptiFineListEntry)("OptiFine " & DownloadInfo.NameDisplay & " 下载", McDownloadOptiFineSaveLoader(DownloadInfo, Target)) With {.OnStateChanged = AddressOf LoaderStateChangedHintOnly}
@@ -434,7 +434,7 @@ pause"
End Try End Try
'检查下载结果 '检查下载结果
Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 0)) Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 0))
If Task.IsAborted Then Exit Sub If Task.IsAborted Then Return
If Java Is Nothing Then Throw New Exception("由于未找到 Java,已取消安装。") If Java Is Nothing Then Throw New Exception("由于未找到 Java,已取消安装。")
End If End If
End SyncLock End SyncLock
@@ -570,7 +570,8 @@ pause"
'官方源 '官方源
Dim PageData As String Dim PageData As String
Try Try
PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html", True) PageData = NetRequestByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile,
Encoding:=New UTF8Encoding(False), Timeout:=15000, Accept:="text/html", UseBrowserUserAgent:=True)
Task.Progress = 0.8 Task.Progress = 0.8
Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0)) Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0))
Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址:" & Sources.Last) Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址:" & Sources.Last)
@@ -584,7 +585,7 @@ pause"
Loaders.Add(New LoaderTask(Of List(Of NetFile), Boolean)("等待原版下载", Loaders.Add(New LoaderTask(Of List(Of NetFile), Boolean)("等待原版下载",
Sub(Task As LoaderTask(Of List(Of NetFile), Boolean)) Sub(Task As LoaderTask(Of List(Of NetFile), Boolean))
'等待原版文件下载完成 '等待原版文件下载完成
If ClientDownloadLoader Is Nothing Then Exit Sub If ClientDownloadLoader Is Nothing Then Return
Dim TargetLoaders As List(Of LoaderBase) = Dim TargetLoaders As List(Of LoaderBase) =
ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName). ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName).
Where(Function(l) l.State <> LoadState.Finished).ToList Where(Function(l) l.State <> LoadState.Finished).ToList
@@ -593,9 +594,9 @@ pause"
TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList
Thread.Sleep(50) Thread.Sleep(50)
Loop Loop
If Task.IsAborted Then Exit Sub If Task.IsAborted Then Return
'拷贝原版文件 '拷贝原版文件
If Not IsCustomFolder Then Exit Sub If Not IsCustomFolder Then Return
SyncLock VanillaSyncLock SyncLock VanillaSyncLock
Dim ClientName As String = GetFolderNameFromPath(ClientFolder) Dim ClientName As String = GetFolderNameFromPath(ClientFolder)
Directory.CreateDirectory(McFolder & "versions\" & DownloadInfo.Inherit) Directory.CreateDirectory(McFolder & "versions\" & DownloadInfo.Inherit)
@@ -707,7 +708,7 @@ Retry:
'下载支持库 '下载支持库
If FixLibrary Then If FixLibrary Then
Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 OptiFine 支持库文件", Loaders.Add(New LoaderTask(Of String, List(Of NetFile))("分析 OptiFine 支持库文件",
Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionFolder))) With {.ProgressWeight = 1, .Show = False}) Sub(Task) Task.Output = McLibFix(New McVersion(VersionFolder))) With {.ProgressWeight = 1, .Show = False})
Loaders.Add(New LoaderDownload("下载 OptiFine 支持库文件", New List(Of NetFile)) With {.ProgressWeight = 4}) Loaders.Add(New LoaderDownload("下载 OptiFine 支持库文件", New List(Of NetFile)) With {.ProgressWeight = 4})
End If End If
@@ -733,7 +734,8 @@ Retry:
'官方源 '官方源
Dim PageData As String Dim PageData As String
Try Try
PageData = NetGetCodeByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile, New UTF8Encoding(False), 15000, "text/html", True) PageData = NetRequestByClient("https://optifine.net/adloadx?f=" & DownloadInfo.NameFile,
Encoding:=New UTF8Encoding(False), Timeout:=15000, Accept:="text/html", UseBrowserUserAgent:=True)
Task.Progress = 0.8 Task.Progress = 0.8
Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0)) Sources.Add("https://optifine.net/" & RegexSearch(PageData, "downloadx\?f=[^""']+")(0))
Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址:" & Sources.Last) Log("[Download] OptiFine " & DownloadInfo.NameDisplay & " 官方下载地址:" & Sources.Last)
@@ -831,7 +833,7 @@ Retry:
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For
Hint("该版本正在下载中!", HintType.Critical) Hint("该版本正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
'已有版本检查 '已有版本检查
@@ -840,7 +842,7 @@ Retry:
File.Delete(VersionFolder & VersionName & ".jar") File.Delete(VersionFolder & VersionName & ".jar")
File.Delete(VersionFolder & VersionName & ".json") File.Delete(VersionFolder & VersionName & ".json")
Else Else
Exit Sub Return
End If End If
End If End If
@@ -859,13 +861,13 @@ Retry:
Try Try
Dim Id As String = DownloadInfo.Inherit Dim Id As String = DownloadInfo.Inherit
Dim Target As String = SelectSaveFile("选择保存位置", DownloadInfo.FileName.Replace("-SNAPSHOT", ""), "LiteLoader 安装器 (*.jar)|*.jar") Dim Target As String = SelectSaveFile("选择保存位置", DownloadInfo.FileName.Replace("-SNAPSHOT", ""), "LiteLoader 安装器 (*.jar)|*.jar")
If Not Target.Contains("\") Then Exit Sub If Not Target.Contains("\") Then Return
'重复任务检查 '重复任务检查
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For If OngoingLoader.Name <> $"LiteLoader {Id} 下载" Then Continue For
Hint("该版本正在下载中!", HintType.Critical) Hint("该版本正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
'构造步骤加载器 '构造步骤加载器
@@ -1041,13 +1043,13 @@ Retry:
Dim Target As String = SelectSaveFile("选择保存位置", $"{Info.LoaderName}-{Info.Inherit}-{Info.VersionName}.{Info.FileExtension}", Dim Target As String = SelectSaveFile("选择保存位置", $"{Info.LoaderName}-{Info.Inherit}-{Info.VersionName}.{Info.FileExtension}",
$"{Info.LoaderName} 安装器 (*.{Info.FileExtension})|*.{Info.FileExtension}") $"{Info.LoaderName} 安装器 (*.{Info.FileExtension})|*.{Info.FileExtension}")
Dim DisplayName As String = $"{Info.LoaderName} {Info.Inherit} - {Info.VersionName}" Dim DisplayName As String = $"{Info.LoaderName} {Info.Inherit} - {Info.VersionName}"
If Not Target.Contains("\") Then Exit Sub If Not Target.Contains("\") Then Return
'重复任务检查 '重复任务检查
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"{DisplayName} 下载" Then Continue For If OngoingLoader.Name <> $"{DisplayName} 下载" Then Continue For
Hint("该版本正在下载中!", HintType.Critical) Hint("该版本正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
'获取下载地址 '获取下载地址
@@ -1103,7 +1105,7 @@ Retry:
End Try End Try
'检查下载结果 '检查下载结果
Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 60)) Java = JavaSelect("已取消安装。", New Version(1, 8, 0, 60))
If Task.IsAborted Then Exit Sub If Task.IsAborted Then Return
If Java Is Nothing Then Throw New Exception("由于未找到 Java,已取消安装。") If Java Is Nothing Then Throw New Exception("由于未找到 Java,已取消安装。")
End If End If
End SyncLock End SyncLock
@@ -1189,7 +1191,7 @@ Retry:
errorWaitHandle.WaitOne(10000) errorWaitHandle.WaitOne(10000)
process.Dispose() process.Dispose()
'检查是否安装成功:最后 5 行中是否有 true(true 可能在倒数数行,见 #832) '检查是否安装成功:最后 5 行中是否有 true(true 可能在倒数数行,见 #832)
If LastResults.Reverse().Take(5).Any(Function(l) l = "true") Then Exit Sub If LastResults.Reverse().Take(5).Any(Function(l) l = "true") Then Return
Log(Join(LastResults, vbCrLf)) Log(Join(LastResults, vbCrLf))
Dim LastLines As String = "" Dim LastLines As String = ""
For i As Integer = Math.Max(0, LastResults.Count - 5) To LastResults.Count - 1 '最后 5 行 For i As Integer = Math.Max(0, LastResults.Count - 5) To LastResults.Count - 1 '最后 5 行
@@ -1237,7 +1239,7 @@ Retry:
Task.Progress = 0.91 Task.Progress = 0.91
Case Else Case Else
If ModeDebug Then Log("[Installer] " & Content) If ModeDebug Then Log("[Installer] " & Content)
Exit Sub Return
End Select End Select
Log("[Installer] " & Content) Log("[Installer] " & Content)
End Sub End Sub
@@ -1282,7 +1284,7 @@ Retry:
For Each ForgeVersion In ForgeLoader.Output For Each ForgeVersion In ForgeLoader.Output
If VersionSortInteger(ForgeVersion.Version.ToString, LoaderVersion) = 0 Then If VersionSortInteger(ForgeVersion.Version.ToString, LoaderVersion) = 0 Then
Info = ForgeVersion Info = ForgeVersion
Exit Sub Return
End If End If
Next Next
Throw New Exception($"未能找到 {LoaderName} " & Inherit & "-" & LoaderVersion & " 的详细信息!") Throw New Exception($"未能找到 {LoaderName} " & Inherit & "-" & LoaderVersion & " 的详细信息!")
@@ -1340,7 +1342,7 @@ Retry:
If Json("data") IsNot Nothing AndAlso Json("data")("MOJMAPS") IsNot Nothing Then If Json("data") IsNot Nothing AndAlso Json("data")("MOJMAPS") IsNot Nothing Then
'下载原版 Json 文件 '下载原版 Json 文件
Task.Progress = 0.4 Task.Progress = 0.4
Dim RawJson As JObject = GetJson(NetGetCodeByLoader(DlSourceLauncherOrMetaGet(DlClientListGet(Inherit)), IsJson:=True)) Dim RawJson As JObject = GetJson(NetRequestByLoader(DlSourceLauncherOrMetaGet(DlClientListGet(Inherit)), IsJson:=True))
'[net.minecraft:client:1.17.1-20210706.113038:mappings@txt] 或 @tsrg] '[net.minecraft:client:1.17.1-20210706.113038:mappings@txt] 或 @tsrg]
Dim OriginalName As String = Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).BeforeFirst("@") Dim OriginalName As String = Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).BeforeFirst("@")
Dim Address = McLibGet(OriginalName).Replace(".jar", "-mappings." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1)) Dim Address = McLibGet(OriginalName).Replace(".jar", "-mappings." & Json("data")("MOJMAPS")("client").ToString.Trim("[]".ToCharArray()).Split("@")(1))
@@ -1385,7 +1387,7 @@ Retry:
#End Region #End Region
#Region "原版文件" #Region "原版文件"
'等待原版文件下载完成 '等待原版文件下载完成
If ClientDownloadLoader Is Nothing Then Exit Sub If ClientDownloadLoader Is Nothing Then Return
Dim TargetLoaders As List(Of LoaderBase) = Dim TargetLoaders As List(Of LoaderBase) =
ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName). ClientDownloadLoader.GetLoaderList.Where(Function(l) l.Name = McDownloadClientLibName OrElse l.Name = McDownloadClientJsonName).
Where(Function(l) l.State <> LoadState.Finished).ToList() Where(Function(l) l.State <> LoadState.Finished).ToList()
@@ -1394,9 +1396,9 @@ Retry:
TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList TargetLoaders = TargetLoaders.Where(Function(l) l.State <> LoadState.Finished).ToList
Thread.Sleep(50) Thread.Sleep(50)
Loop Loop
If Task.IsAborted Then Exit Sub If Task.IsAborted Then Return
'拷贝原版文件 '拷贝原版文件
If Not IsCustomFolder Then Exit Sub If Not IsCustomFolder Then Return
SyncLock VanillaSyncLock SyncLock VanillaSyncLock
Dim ClientName As String = GetFolderNameFromPath(ClientFolder) Dim ClientName As String = GetFolderNameFromPath(ClientFolder)
Directory.CreateDirectory(McFolder & "versions\" & Inherit) Directory.CreateDirectory(McFolder & "versions\" & Inherit)
@@ -1639,32 +1641,33 @@ Retry:
''' 尝试刷新 Forge 推荐版本缓存。 ''' 尝试刷新 Forge 推荐版本缓存。
''' </summary> ''' </summary>
Public Sub McDownloadForgeRecommendedRefresh() Public Sub McDownloadForgeRecommendedRefresh()
If IsForgeRecommendedRefreshed Then Exit Sub If IsForgeRecommendedRefreshed Then Return
IsForgeRecommendedRefreshed = True IsForgeRecommendedRefreshed = True
RunInNewThread(Sub() RunInNewThread(
Try Sub()
Log("[Download] 刷新 Forge 推荐版本缓存开始") Try
Dim Result As String = NetGetCodeByLoader("https://bmclapi2.bangbang93.com/forge/promos") Log("[Download] 刷新 Forge 推荐版本缓存开始")
If Result.Length < 1000 Then Throw New Exception("获取的结果过短(" & Result & ")") Dim Result As String = NetRequestByClientRetry("https://bmclapi2.bangbang93.com/forge/promos")
Dim ResultJson As JContainer = GetJson(Result) If Result.Length < 1000 Then Throw New Exception("获取的结果过短(" & Result & ")")
'获取所有推荐版本列表 Dim ResultJson As JContainer = GetJson(Result)
Dim RecommendedList As New List(Of String) '获取所有推荐版本列表
For Each Version As JObject In ResultJson Dim RecommendedList As New List(Of String)
If Version("name") Is Nothing OrElse Version("build") Is Nothing Then Continue For For Each Version As JObject In ResultJson
Dim Name As String = Version("name") If Version("name") Is Nothing OrElse Version("build") Is Nothing Then Continue For
If Not Name.EndsWithF("-recommended") Then Continue For Dim Name As String = Version("name")
'内容为:"1.15.2":"31.2.0" If Not Name.EndsWithF("-recommended") Then Continue For
RecommendedList.Add("""" & Name.Replace("-recommended", """:""" & Version("build")("version").ToString & """")) '内容为:"1.15.2":"31.2.0"
Next RecommendedList.Add("""" & Name.Replace("-recommended", """:""" & Version("build")("version").ToString & """"))
If RecommendedList.Count < 5 Then Throw New Exception("获取的推荐版本数过少(" & Result & ")") Next
'保存 If RecommendedList.Count < 5 Then Throw New Exception("获取的推荐版本数过少(" & Result & ")")
Dim CacheJson As String = "{" & Join(RecommendedList, ",") & "}" '保存
WriteFile(PathTemp & "Cache\ForgeRecommendedList.json", CacheJson) Dim CacheJson As String = "{" & Join(RecommendedList, ",") & "}"
Log("[Download] 刷新 Forge 推荐版本缓存成功") WriteFile(PathTemp & "Cache\ForgeRecommendedList.json", CacheJson)
Catch ex As Exception Log("[Download] 刷新 Forge 推荐版本缓存成功")
Log(ex, "刷新 Forge 推荐版本缓存失败") Catch ex As Exception
End Try Log(ex, "刷新 Forge 推荐版本缓存失败")
End Sub, "ForgeRecommendedRefresh") End Try
End Sub, "ForgeRecommendedRefresh")
End Sub End Sub
Private IsForgeRecommendedRefreshed As Boolean = False Private IsForgeRecommendedRefreshed As Boolean = False
@@ -1795,13 +1798,13 @@ Retry:
Dim FileName As String = GetFileNameFromPath(Url) Dim FileName As String = GetFileNameFromPath(Url)
Dim Version As String = GetFileNameFromPath(DownloadInfo("version").ToString) Dim Version As String = GetFileNameFromPath(DownloadInfo("version").ToString)
Dim Target As String = SelectSaveFile("选择保存位置", FileName, "Fabric 安装器 (*.jar)|*.jar") Dim Target As String = SelectSaveFile("选择保存位置", FileName, "Fabric 安装器 (*.jar)|*.jar")
If Not Target.Contains("\") Then Exit Sub If Not Target.Contains("\") Then Return
'重复任务检查 '重复任务检查
For Each OngoingLoader In LoaderTaskbar.ToList() For Each OngoingLoader In LoaderTaskbar.ToList()
If OngoingLoader.Name <> $"Fabric {Version} 安装器下载" Then Continue For If OngoingLoader.Name <> $"Fabric {Version} 安装器下载" Then Continue For
Hint("该版本正在下载中!", HintType.Critical) Hint("该版本正在下载中!", HintType.Critical)
Exit Sub Return
Next Next
'构造步骤加载器 '构造步骤加载器
@@ -2006,7 +2009,7 @@ Retry:
Case LoadState.Aborted Case LoadState.Aborted
Hint(Loader.Name & "已取消!", HintType.Info) Hint(Loader.Name & "已取消!", HintType.Info)
Case LoadState.Loading Case LoadState.Loading
Exit Sub '不重新加载版本列表 Return '不重新加载版本列表
End Select End Select
McInstallFailedClearFolder(Loader) McInstallFailedClearFolder(Loader)
LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\")
@@ -2163,13 +2166,17 @@ Retry:
'迁移文件 '迁移文件
If Directory.Exists(TempMcFolder & "libraries") Then CopyDirectory(TempMcFolder & "libraries", PathMcFolder & "libraries") If Directory.Exists(TempMcFolder & "libraries") Then CopyDirectory(TempMcFolder & "libraries", PathMcFolder & "libraries")
Task.Progress = 0.8 Task.Progress = 0.8
'创建 Mod 和资源包文件夹
Dim ModsFolder = New McVersion(VersionFolder).PathIndie & "mods\" '版本隔离信息在此时被决定 Dim ModsFolder = New McVersion(VersionFolder).PathIndie & "mods\" '版本隔离信息在此时被决定
If Directory.Exists(ModsTempFolder) Then If Directory.Exists(ModsTempFolder) Then
CopyDirectory(ModsTempFolder, ModsFolder) CopyDirectory(ModsTempFolder, ModsFolder)
ElseIf Modable Then ElseIf Modable Then
Directory.CreateDirectory(ModsFolder) Directory.CreateDirectory(ModsFolder)
Log("[Download] 自动创建 mods 文件夹:" & ModsFolder) Log("[Download] 自动创建 Mod 文件夹:" & ModsFolder)
End If End If
Dim ResourcepacksFolder = New McVersion(VersionFolder).PathIndie & "resourcepacks\"
Directory.CreateDirectory(ResourcepacksFolder)
Log("[Download] 自动创建资源包文件夹:" & ResourcepacksFolder)
End Sub) With {.ProgressWeight = 2, .Block = True}) End Sub) With {.ProgressWeight = 2, .Block = True})
'补全文件 '补全文件
If Request.OptiFineEntry IsNot Nothing OrElse (Request.ForgeVersion IsNot Nothing AndAlso Request.ForgeVersion.BeforeFirst(".") >= 20) OrElse Request.NeoForgeVersion IsNot Nothing OrElse Request.FabricVersion IsNot Nothing OrElse Request.LiteLoaderEntry IsNot Nothing Then If Request.OptiFineEntry IsNot Nothing OrElse (Request.ForgeVersion IsNot Nothing AndAlso Request.ForgeVersion.BeforeFirst(".") >= 20) OrElse Request.NeoForgeVersion IsNot Nothing OrElse Request.FabricVersion IsNot Nothing OrElse Request.LiteLoaderEntry IsNot Nothing Then
@@ -88,7 +88,7 @@
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
NewCard.Children.Add(NewStack) NewCard.Children.Add(NewStack)
NewCard.SwapControl = NewStack NewCard.SwapControl = NewStack
NewCard.IsSwaped = True NewCard.IsSwapped = True
PanMain.Children.Add(NewCard) PanMain.Children.Add(NewCard)
Next Next
Catch ex As Exception Catch ex As Exception
@@ -19,7 +19,7 @@
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Version} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Version}
NewCard.Children.Add(NewStack) NewCard.Children.Add(NewStack)
NewCard.SwapControl = NewStack NewCard.SwapControl = NewStack
NewCard.IsSwaped = True NewCard.IsSwapped = True
PanMain.Children.Add(NewCard) PanMain.Children.Add(NewCard)
Next Next
''非官方源警示 ''非官方源警示
@@ -42,7 +42,7 @@
End If End If
End Sub End Sub
Public Sub Forge_StateChanged(sender As MyLoading, newState As MyLoading.MyLoadingState, oldState As MyLoading.MyLoadingState) Public Sub Forge_StateChanged(sender As MyLoading, newState As MyLoading.MyLoadingState, oldState As MyLoading.MyLoadingState)
If newState <> MyLoading.MyLoadingState.Stop Then Exit Sub If newState <> MyLoading.MyLoadingState.Stop Then Return
Dim Card As MyCard = CType(sender.Parent, FrameworkElement).Parent Dim Card As MyCard = CType(sender.Parent, FrameworkElement).Parent
Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = sender.State Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = sender.State
@@ -23,11 +23,11 @@
<local:MyImage x:Name="ImgLogo" Margin="52,0,0,0" VerticalAlignment="Center" HorizontalAlignment="Left" Height="32" RenderOptions.BitmapScalingMode="HighQuality" /> <local:MyImage x:Name="ImgLogo" Margin="52,0,0,0" VerticalAlignment="Center" HorizontalAlignment="Left" Height="32" RenderOptions.BitmapScalingMode="HighQuality" />
<local:MyTextBox Margin="93,0,16,0" Padding="-1,0" MinHeight="30" FontSize="15" VerticalAlignment="Center" x:Name="TextSelectName" MaxLength="70" HasBackground="False" /> <local:MyTextBox Margin="93,0,16,0" Padding="-1,0" MinHeight="30" FontSize="15" VerticalAlignment="Center" x:Name="TextSelectName" MaxLength="70" HasBackground="False" />
</local:MyCard> </local:MyCard>
<local:MyHint Text="如果不安装 Fabric API,大多数 Mod 都会无法使用!" Margin="0,10,0,0" x:Name="HintFabricAPI" IsWarn="True" /> <local:MyHint Text="如果不安装 Fabric API,大多数 Mod 都会无法使用!" Margin="0,10,0,0" x:Name="HintFabricAPI" Theme="Red" />
<local:MyHint Text="必须安装 OptiFabric 才能正常使用 OptiFine!" Margin="0,10,0,0" x:Name="HintOptiFabric" IsWarn="True" /> <local:MyHint Text="必须安装 OptiFabric 才能正常使用 OptiFine!" Margin="0,10,0,0" x:Name="HintOptiFabric" Theme="Red" />
<local:MyHint Text="安装结束后,请在 Mod 下载中搜索 OptiFabric Origins 并下载,否则 OptiFine 会无法使用!" Margin="0,10,0,0" x:Name="HintOptiFabricOld" IsWarn="False" /> <local:MyHint Text="安装结束后,请在 Mod 下载中搜索 OptiFabric Origins 并下载,否则 OptiFine 会无法使用!" Margin="0,10,0,0" x:Name="HintOptiFabricOld" Theme="Yellow" />
<local:MyHint Text="OptiFine 与一部分 Mod 的兼容性不佳,请谨慎安装。" Margin="0,10,0,0" x:Name="HintModOptiFine" IsWarn="False" /> <local:MyHint Text="OptiFine 与一部分 Mod 的兼容性不佳,请谨慎安装。" Margin="0,10,0,0" x:Name="HintModOptiFine" Theme="Yellow" />
<local:MyCard Title="Forge" Height="40" Margin="0,12,0,0" x:Name="CardForge" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="Forge" Height="40" Margin="0,12,0,0" x:Name="CardForge" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanForge" /> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanForge" />
<Grid x:Name="PanForgeInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True"> <Grid x:Name="PanForgeInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform> <Grid.RenderTransform>
@@ -45,7 +45,7 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyCard Title="NeoForge" Height="40" Margin="0,12,0,0" x:Name="CardNeoForge" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="NeoForge" Height="40" Margin="0,12,0,0" x:Name="CardNeoForge" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanNeoForge" /> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanNeoForge" />
<Grid x:Name="PanNeoForgeInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True"> <Grid x:Name="PanNeoForgeInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform> <Grid.RenderTransform>
@@ -63,7 +63,7 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyCard Title="Fabric" Height="40" Margin="0,12,0,0" x:Name="CardFabric" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="Fabric" Height="40" Margin="0,12,0,0" x:Name="CardFabric" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanFabric" /> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanFabric" />
<Grid x:Name="PanFabricInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True"> <Grid x:Name="PanFabricInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform> <Grid.RenderTransform>
@@ -81,7 +81,7 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyCard Title="Fabric API" Height="40" Margin="0,12,0,0" x:Name="CardFabricApi" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="Fabric API" Height="40" Margin="0,12,0,0" x:Name="CardFabricApi" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanFabricApi" /> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanFabricApi" />
<Grid x:Name="PanFabricApiInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True"> <Grid x:Name="PanFabricApiInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform> <Grid.RenderTransform>
@@ -99,7 +99,7 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyCard Title="OptiFine" Height="40" Margin="0,12,0,0" x:Name="CardOptiFine" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="OptiFine" Height="40" Margin="0,12,0,0" x:Name="CardOptiFine" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top"> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top">
<StackPanel Name="PanOptiFine" /> <StackPanel Name="PanOptiFine" />
</StackPanel> </StackPanel>
@@ -119,7 +119,7 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyCard Title="OptiFabric" Height="40" Margin="0,12,0,0" x:Name="CardOptiFabric" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="OptiFabric" Height="40" Margin="0,12,0,0" x:Name="CardOptiFabric" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanOptiFabric" /> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanOptiFabric" />
<Grid x:Name="PanOptiFabricInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True"> <Grid x:Name="PanOptiFabricInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform> <Grid.RenderTransform>
@@ -137,7 +137,7 @@
Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" /> Data="F1 M2,0 L0,2 8,10 0,18 2,20 10,12 18,20 20,18 12,10 20,2 18,0 10,8 2,0Z" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyCard Title="LiteLoader" Height="40" Margin="0,12,0,0" x:Name="CardLiteLoader" IsSwaped="True" CanSwap="True" SwapLogoRight="True"> <local:MyCard Title="LiteLoader" Height="40" Margin="0,12,0,0" x:Name="CardLiteLoader" IsSwapped="True" CanSwap="True" SwapLogoRight="True">
<StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanLiteLoader" /> <StackPanel Margin="20,40,18,15" VerticalAlignment="Top" Name="PanLiteLoader" />
<Grid x:Name="PanLiteLoaderInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True"> <Grid x:Name="PanLiteLoaderInfo" Height="18" Margin="132,11,15,0" VerticalAlignment="Top" Tag="True">
<Grid.RenderTransform> <Grid.RenderTransform>
@@ -19,7 +19,7 @@
SelectReload() SelectReload()
'非重复加载部分 '非重复加载部分
If IsLoad Then Exit Sub If IsLoad Then Return
IsLoad = True IsLoad = True
McDownloadForgeRecommendedRefresh() McDownloadForgeRecommendedRefresh()
@@ -38,7 +38,7 @@
Public IsInSelectPage As Boolean = False Public IsInSelectPage As Boolean = False
Private IsFirstLoaded As Boolean = False Private IsFirstLoaded As Boolean = False
Private Sub EnterSelectPage() Private Sub EnterSelectPage()
If IsInSelectPage Then Exit Sub If IsInSelectPage Then Return
IsInSelectPage = True IsInSelectPage = True
PanInner.Margin = New Thickness(25, 10, 25, 40) PanInner.Margin = New Thickness(25, 10, 25, 40)
@@ -54,18 +54,13 @@
DisabledPageAnimControls.Remove(BtnStart) DisabledPageAnimControls.Remove(BtnStart)
BtnStart.Show = True BtnStart.Show = True
CardOptiFine.IsSwaped = True CardOptiFine.IsSwapped = True
CardLiteLoader.IsSwaped = True CardLiteLoader.IsSwapped = True
CardForge.IsSwaped = True CardForge.IsSwapped = True
CardNeoForge.IsSwaped = True CardNeoForge.IsSwapped = True
CardFabric.IsSwaped = True CardFabric.IsSwapped = True
CardFabricApi.IsSwaped = True CardFabricApi.IsSwapped = True
CardOptiFabric.IsSwaped = True CardOptiFabric.IsSwapped = True
If Not Setup.Get("HintInstallBack") Then
Setup.Set("HintInstallBack", True)
Hint("点击 Minecraft 项即可返回游戏主版本选择页面!")
End If
'如果在选择页面按了刷新键,选择页的东西可能会由于动画被隐藏,但不会由于加载结束而再次显示,因此这里需要手动恢复 '如果在选择页面按了刷新键,选择页的东西可能会由于动画被隐藏,但不会由于加载结束而再次显示,因此这里需要手动恢复
For Each Control In GetAllAnimControls(PanSelect) For Each Control In GetAllAnimControls(PanSelect)
@@ -87,8 +82,8 @@
DlOptiFabricLoader.Start() DlOptiFabricLoader.Start()
AniStart({ AniStart({
AaOpacity(PanMinecraft, -PanMinecraft.Opacity, 90, 10), AaOpacity(PanMinecraft, -PanMinecraft.Opacity, 70, 10),
AaTranslateX(PanMinecraft, -50 - CType(PanMinecraft.RenderTransform, TranslateTransform).X, 100, 10), AaTranslateX(PanMinecraft, -50 - CType(PanMinecraft.RenderTransform, TranslateTransform).X, 90, 10),
AaCode( AaCode(
Sub() Sub()
PanBack.ScrollToHome() PanBack.ScrollToHome()
@@ -103,13 +98,13 @@
SelectReload() SelectReload()
PanMinecraft.Visibility = Visibility.Collapsed PanMinecraft.Visibility = Visibility.Collapsed
End Sub, After:=True), End Sub, After:=True),
AaOpacity(PanSelect, 1 - PanSelect.Opacity, 90, 100), AaOpacity(PanSelect, 1 - PanSelect.Opacity, 70, 100),
AaTranslateX(PanSelect, -CType(PanSelect.RenderTransform, TranslateTransform).X, 200, 100, Ease:=New AniEaseOutFluent(AniEasePower.ExtraStrong)), AaTranslateX(PanSelect, -CType(PanSelect.RenderTransform, TranslateTransform).X, 160, 100, Ease:=New AniEaseOutFluent(AniEasePower.ExtraStrong)),
AaCode( AaCode(
Sub() Sub()
PanBack.IsHitTestVisible = True PanBack.IsHitTestVisible = True
'初始化 Binding '初始化 Binding
If IsFirstLoaded Then Exit Sub If IsFirstLoaded Then Return
IsFirstLoaded = True IsFirstLoaded = True
BtnOptiFineClearInner.SetBinding(Shapes.Path.FillProperty, New Binding("Foreground") With {.Source = CardOptiFine.MainTextBlock, .Mode = BindingMode.OneWay}) BtnOptiFineClearInner.SetBinding(Shapes.Path.FillProperty, New Binding("Foreground") With {.Source = CardOptiFine.MainTextBlock, .Mode = BindingMode.OneWay})
BtnLiteLoaderClearInner.SetBinding(Shapes.Path.FillProperty, New Binding("Foreground") With {.Source = CardLiteLoader.MainTextBlock, .Mode = BindingMode.OneWay}) BtnLiteLoaderClearInner.SetBinding(Shapes.Path.FillProperty, New Binding("Foreground") With {.Source = CardLiteLoader.MainTextBlock, .Mode = BindingMode.OneWay})
@@ -122,7 +117,7 @@
}, "FrmDownloadInstall SelectPageSwitch", True) }, "FrmDownloadInstall SelectPageSwitch", True)
End Sub End Sub
Public Sub ExitSelectPage() Handles BtnBack.Click Public Sub ExitSelectPage() Handles BtnBack.Click
If Not IsInSelectPage Then Exit Sub If Not IsInSelectPage Then Return
IsInSelectPage = False IsInSelectPage = False
PanInner.Margin = New Thickness(25, 10, 25, 25) PanInner.Margin = New Thickness(25, 10, 25, 25)
@@ -137,11 +132,11 @@
PanBack.ScrollToHome() PanBack.ScrollToHome()
AniStart({ AniStart({
AaOpacity(PanSelect, -PanSelect.Opacity, 90, 10), AaOpacity(PanSelect, -PanSelect.Opacity, 70, 10),
AaTranslateX(PanSelect, 50 - CType(PanSelect.RenderTransform, TranslateTransform).X, 100, 10), AaTranslateX(PanSelect, 50 - CType(PanSelect.RenderTransform, TranslateTransform).X, 90, 10),
AaCode(Sub() PanBack.ScrollToHome(), After:=True), AaCode(Sub() PanBack.ScrollToHome(), After:=True),
AaOpacity(PanMinecraft, 1 - PanMinecraft.Opacity, 90, 100), AaOpacity(PanMinecraft, 1 - PanMinecraft.Opacity, 70, 100),
AaTranslateX(PanMinecraft, -CType(PanMinecraft.RenderTransform, TranslateTransform).X, 200, 100, Ease:=New AniEaseOutFluent(AniEasePower.ExtraStrong)), AaTranslateX(PanMinecraft, -CType(PanMinecraft.RenderTransform, TranslateTransform).X, 160, 100, Ease:=New AniEaseOutFluent(AniEasePower.ExtraStrong)),
AaCode( AaCode(
Sub() Sub()
PanSelect.Visibility = Visibility.Collapsed PanSelect.Visibility = Visibility.Collapsed
@@ -168,19 +163,19 @@
'OptiFine 'OptiFine
Private SelectedOptiFine As DlOptiFineListEntry = Nothing Private SelectedOptiFine As DlOptiFineListEntry = Nothing
Private Sub SetOptiFineInfoShow(IsShow As String) Private Sub SetOptiFineInfoShow(IsShow As String)
If PanOptiFineInfo.Tag = IsShow Then Exit Sub If PanOptiFineInfo.Tag = IsShow Then Return
PanOptiFineInfo.Tag = IsShow PanOptiFineInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanOptiFineInfo, -CType(PanOptiFineInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanOptiFineInfo, -CType(PanOptiFineInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanOptiFineInfo, 1 - PanOptiFineInfo.Opacity, 100, 90) AaOpacity(PanOptiFineInfo, 1 - PanOptiFineInfo.Opacity, 80, 90)
}, "SetOptiFineInfoShow") }, "SetOptiFineInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanOptiFineInfo, 6 - CType(PanOptiFineInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanOptiFineInfo, 6 - CType(PanOptiFineInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanOptiFineInfo, -PanOptiFineInfo.Opacity, 100) AaOpacity(PanOptiFineInfo, -PanOptiFineInfo.Opacity, 50)
}, "SetOptiFineInfoShow") }, "SetOptiFineInfoShow")
End If End If
End Sub End Sub
@@ -188,19 +183,19 @@
'LiteLoader 'LiteLoader
Private SelectedLiteLoader As DlLiteLoaderListEntry = Nothing Private SelectedLiteLoader As DlLiteLoaderListEntry = Nothing
Private Sub SetLiteLoaderInfoShow(IsShow As String) Private Sub SetLiteLoaderInfoShow(IsShow As String)
If PanLiteLoaderInfo.Tag = IsShow Then Exit Sub If PanLiteLoaderInfo.Tag = IsShow Then Return
PanLiteLoaderInfo.Tag = IsShow PanLiteLoaderInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanLiteLoaderInfo, -CType(PanLiteLoaderInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanLiteLoaderInfo, -CType(PanLiteLoaderInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanLiteLoaderInfo, 1 - PanLiteLoaderInfo.Opacity, 100, 90) AaOpacity(PanLiteLoaderInfo, 1 - PanLiteLoaderInfo.Opacity, 80, 90)
}, "SetLiteLoaderInfoShow") }, "SetLiteLoaderInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanLiteLoaderInfo, 6 - CType(PanLiteLoaderInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanLiteLoaderInfo, 6 - CType(PanLiteLoaderInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanLiteLoaderInfo, -PanLiteLoaderInfo.Opacity, 100) AaOpacity(PanLiteLoaderInfo, -PanLiteLoaderInfo.Opacity, 50)
}, "SetLiteLoaderInfoShow") }, "SetLiteLoaderInfoShow")
End If End If
End Sub End Sub
@@ -208,19 +203,19 @@
'Forge 'Forge
Private SelectedForge As DlForgeVersionEntry = Nothing Private SelectedForge As DlForgeVersionEntry = Nothing
Private Sub SetForgeInfoShow(IsShow As String) Private Sub SetForgeInfoShow(IsShow As String)
If PanForgeInfo.Tag = IsShow Then Exit Sub If PanForgeInfo.Tag = IsShow Then Return
PanForgeInfo.Tag = IsShow PanForgeInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanForgeInfo, -CType(PanForgeInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanForgeInfo, -CType(PanForgeInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanForgeInfo, 1 - PanForgeInfo.Opacity, 100, 90) AaOpacity(PanForgeInfo, 1 - PanForgeInfo.Opacity, 80, 90)
}, "SetForgeInfoShow") }, "SetForgeInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanForgeInfo, 6 - CType(PanForgeInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanForgeInfo, 6 - CType(PanForgeInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanForgeInfo, -PanForgeInfo.Opacity, 100) AaOpacity(PanForgeInfo, -PanForgeInfo.Opacity, 50)
}, "SetForgeInfoShow") }, "SetForgeInfoShow")
End If End If
End Sub End Sub
@@ -228,19 +223,19 @@
'NeoForge 'NeoForge
Private SelectedNeoForge As DlNeoForgeListEntry = Nothing Private SelectedNeoForge As DlNeoForgeListEntry = Nothing
Private Sub SetNeoForgeInfoShow(IsShow As String) Private Sub SetNeoForgeInfoShow(IsShow As String)
If PanNeoForgeInfo.Tag = IsShow Then Exit Sub If PanNeoForgeInfo.Tag = IsShow Then Return
PanNeoForgeInfo.Tag = IsShow PanNeoForgeInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanNeoForgeInfo, -CType(PanNeoForgeInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanNeoForgeInfo, -CType(PanNeoForgeInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanNeoForgeInfo, 1 - PanNeoForgeInfo.Opacity, 100, 90) AaOpacity(PanNeoForgeInfo, 1 - PanNeoForgeInfo.Opacity, 80, 90)
}, "SetNeoForgeInfoShow") }, "SetNeoForgeInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanNeoForgeInfo, 6 - CType(PanNeoForgeInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanNeoForgeInfo, 6 - CType(PanNeoForgeInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanNeoForgeInfo, -PanNeoForgeInfo.Opacity, 100) AaOpacity(PanNeoForgeInfo, -PanNeoForgeInfo.Opacity, 50)
}, "SetNeoForgeInfoShow") }, "SetNeoForgeInfoShow")
End If End If
End Sub End Sub
@@ -248,19 +243,19 @@
'Fabric 'Fabric
Private SelectedFabric As String = Nothing Private SelectedFabric As String = Nothing
Private Sub SetFabricInfoShow(IsShow As String) Private Sub SetFabricInfoShow(IsShow As String)
If PanFabricInfo.Tag = IsShow Then Exit Sub If PanFabricInfo.Tag = IsShow Then Return
PanFabricInfo.Tag = IsShow PanFabricInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanFabricInfo, -CType(PanFabricInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanFabricInfo, -CType(PanFabricInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanFabricInfo, 1 - PanFabricInfo.Opacity, 100, 90) AaOpacity(PanFabricInfo, 1 - PanFabricInfo.Opacity, 80, 90)
}, "SetFabricInfoShow") }, "SetFabricInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanFabricInfo, 6 - CType(PanFabricInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanFabricInfo, 6 - CType(PanFabricInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanFabricInfo, -PanFabricInfo.Opacity, 100) AaOpacity(PanFabricInfo, -PanFabricInfo.Opacity, 50)
}, "SetFabricInfoShow") }, "SetFabricInfoShow")
End If End If
End Sub End Sub
@@ -268,19 +263,19 @@
'FabricApi 'FabricApi
Private SelectedFabricApi As CompFile = Nothing Private SelectedFabricApi As CompFile = Nothing
Private Sub SetFabricApiInfoShow(IsShow As String) Private Sub SetFabricApiInfoShow(IsShow As String)
If PanFabricApiInfo.Tag = IsShow Then Exit Sub If PanFabricApiInfo.Tag = IsShow Then Return
PanFabricApiInfo.Tag = IsShow PanFabricApiInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanFabricApiInfo, -CType(PanFabricApiInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanFabricApiInfo, -CType(PanFabricApiInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanFabricApiInfo, 1 - PanFabricApiInfo.Opacity, 100, 90) AaOpacity(PanFabricApiInfo, 1 - PanFabricApiInfo.Opacity, 80, 90)
}, "SetFabricApiInfoShow") }, "SetFabricApiInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanFabricApiInfo, 6 - CType(PanFabricApiInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanFabricApiInfo, 6 - CType(PanFabricApiInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanFabricApiInfo, -PanFabricApiInfo.Opacity, 100) AaOpacity(PanFabricApiInfo, -PanFabricApiInfo.Opacity, 50)
}, "SetFabricApiInfoShow") }, "SetFabricApiInfoShow")
End If End If
End Sub End Sub
@@ -288,19 +283,19 @@
'OptiFabric 'OptiFabric
Private SelectedOptiFabric As CompFile = Nothing Private SelectedOptiFabric As CompFile = Nothing
Private Sub SetOptiFabricInfoShow(IsShow As String) Private Sub SetOptiFabricInfoShow(IsShow As String)
If PanOptiFabricInfo.Tag = IsShow Then Exit Sub If PanOptiFabricInfo.Tag = IsShow Then Return
PanOptiFabricInfo.Tag = IsShow PanOptiFabricInfo.Tag = IsShow
If IsShow = "True" Then If IsShow = "True" Then
'显示信息栏 '显示信息栏
AniStart({ AniStart({
AaTranslateY(PanOptiFabricInfo, -CType(PanOptiFabricInfo.RenderTransform, TranslateTransform).Y, 270, 100, Ease:=New AniEaseOutBack), AaTranslateY(PanOptiFabricInfo, -CType(PanOptiFabricInfo.RenderTransform, TranslateTransform).Y, 200, 100, Ease:=New AniEaseOutFluent),
AaOpacity(PanOptiFabricInfo, 1 - PanOptiFabricInfo.Opacity, 100, 90) AaOpacity(PanOptiFabricInfo, 1 - PanOptiFabricInfo.Opacity, 80, 90)
}, "SetOptiFabricInfoShow") }, "SetOptiFabricInfoShow")
Else Else
'隐藏信息栏 '隐藏信息栏
AniStart({ AniStart({
AaTranslateY(PanOptiFabricInfo, 6 - CType(PanOptiFabricInfo.RenderTransform, TranslateTransform).Y, 200), AaTranslateY(PanOptiFabricInfo, 6 - CType(PanOptiFabricInfo.RenderTransform, TranslateTransform).Y, 120),
AaOpacity(PanOptiFabricInfo, -PanOptiFabricInfo.Opacity, 100) AaOpacity(PanOptiFabricInfo, -PanOptiFabricInfo.Opacity, 50)
}, "SetOptiFabricInfoShow") }, "SetOptiFabricInfoShow")
End If End If
End Sub End Sub
@@ -310,7 +305,7 @@
''' 重载已选择的项目的显示。 ''' 重载已选择的项目的显示。
''' </summary> ''' </summary>
Private Sub SelectReload() Handles CardOptiFine.Swap, LoadOptiFine.StateChanged, CardForge.Swap, LoadForge.StateChanged, CardNeoForge.Swap, LoadNeoForge.StateChanged, CardFabric.Swap, LoadFabric.StateChanged, CardFabricApi.Swap, LoadFabricApi.StateChanged, CardOptiFabric.Swap, LoadOptiFabric.StateChanged, CardLiteLoader.Swap, LoadLiteLoader.StateChanged Private Sub SelectReload() Handles CardOptiFine.Swap, LoadOptiFine.StateChanged, CardForge.Swap, LoadForge.StateChanged, CardNeoForge.Swap, LoadNeoForge.StateChanged, CardFabric.Swap, LoadFabric.StateChanged, CardFabricApi.Swap, LoadFabricApi.StateChanged, CardOptiFabric.Swap, LoadOptiFabric.StateChanged, CardLiteLoader.Swap, LoadLiteLoader.StateChanged
If SelectedMinecraftId Is Nothing OrElse IsReloading Then Exit Sub If SelectedMinecraftId Is Nothing OrElse IsReloading Then Return
IsReloading = True IsReloading = True
'主预览 '主预览
SelectNameUpdate() SelectNameUpdate()
@@ -318,8 +313,8 @@
'OptiFine 'OptiFine
Dim OptiFineError As String = LoadOptiFineGetError() Dim OptiFineError As String = LoadOptiFineGetError()
CardOptiFine.MainSwap.Visibility = If(OptiFineError Is Nothing, Visibility.Visible, Visibility.Collapsed) CardOptiFine.MainSwap.Visibility = If(OptiFineError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If OptiFineError IsNot Nothing Then CardOptiFine.IsSwaped = True '例如在同时展开卡片时选择了不兼容项则强制折叠 If OptiFineError IsNot Nothing Then CardOptiFine.IsSwapped = True '例如在同时展开卡片时选择了不兼容项则强制折叠
SetOptiFineInfoShow(CardOptiFine.IsSwaped) SetOptiFineInfoShow(CardOptiFine.IsSwapped)
If SelectedOptiFine Is Nothing Then If SelectedOptiFine Is Nothing Then
BtnOptiFineClear.Visibility = Visibility.Collapsed BtnOptiFineClear.Visibility = Visibility.Collapsed
ImgOptiFine.Visibility = Visibility.Collapsed ImgOptiFine.Visibility = Visibility.Collapsed
@@ -338,8 +333,8 @@
CardLiteLoader.Visibility = Visibility.Visible CardLiteLoader.Visibility = Visibility.Visible
Dim LiteLoaderError As String = LoadLiteLoaderGetError() Dim LiteLoaderError As String = LoadLiteLoaderGetError()
CardLiteLoader.MainSwap.Visibility = If(LiteLoaderError Is Nothing, Visibility.Visible, Visibility.Collapsed) CardLiteLoader.MainSwap.Visibility = If(LiteLoaderError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If LiteLoaderError IsNot Nothing Then CardLiteLoader.IsSwaped = True '例如在同时展开卡片时选择了不兼容项则强制折叠 If LiteLoaderError IsNot Nothing Then CardLiteLoader.IsSwapped = True '例如在同时展开卡片时选择了不兼容项则强制折叠
SetLiteLoaderInfoShow(CardLiteLoader.IsSwaped) SetLiteLoaderInfoShow(CardLiteLoader.IsSwapped)
If SelectedLiteLoader Is Nothing Then If SelectedLiteLoader Is Nothing Then
BtnLiteLoaderClear.Visibility = Visibility.Collapsed BtnLiteLoaderClear.Visibility = Visibility.Collapsed
ImgLiteLoader.Visibility = Visibility.Collapsed ImgLiteLoader.Visibility = Visibility.Collapsed
@@ -355,8 +350,8 @@
'Forge 'Forge
Dim ForgeError As String = LoadForgeGetError() Dim ForgeError As String = LoadForgeGetError()
CardForge.MainSwap.Visibility = If(ForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed) CardForge.MainSwap.Visibility = If(ForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If ForgeError IsNot Nothing Then CardForge.IsSwaped = True If ForgeError IsNot Nothing Then CardForge.IsSwapped = True
SetForgeInfoShow(CardForge.IsSwaped) SetForgeInfoShow(CardForge.IsSwapped)
If SelectedForge Is Nothing Then If SelectedForge Is Nothing Then
BtnForgeClear.Visibility = Visibility.Collapsed BtnForgeClear.Visibility = Visibility.Collapsed
ImgForge.Visibility = Visibility.Collapsed ImgForge.Visibility = Visibility.Collapsed
@@ -379,10 +374,22 @@
LabNeoForge.Text = If(NeoForgeError, "可以添加") LabNeoForge.Text = If(NeoForgeError, "可以添加")
LabNeoForge.Foreground = ColorGray4 LabNeoForge.Foreground = ColorGray4
Else Else
BtnNeoForgeClear.Visibility = Visibility.Visible CardNeoForge.Visibility = Visibility.Visible
ImgNeoForge.Visibility = Visibility.Visible Dim NeoForgeError As String = LoadNeoForgeGetError()
LabNeoForge.Text = SelectedNeoForge.VersionName CardNeoForge.MainSwap.Visibility = If(NeoForgeError Is Nothing, Visibility.Visible, Visibility.Collapsed)
LabNeoForge.Foreground = ColorGray1 If NeoForgeError IsNot Nothing Then CardNeoForge.IsSwapped = True
SetNeoForgeInfoShow(CardNeoForge.IsSwapped)
If SelectedNeoForge Is Nothing Then
BtnNeoForgeClear.Visibility = Visibility.Collapsed
ImgNeoForge.Visibility = Visibility.Collapsed
LabNeoForge.Text = If(NeoForgeError, "可以添加")
LabNeoForge.Foreground = ColorGray4
Else
BtnNeoForgeClear.Visibility = Visibility.Visible
ImgNeoForge.Visibility = Visibility.Visible
LabNeoForge.Text = SelectedNeoForge.VersionName
LabNeoForge.Foreground = ColorGray1
End If
End If End If
'Fabric 'Fabric
If SelectedMinecraftId.Contains("1.") AndAlso Val(SelectedMinecraftId.Split(".")(1)) <= 13 Then If SelectedMinecraftId.Contains("1.") AndAlso Val(SelectedMinecraftId.Split(".")(1)) <= 13 Then
@@ -391,8 +398,8 @@
CardFabric.Visibility = Visibility.Visible CardFabric.Visibility = Visibility.Visible
Dim FabricError As String = LoadFabricGetError() Dim FabricError As String = LoadFabricGetError()
CardFabric.MainSwap.Visibility = If(FabricError Is Nothing, Visibility.Visible, Visibility.Collapsed) CardFabric.MainSwap.Visibility = If(FabricError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If FabricError IsNot Nothing Then CardFabric.IsSwaped = True If FabricError IsNot Nothing Then CardFabric.IsSwapped = True
SetFabricInfoShow(CardFabric.IsSwaped) SetFabricInfoShow(CardFabric.IsSwapped)
If SelectedFabric Is Nothing Then If SelectedFabric Is Nothing Then
BtnFabricClear.Visibility = Visibility.Collapsed BtnFabricClear.Visibility = Visibility.Collapsed
ImgFabric.Visibility = Visibility.Collapsed ImgFabric.Visibility = Visibility.Collapsed
@@ -412,8 +419,8 @@
CardFabricApi.Visibility = Visibility.Visible CardFabricApi.Visibility = Visibility.Visible
Dim FabricApiError As String = LoadFabricApiGetError() Dim FabricApiError As String = LoadFabricApiGetError()
CardFabricApi.MainSwap.Visibility = If(FabricApiError Is Nothing, Visibility.Visible, Visibility.Collapsed) CardFabricApi.MainSwap.Visibility = If(FabricApiError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If FabricApiError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardFabricApi.IsSwaped = True If FabricApiError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardFabricApi.IsSwapped = True
SetFabricApiInfoShow(CardFabricApi.IsSwaped) SetFabricApiInfoShow(CardFabricApi.IsSwapped)
If SelectedFabricApi Is Nothing Then If SelectedFabricApi Is Nothing Then
BtnFabricApiClear.Visibility = Visibility.Collapsed BtnFabricApiClear.Visibility = Visibility.Collapsed
ImgFabricApi.Visibility = Visibility.Collapsed ImgFabricApi.Visibility = Visibility.Collapsed
@@ -433,8 +440,8 @@
CardOptiFabric.Visibility = Visibility.Visible CardOptiFabric.Visibility = Visibility.Visible
Dim OptiFabricError As String = LoadOptiFabricGetError() Dim OptiFabricError As String = LoadOptiFabricGetError()
CardOptiFabric.MainSwap.Visibility = If(OptiFabricError Is Nothing, Visibility.Visible, Visibility.Collapsed) CardOptiFabric.MainSwap.Visibility = If(OptiFabricError Is Nothing, Visibility.Visible, Visibility.Collapsed)
If OptiFabricError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardOptiFabric.IsSwaped = True If OptiFabricError IsNot Nothing OrElse SelectedFabric Is Nothing Then CardOptiFabric.IsSwapped = True
SetOptiFabricInfoShow(CardOptiFabric.IsSwaped) SetOptiFabricInfoShow(CardOptiFabric.IsSwapped)
If SelectedOptiFabric Is Nothing Then If SelectedOptiFabric Is Nothing Then
BtnOptiFabricClear.Visibility = Visibility.Collapsed BtnOptiFabricClear.Visibility = Visibility.Collapsed
ImgOptiFabric.Visibility = Visibility.Collapsed ImgOptiFabric.Visibility = Visibility.Collapsed
@@ -535,13 +542,13 @@
Private IsSelectNameEdited As Boolean = False Private IsSelectNameEdited As Boolean = False
Private IsSelectNameChanging As Boolean = False Private IsSelectNameChanging As Boolean = False
Private Sub SelectNameUpdate() Private Sub SelectNameUpdate()
If IsSelectNameEdited OrElse IsSelectNameChanging Then Exit Sub If IsSelectNameEdited OrElse IsSelectNameChanging Then Return
IsSelectNameChanging = True IsSelectNameChanging = True
TextSelectName.Text = GetSelectName() TextSelectName.Text = GetSelectName()
IsSelectNameChanging = False IsSelectNameChanging = False
End Sub End Sub
Private Sub TextSelectName_TextChanged(sender As Object, e As TextChangedEventArgs) Handles TextSelectName.TextChanged Private Sub TextSelectName_TextChanged(sender As Object, e As TextChangedEventArgs) Handles TextSelectName.TextChanged
If IsSelectNameChanging Then Exit Sub If IsSelectNameChanging Then Return
IsSelectNameEdited = True IsSelectNameEdited = True
SelectReload() SelectReload()
End Sub End Sub
@@ -634,7 +641,7 @@
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
NewCard.Children.Add(NewStack) NewCard.Children.Add(NewStack)
NewCard.SwapControl = NewStack NewCard.SwapControl = NewStack
NewCard.IsSwaped = True NewCard.IsSwapped = True
PanMinecraft.Children.Add(NewCard) PanMinecraft.Children.Add(NewCard)
Next Next
'自动选择版本 '自动选择版本
@@ -671,6 +678,11 @@
VersionSortInteger(SelectedMinecraftId, "1.13") >= 0 AndAlso VersionSortInteger("1.14.3", SelectedMinecraftId) >= 0 Then VersionSortInteger(SelectedMinecraftId, "1.13") >= 0 AndAlso VersionSortInteger("1.14.3", SelectedMinecraftId) >= 0 Then
Return "与 Forge 不兼容" Return "与 Forge 不兼容"
End If End If
'检查 Fabric 1.20.5+:全部不兼容
If SelectedFabric IsNot Nothing AndAlso
VersionSortInteger(SelectedMinecraftId, "1.20.4") > 0 Then
Return "与 Fabric 不兼容"
End If
'检查 Forge 版本 '检查 Forge 版本
Dim HasAny As Boolean = False Dim HasAny As Boolean = False
Dim HasRequiredVersion As Boolean = False Dim HasRequiredVersion As Boolean = False
@@ -712,7 +724,7 @@
''' </summary> ''' </summary>
Private Sub OptiFine_Loaded() Handles LoadOptiFine.StateChanged Private Sub OptiFine_Loaded() Handles LoadOptiFine.StateChanged
Try Try
If DlOptiFineListLoader.State <> LoadState.Finished Then Exit Sub If DlOptiFineListLoader.State <> LoadState.Finished Then Return
'获取版本列表 '获取版本列表
Dim Versions As New List(Of DlOptiFineListEntry) Dim Versions As New List(Of DlOptiFineListEntry)
@@ -720,7 +732,7 @@
If SelectedForge IsNot Nothing AndAlso Not IsOptiFineSuitForForge(Version, SelectedForge) Then Continue For If SelectedForge IsNot Nothing AndAlso Not IsOptiFineSuitForForge(Version, SelectedForge) Then Continue For
If Version.NameDisplay.StartsWith(SelectedMinecraftId & " ") Then Versions.Add(Version) If Version.NameDisplay.StartsWith(SelectedMinecraftId & " ") Then Versions.Add(Version)
Next Next
If Not Versions.Any() Then Exit Sub If Not Versions.Any() Then Return
'排序 '排序
Versions = Versions.Sort( Versions = Versions.Sort(
Function(Left As DlOptiFineListEntry, Right As DlOptiFineListEntry) As Boolean Function(Left As DlOptiFineListEntry, Right As DlOptiFineListEntry) As Boolean
@@ -745,14 +757,14 @@
OptiFabric_Loaded() OptiFabric_Loaded()
Forge_Loaded() Forge_Loaded()
NeoForge_Loaded() NeoForge_Loaded()
CardOptiFine.IsSwaped = True CardOptiFine.IsSwapped = True
SelectReload() SelectReload()
End Sub End Sub
Private Sub OptiFine_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnOptiFineClear.MouseLeftButtonUp Private Sub OptiFine_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnOptiFineClear.MouseLeftButtonUp
SelectedOptiFine = Nothing SelectedOptiFine = Nothing
SelectedOptiFabric = Nothing SelectedOptiFabric = Nothing
AutoSelectedOptiFabric = False AutoSelectedOptiFabric = False
CardOptiFine.IsSwaped = True CardOptiFine.IsSwapped = True
e.Handled = True e.Handled = True
Forge_Loaded() Forge_Loaded()
NeoForge_Loaded() NeoForge_Loaded()
@@ -786,13 +798,13 @@
''' </summary> ''' </summary>
Private Sub LiteLoader_Loaded() Handles LoadLiteLoader.StateChanged Private Sub LiteLoader_Loaded() Handles LoadLiteLoader.StateChanged
Try Try
If DlLiteLoaderListLoader.State <> LoadState.Finished Then Exit Sub If DlLiteLoaderListLoader.State <> LoadState.Finished Then Return
'获取版本列表 '获取版本列表
Dim Versions As New List(Of DlLiteLoaderListEntry) Dim Versions As New List(Of DlLiteLoaderListEntry)
For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value For Each Version As DlLiteLoaderListEntry In DlLiteLoaderListLoader.Output.Value
If Version.Inherit = SelectedMinecraftId Then Versions.Add(Version) If Version.Inherit = SelectedMinecraftId Then Versions.Add(Version)
Next Next
If Not Versions.Any() Then Exit Sub If Not Versions.Any() Then Return
'可视化 '可视化
PanLiteLoader.Children.Clear() PanLiteLoader.Children.Clear()
For Each Version In Versions For Each Version In Versions
@@ -806,12 +818,12 @@
'选择与清除 '选择与清除
Private Sub LiteLoader_Selected(sender As MyListItem, e As EventArgs) Private Sub LiteLoader_Selected(sender As MyListItem, e As EventArgs)
SelectedLiteLoader = sender.Tag SelectedLiteLoader = sender.Tag
CardLiteLoader.IsSwaped = True CardLiteLoader.IsSwapped = True
SelectReload() SelectReload()
End Sub End Sub
Private Sub LiteLoader_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnLiteLoaderClear.MouseLeftButtonUp Private Sub LiteLoader_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnLiteLoaderClear.MouseLeftButtonUp
SelectedLiteLoader = Nothing SelectedLiteLoader = Nothing
CardLiteLoader.IsSwaped = True CardLiteLoader.IsSwapped = True
e.Handled = True e.Handled = True
SelectReload() SelectReload()
End Sub End Sub
@@ -866,13 +878,13 @@
''' </summary> ''' </summary>
Private Sub Forge_Loaded() Handles LoadForge.StateChanged Private Sub Forge_Loaded() Handles LoadForge.StateChanged
Try Try
If Not LoadForge.State.IsLoader Then Exit Sub If Not LoadForge.State.IsLoader Then Return
Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = LoadForge.State Dim Loader As LoaderTask(Of String, List(Of DlForgeVersionEntry)) = LoadForge.State
If SelectedMinecraftId <> Loader.Input Then Exit Sub If SelectedMinecraftId <> Loader.Input Then Return
If Loader.State <> LoadState.Finished Then Exit Sub If Loader.State <> LoadState.Finished Then Return
'获取要显示的版本 '获取要显示的版本
Dim Versions = Loader.Output.ToList '复制数组,以免 Output 在实例化后变空 Dim Versions = Loader.Output.ToList '复制数组,以免 Output 在实例化后变空
If Not Loader.Output.Any() Then Exit Sub If Not Loader.Output.Any() Then Return
PanForge.Children.Clear() PanForge.Children.Clear()
Versions = Versions.Where( Versions = Versions.Where(
Function(v) Function(v)
@@ -892,14 +904,14 @@
'选择与清除 '选择与清除
Private Sub Forge_Selected(sender As MyListItem, e As EventArgs) Private Sub Forge_Selected(sender As MyListItem, e As EventArgs)
SelectedForge = sender.Tag SelectedForge = sender.Tag
CardForge.IsSwaped = True CardForge.IsSwapped = True
If SelectedOptiFine IsNot Nothing AndAlso Not IsOptiFineSuitForForge(SelectedOptiFine, SelectedForge) Then SelectedOptiFine = Nothing If SelectedOptiFine IsNot Nothing AndAlso Not IsOptiFineSuitForForge(SelectedOptiFine, SelectedForge) Then SelectedOptiFine = Nothing
OptiFine_Loaded() OptiFine_Loaded()
SelectReload() SelectReload()
End Sub End Sub
Private Sub Forge_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnForgeClear.MouseLeftButtonUp Private Sub Forge_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnForgeClear.MouseLeftButtonUp
SelectedForge = Nothing SelectedForge = Nothing
CardForge.IsSwaped = True CardForge.IsSwapped = True
e.Handled = True e.Handled = True
OptiFine_Loaded() OptiFine_Loaded()
SelectReload() SelectReload()
@@ -936,9 +948,9 @@
Private Sub NeoForge_Loaded() Handles LoadNeoForge.StateChanged Private Sub NeoForge_Loaded() Handles LoadNeoForge.StateChanged
Try Try
'获取版本列表 '获取版本列表
If DlNeoForgeListLoader.State <> LoadState.Finished Then Exit Sub If DlNeoForgeListLoader.State <> LoadState.Finished Then Return
Dim Versions = DlNeoForgeListLoader.Output.Value.Where(Function(v) v.Inherit = SelectedMinecraftId).ToList Dim Versions = DlNeoForgeListLoader.Output.Value.Where(Function(v) v.Inherit = SelectedMinecraftId).ToList
If Not Versions.Any() Then Exit Sub If Not Versions.Any() Then Return
'可视化 '可视化
PanNeoForge.Children.Clear() PanNeoForge.Children.Clear()
NeoForgeDownloadListItemPreload(PanNeoForge, Versions, AddressOf NeoForge_Selected, False) NeoForgeDownloadListItemPreload(PanNeoForge, Versions, AddressOf NeoForge_Selected, False)
@@ -953,13 +965,13 @@
'选择与清除 '选择与清除
Private Sub NeoForge_Selected(sender As MyListItem, e As EventArgs) Private Sub NeoForge_Selected(sender As MyListItem, e As EventArgs)
SelectedNeoForge = sender.Tag SelectedNeoForge = sender.Tag
CardNeoForge.IsSwaped = True CardNeoForge.IsSwapped = True
OptiFine_Loaded() OptiFine_Loaded()
SelectReload() SelectReload()
End Sub End Sub
Private Sub NeoForge_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnNeoForgeClear.MouseLeftButtonUp Private Sub NeoForge_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnNeoForgeClear.MouseLeftButtonUp
SelectedNeoForge = Nothing SelectedNeoForge = Nothing
CardNeoForge.IsSwaped = True CardNeoForge.IsSwapped = True
e.Handled = True e.Handled = True
OptiFine_Loaded() OptiFine_Loaded()
SelectReload() SelectReload()
@@ -975,6 +987,11 @@
Private Function LoadFabricGetError() As String Private Function LoadFabricGetError() As String
If LoadFabric Is Nothing OrElse LoadFabric.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……" If LoadFabric Is Nothing OrElse LoadFabric.State.LoadingState = MyLoading.MyLoadingState.Run Then Return "加载中……"
If LoadFabric.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败:" & CType(LoadFabric.State, Object).Error.Message If LoadFabric.State.LoadingState = MyLoading.MyLoadingState.Error Then Return "获取版本列表失败:" & CType(LoadFabric.State, Object).Error.Message
'检查 OptiFine 1.20.5+:没有 OptiFabric 故全部不兼容
If SelectedOptiFine IsNot Nothing AndAlso
VersionSortInteger(SelectedMinecraftId, "1.20.4") > 0 Then
Return "与 OptiFine 不兼容"
End If
For Each Version As JObject In DlFabricListLoader.Output.Value("game") For Each Version As JObject In DlFabricListLoader.Output.Value("game")
If Version("version").ToString = SelectedMinecraftId.Replace("∞", "infinite").Replace("Combat Test 7c", "1.16_combat-3") Then If Version("version").ToString = SelectedMinecraftId.Replace("∞", "infinite").Replace("Combat Test 7c", "1.16_combat-3") Then
If SelectedForge IsNot Nothing Then Return "与 Forge 不兼容" If SelectedForge IsNot Nothing Then Return "与 Forge 不兼容"
@@ -995,10 +1012,10 @@
''' </summary> ''' </summary>
Private Sub Fabric_Loaded() Handles LoadFabric.StateChanged Private Sub Fabric_Loaded() Handles LoadFabric.StateChanged
Try Try
If DlFabricListLoader.State <> LoadState.Finished Then Exit Sub If DlFabricListLoader.State <> LoadState.Finished Then Return
'获取版本列表 '获取版本列表
Dim Versions As JArray = DlFabricListLoader.Output.Value("loader") Dim Versions As JArray = DlFabricListLoader.Output.Value("loader")
If Not Versions.Any() Then Exit Sub If Not Versions.Any() Then Return
'可视化 '可视化
PanFabric.Children.Clear() PanFabric.Children.Clear()
PanFabric.Tag = Versions PanFabric.Tag = Versions
@@ -1014,7 +1031,7 @@
SelectedFabric = sender.Tag("version").ToString SelectedFabric = sender.Tag("version").ToString
FabricApi_Loaded() FabricApi_Loaded()
OptiFabric_Loaded() OptiFabric_Loaded()
CardFabric.IsSwaped = True CardFabric.IsSwapped = True
SelectReload() SelectReload()
End Sub End Sub
Private Sub Fabric_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnFabricClear.MouseLeftButtonUp Private Sub Fabric_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnFabricClear.MouseLeftButtonUp
@@ -1023,7 +1040,7 @@
AutoSelectedFabricApi = False AutoSelectedFabricApi = False
SelectedOptiFabric = Nothing SelectedOptiFabric = Nothing
AutoSelectedOptiFabric = False AutoSelectedOptiFabric = False
CardFabric.IsSwaped = True CardFabric.IsSwapped = True
e.Handled = True e.Handled = True
SelectReload() SelectReload()
End Sub End Sub
@@ -1100,8 +1117,8 @@
''' </summary> ''' </summary>
Private Sub FabricApi_Loaded() Handles LoadFabricApi.StateChanged Private Sub FabricApi_Loaded() Handles LoadFabricApi.StateChanged
Try Try
If DlFabricApiLoader.State <> LoadState.Finished Then Exit Sub If DlFabricApiLoader.State <> LoadState.Finished Then Return
If SelectedMinecraftId Is Nothing OrElse SelectedFabric Is Nothing Then Exit Sub If SelectedMinecraftId Is Nothing OrElse SelectedFabric Is Nothing Then Return
'获取版本列表 '获取版本列表
Dim Versions As New List(Of CompFile) Dim Versions As New List(Of CompFile)
For Each Version In DlFabricApiLoader.Output For Each Version In DlFabricApiLoader.Output
@@ -1113,7 +1130,7 @@
Versions.Add(Version) Versions.Add(Version)
End If End If
Next Next
If Not Versions.Any() Then Exit Sub If Not Versions.Any() Then Return
Versions = Versions.OrderByDescending(Function(v) v.ReleaseDate).ToList Versions = Versions.OrderByDescending(Function(v) v.ReleaseDate).ToList
'可视化 '可视化
PanFabricApi.Children.Clear() PanFabricApi.Children.Clear()
@@ -1135,12 +1152,12 @@
'选择与清除 '选择与清除
Private Sub FabricApi_Selected(sender As MyListItem, e As EventArgs) Private Sub FabricApi_Selected(sender As MyListItem, e As EventArgs)
SelectedFabricApi = sender.Tag SelectedFabricApi = sender.Tag
CardFabricApi.IsSwaped = True CardFabricApi.IsSwapped = True
SelectReload() SelectReload()
End Sub End Sub
Private Sub FabricApi_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnFabricApiClear.MouseLeftButtonUp Private Sub FabricApi_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnFabricApiClear.MouseLeftButtonUp
SelectedFabricApi = Nothing SelectedFabricApi = Nothing
CardFabricApi.IsSwaped = True CardFabricApi.IsSwapped = True
e.Handled = True e.Handled = True
SelectReload() SelectReload()
End Sub End Sub
@@ -1196,14 +1213,14 @@
''' </summary> ''' </summary>
Private Sub OptiFabric_Loaded() Handles LoadOptiFabric.StateChanged Private Sub OptiFabric_Loaded() Handles LoadOptiFabric.StateChanged
Try Try
If DlOptiFabricLoader.State <> LoadState.Finished Then Exit Sub If DlOptiFabricLoader.State <> LoadState.Finished Then Return
If SelectedMinecraftId Is Nothing OrElse SelectedFabric Is Nothing OrElse SelectedOptiFine Is Nothing Then Exit Sub If SelectedMinecraftId Is Nothing OrElse SelectedFabric Is Nothing OrElse SelectedOptiFine Is Nothing Then Return
'获取版本列表 '获取版本列表
Dim Versions As New List(Of CompFile) Dim Versions As New List(Of CompFile)
For Each Version In DlOptiFabricLoader.Output For Each Version In DlOptiFabricLoader.Output
If IsSuitableOptiFabric(Version, SelectedMinecraftId) Then Versions.Add(Version) If IsSuitableOptiFabric(Version, SelectedMinecraftId) Then Versions.Add(Version)
Next Next
If Not Versions.Any() Then Exit Sub If Not Versions.Any() Then Return
'排序 '排序
Versions = Versions.OrderByDescending(Function(v) v.ReleaseDate).ToList Versions = Versions.OrderByDescending(Function(v) v.ReleaseDate).ToList
'可视化 '可视化
@@ -1227,12 +1244,12 @@
'选择与清除 '选择与清除
Private Sub OptiFabric_Selected(sender As MyListItem, e As EventArgs) Private Sub OptiFabric_Selected(sender As MyListItem, e As EventArgs)
SelectedOptiFabric = sender.Tag SelectedOptiFabric = sender.Tag
CardOptiFabric.IsSwaped = True CardOptiFabric.IsSwapped = True
SelectReload() SelectReload()
End Sub End Sub
Private Sub OptiFabric_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnOptiFabricClear.MouseLeftButtonUp Private Sub OptiFabric_Clear(sender As Object, e As MouseButtonEventArgs) Handles BtnOptiFabricClear.MouseLeftButtonUp
SelectedOptiFabric = Nothing SelectedOptiFabric = Nothing
CardOptiFabric.IsSwaped = True CardOptiFabric.IsSwapped = True
e.Handled = True e.Handled = True
SelectReload() SelectReload()
End Sub End Sub
@@ -1251,7 +1268,7 @@
If MyMsgBox("你尚未开启版本隔离,多个 MC 版本会共用同一个 Mod 文件夹。" & vbCrLf & If MyMsgBox("你尚未开启版本隔离,多个 MC 版本会共用同一个 Mod 文件夹。" & vbCrLf &
"因此,游戏可能会因为读取到与当前版本不符的 Mod 而崩溃。" & vbCrLf & "因此,游戏可能会因为读取到与当前版本不符的 Mod 而崩溃。" & vbCrLf &
"推荐先在 设置 → 启动选项 → 默认版本隔离 中开启版本隔离!", "版本隔离提示", "取消下载", "继续") = 1 Then "推荐先在 设置 → 启动选项 → 默认版本隔离 中开启版本隔离!", "版本隔离提示", "取消下载", "继续") = 1 Then
Exit Sub Return
End If End If
End If End If
'提交安装申请 '提交安装申请
@@ -1269,7 +1286,7 @@
.OptiFabric = SelectedOptiFabric, .OptiFabric = SelectedOptiFabric,
.LiteLoaderEntry = SelectedLiteLoader .LiteLoaderEntry = SelectedLiteLoader
} }
If Not McInstall(Request) Then Exit Sub If Not McInstall(Request) Then Return
'返回,这样在再次进入安装页面时这个版本就会显示文件夹已重复 '返回,这样在再次进入安装页面时这个版本就会显示文件夹已重复
ExitSelectPage() ExitSelectPage()
End Sub End Sub
@@ -65,7 +65,7 @@
''' 切换现有页面。 ''' 切换现有页面。
''' </summary> ''' </summary>
Public Sub PageChange(ID As FormMain.PageSubType) Public Sub PageChange(ID As FormMain.PageSubType)
If PageID = ID Then Exit Sub If PageID = ID Then Return
AniControlEnabled += 1 AniControlEnabled += 1
Try Try
PageChangeRun(PageGet(ID)) PageChangeRun(PageGet(ID))
@@ -187,13 +187,13 @@
'点击返回 '点击返回
Private Sub ItemInstall_Click(sender As Object, e As MouseButtonEventArgs) Handles ItemInstall.Click Private Sub ItemInstall_Click(sender As Object, e As MouseButtonEventArgs) Handles ItemInstall.Click
If Not ItemInstall.Checked Then Exit Sub If Not ItemInstall.Checked Then Return
FrmDownloadInstall.ExitSelectPage() FrmDownloadInstall.ExitSelectPage()
End Sub End Sub
'展开手动安装 '展开手动安装
Private Sub ItemHand_Click(sender As Object, e As RouteEventArgs) Handles ItemHand.Changed Private Sub ItemHand_Click(sender As Object, e As RouteEventArgs) Handles ItemHand.Changed
If ItemHand.Checked = False Then Exit Sub If ItemHand.Checked = False Then Return
e.Handled = True e.Handled = True
AniControlEnabled += 1 AniControlEnabled += 1
If Not Setup.Get("HintHandInstall") Then If Not Setup.Get("HintHandInstall") Then
@@ -202,7 +202,7 @@
"在自动安装页面先选择 MC 版本,然后就可以选择 OptiFine、Forge 等组件,让 PCL 自动进行安装了。", "自动安装提示", "返回自动安装", "继续下载手动安装包") = 1 Then "在自动安装页面先选择 MC 版本,然后就可以选择 OptiFine、Forge 等组件,让 PCL 自动进行安装了。", "自动安装提示", "返回自动安装", "继续下载手动安装包") = 1 Then
FrmMain.PageChange(New FormMain.PageStackData With {.Page = FormMain.PageType.Download}, FormMain.PageSubType.DownloadInstall) FrmMain.PageChange(New FormMain.PageStackData With {.Page = FormMain.PageType.Download}, FormMain.PageSubType.DownloadInstall)
AniControlEnabled -= 1 AniControlEnabled -= 1
Exit Sub Return
End If End If
End If End If
ItemHand.Visibility = Visibility.Collapsed ItemHand.Visibility = Visibility.Collapsed
@@ -34,7 +34,7 @@
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
NewCard.Children.Add(NewStack) NewCard.Children.Add(NewStack)
NewCard.SwapControl = NewStack NewCard.SwapControl = NewStack
NewCard.IsSwaped = True NewCard.IsSwapped = True
PanMain.Children.Add(NewCard) PanMain.Children.Add(NewCard)
Next Next
Catch ex As Exception Catch ex As Exception
@@ -23,7 +23,7 @@
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
NewCard.Children.Add(NewStack) NewCard.Children.Add(NewStack)
NewCard.SwapControl = NewStack NewCard.SwapControl = NewStack
NewCard.IsSwaped = True NewCard.IsSwapped = True
PanMain.Children.Add(NewCard) PanMain.Children.Add(NewCard)
Next Next
Catch ex As Exception Catch ex As Exception
@@ -38,7 +38,7 @@
Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value} Dim NewStack As New StackPanel With {.Margin = New Thickness(20, MyCard.SwapedHeight, 18, 0), .VerticalAlignment = VerticalAlignment.Top, .RenderTransform = New TranslateTransform(0, 0), .Tag = Pair.Value}
NewCard.Children.Add(NewStack) NewCard.Children.Add(NewStack)
NewCard.SwapControl = NewStack NewCard.SwapControl = NewStack
NewCard.IsSwaped = True NewCard.IsSwapped = True
PanMain.Children.Add(NewCard) PanMain.Children.Add(NewCard)
Next Next
Catch ex As Exception Catch ex As Exception
@@ -87,7 +87,7 @@
LabTitle.Text = "登录 Minecraft" LabTitle.Text = "登录 Minecraft"
LabCaption.Text = LabCaption.Text =
$"登录网页将自动开启,请在网页中输入 {UserCode}(已自动复制)。" & vbCrLf & vbCrLf & $"登录网页将自动开启,请在网页中输入 {UserCode}(已自动复制)。" & vbCrLf & vbCrLf &
$"如果网络环境不佳,网页可能一直加载不出来,届时请使用 VPN 并重试。" & vbCrLf & $"如果网络环境不佳,网页可能一直加载不出来,届时请使用加速器或 VPN 以改善网络环境。" & vbCrLf &
$"你也可以用其他设备打开 {Website} 并输入上述代码。" $"你也可以用其他设备打开 {Website} 并输入上述代码。"
Btn1.EventData = Website Btn1.EventData = Website
Btn2.EventData = UserCode Btn2.EventData = UserCode
@@ -97,7 +97,7 @@
Private Sub WorkThread() Private Sub WorkThread()
Thread.Sleep(3000) Thread.Sleep(3000)
If MyConverter.IsExited Then Exit Sub If MyConverter.IsExited Then Return
OpenWebsite(Website) OpenWebsite(Website)
ClipboardSet(UserCode) ClipboardSet(UserCode)
Thread.Sleep((Data("interval").ToObject(Of Integer) - 1) * 1000) Thread.Sleep((Data("interval").ToObject(Of Integer) - 1) * 1000)
@@ -105,13 +105,16 @@
Dim UnknownFailureCount As Integer = 0 Dim UnknownFailureCount As Integer = 0
Do While Not MyConverter.IsExited Do While Not MyConverter.IsExited
Try Try
Dim Result = NetRequestOnce( Dim Result = NetRequestByClient(
"https://login.microsoftonline.com/consumers/oauth2/v2.0/token", "POST", "https://login.microsoftonline.com/consumers/oauth2/v2.0/token", HttpMethod.Post,
"grant_type=urn:ietf:params:oauth:grant-type:device_code" & "&" & Content:=
"client_id=" & OAuthClientId & "&" & "grant_type=urn:ietf:params:oauth:grant-type:device_code" & "&" &
"device_code=" & DeviceCode & "&" & "client_id=" & OAuthClientId & "&" &
"scope=XboxLive.signin%20offline_access", "device_code=" & DeviceCode & "&" &
"application/x-www-form-urlencoded", 5000 + UnknownFailureCount * 5000, MakeLog:=False) "scope=XboxLive.signin%20offline_access",
ContentType:="application/x-www-form-urlencoded",
Timeout:=5000 + UnknownFailureCount * 5000,
MakeLog:=False)
'获取结果 '获取结果
Dim ResultJson As JObject = GetJson(Result) Dim ResultJson As JObject = GetJson(Result)
McLaunchLog($"令牌过期时间:{ResultJson("expires_in")} 秒") McLaunchLog($"令牌过期时间:{ResultJson("expires_in")} 秒")
@@ -119,21 +122,29 @@
Finished({ResultJson("access_token").ToString, ResultJson("refresh_token").ToString}) Finished({ResultJson("access_token").ToString, ResultJson("refresh_token").ToString})
Return Return
Catch ex As Exception Catch ex As Exception
If ex.Message.Contains("authorization_declined") Then If TypeOf ex Is ResponsedWebException Then
Finished(New Exception("$你拒绝了 PCL 申请的权限……")) Dim Response = CType(ex, ResponsedWebException).Response
Return If Response.Contains("authorization_declined") Then
ElseIf ex.Message.Contains("expired_token") Then Finished(New Exception("$你拒绝了 PCL 申请的权限……"))
Finished(New Exception("$登录用时太长啦,重新试试吧!")) Return
Return ElseIf Response.Contains("expired_token") Then
ElseIf ex.Message.Contains("service abuse") Then Finished(New Exception("$登录用时太长啦,重新试试吧!"))
Finished(New Exception("$非常抱歉,该账号已被微软封禁,无法登录。")) Return
Return ElseIf Response.Contains("Account security interrupt") Then
ElseIf ex.Message.Contains("AADSTS70000") Then '可能不能判 “invalid_grant”,见 #269 Finished(New Exception("$该账号由于安全问题无法登陆,请前往微软账户页获取更多信息。"))
Finished(New RestartException) Return
Return ElseIf Response.Contains("service abuse") Then
ElseIf ex.Message.Contains("authorization_pending") Then Finished(New Exception("$非常抱歉,该账号已被微软封禁,无法登录。"))
Thread.Sleep(2000) Return
ElseIf UnknownFailureCount <= 2 Then ElseIf Response.Contains("AADSTS70000") Then '可能不能判 “invalid_grant”,见 #269
Finished(New RestartException)
Return
ElseIf Response.Contains("authorization_pending") Then
Thread.Sleep(2000)
Continue Do
End If
End If
If UnknownFailureCount <= 2 Then
UnknownFailureCount += 1 UnknownFailureCount += 1
Log(ex, $"登录轮询第 {UnknownFailureCount} 次失败") Log(ex, $"登录轮询第 {UnknownFailureCount} 次失败")
Thread.Sleep(2000) Thread.Sleep(2000)
@@ -49,7 +49,7 @@
If Not Loader.State = LoadState.Finished Then If Not Loader.State = LoadState.Finished Then
Hint("皮肤正在获取中,请稍候!", HintType.Critical) Hint("皮肤正在获取中,请稍候!", HintType.Critical)
If Not Loader.State = LoadState.Loading Then Loader.Start() If Not Loader.State = LoadState.Loading Then Loader.Start()
Exit Sub Return
End If End If
Try Try
Dim FileAddress As String = SelectSaveFile("选取保存皮肤的位置", GetFileNameFromPath(Address), "皮肤图片文件(*.png)|*.png") Dim FileAddress As String = SelectSaveFile("选取保存皮肤的位置", GetFileNameFromPath(Address), "皮肤图片文件(*.png)|*.png")
@@ -87,7 +87,7 @@
Catch ex As Exception '#2272 Catch ex As Exception '#2272
Log(ex, $"皮肤文件已损坏:{Address}", LogLevel.Hint) Log(ex, $"皮肤文件已损坏:{Address}", LogLevel.Hint)
File.Delete(Address) File.Delete(Address)
Exit Sub Return
End Try End Try
ImgBack.Tag = Address ImgBack.Tag = Address
'大小检查 '大小检查
@@ -209,11 +209,11 @@
'检查条件,获取新披风 '检查条件,获取新披风
If IsChanging Then If IsChanging Then
Hint("正在更改披风中,请稍候!") Hint("正在更改披风中,请稍候!")
Exit Sub Return
End If End If
If McLoginMsLoader.State = LoadState.Failed Then If McLoginMsLoader.State = LoadState.Failed Then
Hint("登录失败,无法更改披风!", HintType.Critical) Hint("登录失败,无法更改披风!", HintType.Critical)
Exit Sub Return
End If End If
Hint("正在获取披风列表,请稍候……") Hint("正在获取披风列表,请稍候……")
IsChanging = True IsChanging = True
@@ -226,7 +226,7 @@ Retry:
If McLoginMsLoader.State <> LoadState.Finished Then McLoginMsLoader.WaitForExit(PageLoginMsSkin.GetLoginData()) If McLoginMsLoader.State <> LoadState.Finished Then McLoginMsLoader.WaitForExit(PageLoginMsSkin.GetLoginData())
If McLoginMsLoader.State <> LoadState.Finished Then If McLoginMsLoader.State <> LoadState.Finished Then
Hint("登录失败,无法更改披风!", HintType.Critical) Hint("登录失败,无法更改披风!", HintType.Critical)
Exit Sub Return
End If End If
Dim AccessToken As String = McLoginMsLoader.Output.AccessToken Dim AccessToken As String = McLoginMsLoader.Output.AccessToken
Dim Uuid As String = McLoginMsLoader.Output.Uuid Dim Uuid As String = McLoginMsLoader.Output.Uuid
@@ -243,7 +243,8 @@ Retry:
{"Minecon2013", "Minecon 2013 参与者披风"}, {"Minecon2015", "Minecon 2015 参与者披风"}, {"Minecon2016", "Minecon 2016 参与者披风"}, {"Minecon2013", "Minecon 2013 参与者披风"}, {"Minecon2015", "Minecon 2015 参与者披风"}, {"Minecon2016", "Minecon 2016 参与者披风"},
{"Cherry Blossom", "樱花披风"}, {"15th Anniversary", "15 周年纪念披风"}, {"Purple Heart", "紫色心形披风"}, {"Cherry Blossom", "樱花披风"}, {"15th Anniversary", "15 周年纪念披风"}, {"Purple Heart", "紫色心形披风"},
{"Follower's", "追随者披风"}, {"MCC 15th Year", "MCC 15 周年披风"}, {"Minecraft Experience", "村民救援披风"}, {"Follower's", "追随者披风"}, {"MCC 15th Year", "MCC 15 周年披风"}, {"Minecraft Experience", "村民救援披风"},
{"Mojang Office", "Mojang 办公室披风"}, {"Home", "家园披风"}, {"Menace", "入侵披风"}, {"Yearn", "渴望披风"} {"Mojang Office", "Mojang 办公室披风"}, {"Home", "家园披风"}, {"Menace", "入侵披风"}, {"Yearn", "渴望披风"},
{"Common", "普通披风"}, {"Pan", "薄煎饼披风"}, {"Founder's", "创始人披风"}
} }
Dim SelectionControl As New List(Of IMyRadio) From {New MyRadioBox With {.Text = "无披风"}} Dim SelectionControl As New List(Of IMyRadio) From {New MyRadioBox With {.Text = "无披风"}}
For Each Cape In SkinData("capes") For Each Cape In SkinData("capes")
@@ -256,15 +257,16 @@ Retry:
Log(ex, "获取玩家皮肤列表失败", LogLevel.Feedback) Log(ex, "获取玩家皮肤列表失败", LogLevel.Feedback)
End Try End Try
End Sub) End Sub)
If SelId Is Nothing Then Exit Sub If SelId Is Nothing Then Return
'发送请求 '发送请求
Dim Result As String = NetRequestRetry("https://api.minecraftservices.com/minecraft/profile/capes/active", Dim Result As String = NetRequestByClientRetry("https://api.minecraftservices.com/minecraft/profile/capes/active",
If(SelId = 0, "DELETE", "PUT"), If(SelId = 0, HttpMethod.Delete, HttpMethod.Put),
If(SelId = 0, "", New JObject(New JProperty("capeId", SkinData("capes")(SelId - 1)("id"))).ToString(0)), Content:=If(SelId = 0, "", New JObject(New JProperty("capeId", SkinData("capes")(SelId - 1)("id"))).ToString(0)),
"application/json", Headers:=New Dictionary(Of String, String) From {{"Authorization", "Bearer " & AccessToken}}) ContentType:="application/json",
Headers:={{"Authorization", "Bearer " & AccessToken}})
If Result.Contains("""errorMessage""") Then If Result.Contains("""errorMessage""") Then
Hint("更改披风失败:" & GetJson(Result)("errorMessage"), HintType.Critical) Hint("更改披风失败:" & GetJson(Result)("errorMessage").ToString, HintType.Critical)
Exit Sub Return
Else Else
Hint("更改披风成功!", HintType.Finish) Hint("更改披风成功!", HintType.Finish)
End If End If
@@ -9,7 +9,7 @@
AprilPosTrans.X = 0 AprilPosTrans.X = 0
AprilPosTrans.Y = 0 AprilPosTrans.Y = 0
If IsLoad Then Exit Sub If IsLoad Then Return
IsLoad = True IsLoad = True
AniControlEnabled += 1 AniControlEnabled += 1
@@ -243,19 +243,21 @@
If Not IsNothing(PageNew) AndAlso Not IsNothing(PageNew.Parent) Then PageNew.SetValue(ContentPresenter.ContentProperty, Nothing) If Not IsNothing(PageNew) AndAlso Not IsNothing(PageNew.Parent) Then PageNew.SetValue(ContentPresenter.ContentProperty, Nothing)
If Anim Then If Anim Then
'动画 '动画
Dispatcher.Invoke(Sub() Dispatcher.Invoke(
'执行动画 Sub()
AniStart({ '执行动画
AaOpacity(PanLogin, -PanLogin.Opacity, 100,, New AniEaseOutFluent), AniStart({
AaCode(Sub() AaOpacity(PanLogin, -PanLogin.Opacity, 100,, New AniEaseOutFluent),
AniControlEnabled += 1 AaCode(
PanLogin.Children.Clear() Sub()
PanLogin.Children.Add(PageNew) AniControlEnabled += 1
AniControlEnabled -= 1 PanLogin.Children.Clear()
End Sub, 100), PanLogin.Children.Add(PageNew)
AaOpacity(PanLogin, 1, 100, 120, New AniEaseInFluent) AniControlEnabled -= 1
}, "FrmLogin PageChange") End Sub, 100),
End Sub, Threading.DispatcherPriority.Render) AaOpacity(PanLogin, 1, 100, 120, New AniEaseInFluent)
}, "FrmLogin PageChange")
End Sub, Threading.DispatcherPriority.Render)
Else Else
'无动画 '无动画
AniControlEnabled += 1 AniControlEnabled += 1
@@ -353,7 +355,7 @@ UnknownType:
GoTo UnknownType GoTo UnknownType
End Select End Select
'刷新页面 '刷新页面
If PageCurrent = Type Then Exit Sub If PageCurrent = Type Then Return
PageChange(Type, Anim).Reload(KeepInput) PageChange(Type, Anim).Reload(KeepInput)
Dim Control As MyRadioButton = FindName("RadioLoginType" & Setup.Get("LoginType")) Dim Control As MyRadioButton = FindName("RadioLoginType" & Setup.Get("LoginType"))
If Control IsNot Nothing Then Control.Checked = True If Control IsNot Nothing Then Control.Checked = True
@@ -393,7 +395,7 @@ UnknownType:
Catch ex As Exception Catch ex As Exception
If ex.GetType.Name = "ThreadInterruptedException" Then If ex.GetType.Name = "ThreadInterruptedException" Then
Data.Output = "" Data.Output = ""
Exit Sub Return
ElseIf GetExceptionSummary(ex).Contains("429") Then ElseIf GetExceptionSummary(ex).Contains("429") Then
Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(UserName)) & ".png" Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(UserName)) & ".png"
Log("[Minecraft] 获取正版皮肤失败(" & UserName & "):获取皮肤太过频繁,请 5 分钟后再试!", LogLevel.Hint) Log("[Minecraft] 获取正版皮肤失败(" & UserName & "):获取皮肤太过频繁,请 5 分钟后再试!", LogLevel.Hint)
@@ -463,7 +465,7 @@ UseDefault:
Catch ex As Exception Catch ex As Exception
If ex.GetType.Name = "ThreadInterruptedException" Then If ex.GetType.Name = "ThreadInterruptedException" Then
Data.Output = "" Data.Output = ""
Exit Sub Return
ElseIf GetExceptionSummary(ex).Contains("429") Then ElseIf GetExceptionSummary(ex).Contains("429") Then
Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(ID)) & ".png" Data.Output = PathImage & "Skins/" & McSkinSex(McLoginLegacyUuid(ID)) & ".png"
Log("获取离线登录使用的正版皮肤失败(" & ID & "):获取皮肤太过频繁,请 5 分钟后再试!") Log("获取离线登录使用的正版皮肤失败(" & ID & "):获取皮肤太过频繁,请 5 分钟后再试!")
@@ -515,7 +517,7 @@ UseDefault:
Catch ex As Exception Catch ex As Exception
If ex.GetType.Name = "ThreadInterruptedException" Then If ex.GetType.Name = "ThreadInterruptedException" Then
Data.Output = "" Data.Output = ""
Exit Sub Return
ElseIf GetExceptionSummary(ex).Contains("429") Then ElseIf GetExceptionSummary(ex).Contains("429") Then
Data.Output = PathImage & "Skins/Steve.png" Data.Output = PathImage & "Skins/Steve.png"
Log("[Minecraft] 获取统一通行证皮肤失败(" & UserName & "):获取皮肤太过频繁,请 5 分钟后再试!", LogLevel.Hint) Log("[Minecraft] 获取统一通行证皮肤失败(" & UserName & "):获取皮肤太过频繁,请 5 分钟后再试!", LogLevel.Hint)
@@ -563,7 +565,7 @@ Finish:
Catch ex As Exception Catch ex As Exception
If ex.GetType.Name = "ThreadInterruptedException" Then If ex.GetType.Name = "ThreadInterruptedException" Then
Data.Output = "" Data.Output = ""
Exit Sub Return
ElseIf GetExceptionSummary(ex).Contains("429") Then ElseIf GetExceptionSummary(ex).Contains("429") Then
Data.Output = PathImage & "Skins/Steve.png" Data.Output = PathImage & "Skins/Steve.png"
Log("[Minecraft] 获取 Authlib-Injector 皮肤失败(" & UserName & "):获取皮肤太过频繁,请 5 分钟后再试!", LogLevel.Hint) Log("[Minecraft] 获取 Authlib-Injector 皮肤失败(" & UserName & "):获取皮肤太过频繁,请 5 分钟后再试!", LogLevel.Hint)
@@ -592,13 +594,13 @@ Finish:
'版本选择按钮 '版本选择按钮
Private Sub BtnVersion_Click(sender As Object, e As EventArgs) Handles BtnVersion.Click Private Sub BtnVersion_Click(sender As Object, e As EventArgs) Handles BtnVersion.Click
If McLaunchLoader.State = LoadState.Loading Then Exit Sub If McLaunchLoader.State = LoadState.Loading Then Return
FrmMain.PageChange(FormMain.PageType.VersionSelect) FrmMain.PageChange(FormMain.PageType.VersionSelect)
End Sub End Sub
'启动按钮 '启动按钮
Public Sub LaunchButtonClick() Handles BtnLaunch.Click Public Sub LaunchButtonClick() Handles BtnLaunch.Click
If McLaunchLoader.State = LoadState.Loading OrElse Not BtnLaunch.IsEnabled OrElse If McLaunchLoader.State = LoadState.Loading OrElse Not BtnLaunch.IsEnabled OrElse
(FrmMain.PageRight IsNot Nothing AndAlso FrmMain.PageRight.PageState <> MyPageRight.PageStates.ContentStay AndAlso FrmMain.PageRight.PageState <> MyPageRight.PageStates.ContentEnter) Then Exit Sub (FrmMain.PageRight IsNot Nothing AndAlso FrmMain.PageRight.PageState <> MyPageRight.PageStates.ContentStay AndAlso FrmMain.PageRight.PageState <> MyPageRight.PageStates.ContentEnter) Then Return
'愚人节处理 '愚人节处理
If IsAprilEnabled AndAlso Not IsAprilGiveup Then If IsAprilEnabled AndAlso Not IsAprilGiveup Then
ThemeUnlock(12, False, "隐藏主题 滑稽彩 已解锁!") ThemeUnlock(12, False, "隐藏主题 滑稽彩 已解锁!")
@@ -619,7 +621,7 @@ Finish:
Private BtnLaunchState As Integer = 0 Private BtnLaunchState As Integer = 0
Private BtnLaunchVersion As McVersion = Nothing Private BtnLaunchVersion As McVersion = Nothing
Public Sub RefreshButtonsUI() Handles BtnLaunch.Loaded Public Sub RefreshButtonsUI() Handles BtnLaunch.Loaded
If Not BtnLaunch.IsLoaded Then Exit Sub If Not BtnLaunch.IsLoaded Then Return
'获取当前状态 '获取当前状态
Dim CurrentState As Integer Dim CurrentState As Integer
If (Not IsLoadFinished) OrElse McVersionListLoader.State = LoadState.Loading OrElse McFolderListLoader.State = LoadState.Loading Then If (Not IsLoadFinished) OrElse McVersionListLoader.State = LoadState.Loading OrElse McFolderListLoader.State = LoadState.Loading Then
@@ -695,7 +697,7 @@ ExitRefresh:
End Sub End Sub
'版本设置按钮 '版本设置按钮
Private Sub BtnMore_Click(sender As Object, e As EventArgs) Handles BtnMore.Click Private Sub BtnMore_Click(sender As Object, e As EventArgs) Handles BtnMore.Click
If McLaunchLoader.State = LoadState.Loading Then Exit Sub If McLaunchLoader.State = LoadState.Loading Then Return
McVersionCurrent.Load() McVersionCurrent.Load()
PageVersionLeft.Version = McVersionCurrent PageVersionLeft.Version = McVersionCurrent
FrmMain.PageChange(FormMain.PageType.VersionSetup, 0) FrmMain.PageChange(FormMain.PageType.VersionSetup, 0)
@@ -705,7 +707,7 @@ ExitRefresh:
''' </summary> ''' </summary>
Public Sub LaunchingRefresh() Public Sub LaunchingRefresh()
Try Try
If McLaunchLoaderReal.State = LoadState.Aborted Then Exit Sub If McLaunchLoaderReal.State = LoadState.Aborted Then Return
'阶段状态获取 '阶段状态获取
Dim IsLaunched As Boolean = False '是否已经启动游戏,只是在等待窗口 Dim IsLaunched As Boolean = False '是否已经启动游戏,只是在等待窗口
Try Try
@@ -719,7 +721,7 @@ ExitRefresh:
LabLaunchingStage.Text = "已完成" LabLaunchingStage.Text = "已完成"
Catch ex As Exception Catch ex As Exception
Log(ex, "获取是否启动完成失败,可能是由于启动状态改变导致集合已修改") Log(ex, "获取是否启动完成失败,可能是由于启动状态改变导致集合已修改")
Exit Sub Return
End Try End Try
If AniIsRun("Launch State Page") Then IsLaunched = False '等待页面切换动画完成 If AniIsRun("Launch State Page") Then IsLaunched = False '等待页面切换动画完成
'计算应显示的进度 '计算应显示的进度
@@ -789,7 +791,7 @@ ExitRefresh:
Private ActualUsedWidth As Double Private ActualUsedWidth As Double
Private Sub PanLaunchingInfo_SizeChangedW(sender As Object, e As SizeChangedEventArgs) Handles PanLaunchingInfo.SizeChanged Private Sub PanLaunchingInfo_SizeChangedW(sender As Object, e As SizeChangedEventArgs) Handles PanLaunchingInfo.SizeChanged
Dim DeltaWidth As Double = e.NewSize.Width - e.PreviousSize.Width Dim DeltaWidth As Double = e.NewSize.Width - e.PreviousSize.Width
If e.PreviousSize.Width = 0 OrElse IsWidthAnimating OrElse Math.Abs(DeltaWidth) < 1 OrElse PanLaunchingInfo.ActualWidth = 0 Then Exit Sub If e.PreviousSize.Width = 0 OrElse IsWidthAnimating OrElse Math.Abs(DeltaWidth) < 1 OrElse PanLaunchingInfo.ActualWidth = 0 Then Return
AniStart({ AniStart({
AaWidth(PanLaunchingInfo, DeltaWidth, 180,, New AniEaseOutFluent), AaWidth(PanLaunchingInfo, DeltaWidth, 180,, New AniEaseOutFluent),
AaCode(Sub() AaCode(Sub()
@@ -805,7 +807,7 @@ ExitRefresh:
Private ActualUsedHeight As Double Private ActualUsedHeight As Double
Private Sub PanLaunchingInfo_SizeChangedH(sender As Object, e As SizeChangedEventArgs) Handles PanLaunchingInfo.SizeChanged Private Sub PanLaunchingInfo_SizeChangedH(sender As Object, e As SizeChangedEventArgs) Handles PanLaunchingInfo.SizeChanged
Dim DeltaHeight As Double = e.NewSize.Height - e.PreviousSize.Height Dim DeltaHeight As Double = e.NewSize.Height - e.PreviousSize.Height
If e.PreviousSize.Height = 0 OrElse IsHeightAnimating OrElse Math.Abs(DeltaHeight) < 1 OrElse PanLaunchingInfo.ActualHeight = 0 Then Exit Sub If e.PreviousSize.Height = 0 OrElse IsHeightAnimating OrElse Math.Abs(DeltaHeight) < 1 OrElse PanLaunchingInfo.ActualHeight = 0 Then Return
AniStart({ AniStart({
AaHeight(PanLaunchingInfo, DeltaHeight, 180,, New AniEaseOutFluent), AaHeight(PanLaunchingInfo, DeltaHeight, 180,, New AniEaseOutFluent),
AaCode(Sub() AaCode(Sub()
@@ -65,7 +65,7 @@ Download:
RunInUiWait(Sub() LoadContent("")) '在加载结束前清空页面 RunInUiWait(Sub() LoadContent("")) '在加载结束前清空页面
Setup.Set("CacheSavedPageVersion", "") Setup.Set("CacheSavedPageVersion", "")
OnlineLoader.Start(Url) '下载完成后将会再次触发更新 OnlineLoader.Start(Url) '下载完成后将会再次触发更新
Exit Sub Return
End If End If
Case 3 Case 3
Select Case Setup.Get("UiCustomPreset") Select Case Setup.Get("UiCustomPreset")
@@ -89,11 +89,11 @@ Download:
</local:MyCard>" </local:MyCard>"
Case 2 Case 2
Log("[Page] 主页预设:Minecraft 新闻") Log("[Page] 主页预设:Minecraft 新闻")
Url = "http://pcl.mcnews.thestack.top" Url = "https://pcl.mcnews.thestack.top"
GoTo Download GoTo Download
Case 3 Case 3
Log("[Page] 主页预设:简单主页") Log("[Page] 主页预设:简单主页")
Url = "https://raw.gitcode.com/mfn233/PCL-Mainpage/raw/main/Custom.xaml" Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/MFn233/Custom.xaml"
GoTo Download GoTo Download
Case 4 Case 4
Log("[Page] 主页预设:每日整合包推荐") Log("[Page] 主页预设:每日整合包推荐")
@@ -127,6 +127,10 @@ Download:
Log("[Page] 主页预设:杂志主页") Log("[Page] 主页预设:杂志主页")
Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/Ext1nguisher/Custom.xaml" Url = "https://pclhomeplazaoss.lingyunawa.top:26994/d/Homepages/Ext1nguisher/Custom.xaml"
GoTo Download GoTo Download
Case 12
Log("[Page] 主页预设:PCL GitHub 仪表盘")
Url = "https://ddf.pcl-community.org/Custom.xaml"
GoTo Download
End Select End Select
End Select End Select
RunInUi(Sub() LoadContent(Content)) RunInUi(Sub() LoadContent(Content))
@@ -146,13 +150,13 @@ Download:
VersionAddress = Address.BeforeFirst("?") VersionAddress = Address.BeforeFirst("?")
If Not VersionAddress.EndsWith("/") Then VersionAddress += "/" If Not VersionAddress.EndsWith("/") Then VersionAddress += "/"
VersionAddress += "version" VersionAddress += "version"
If Address.Contains("?") Then VersionAddress += Address.AfterLast("?") If Address.Contains("?") Then VersionAddress += "?" & Address.AfterFirst("?")
End If End If
'校验版本 '校验版本
Dim Version As String = "" Dim Version As String = ""
Dim NeedDownload As Boolean = True Dim NeedDownload As Boolean = True
Try Try
Version = NetGetCodeByRequestOnce(VersionAddress, Timeout:=10000) Version = NetRequestByClientRetry(VersionAddress)
If Version.Length > 1000 Then Throw New Exception($"获取的主页版本过长({Version.Length} 字符)") If Version.Length > 1000 Then Throw New Exception($"获取的主页版本过长({Version.Length} 字符)")
Dim CurrentVersion As String = Setup.Get("CacheSavedPageVersion") Dim CurrentVersion As String = Setup.Get("CacheSavedPageVersion")
If Version <> "" AndAlso CurrentVersion <> "" AndAlso Version = CurrentVersion Then If Version <> "" AndAlso CurrentVersion <> "" AndAlso Version = CurrentVersion Then
@@ -167,14 +171,14 @@ Download:
End Try End Try
'实际下载 '实际下载
If NeedDownload Then If NeedDownload Then
Dim FileContent As String = NetGetCodeByRequestRetry(Address) Dim FileContent As String = NetRequestByClientRetry(Address)
Log($"[Page] 已联网下载主页,内容长度:{FileContent.Length},来源:{Address}") Log($"[Page] 已联网下载主页,内容长度:{FileContent.Length},来源:{Address}")
Setup.Set("CacheSavedPageUrl", Address) Setup.Set("CacheSavedPageUrl", Address)
Setup.Set("CacheSavedPageVersion", Version) Setup.Set("CacheSavedPageVersion", Version)
WriteFile(PathTemp & "Cache\Custom.xaml", FileContent) WriteFile(PathTemp & "Cache\Custom.xaml", FileContent)
End If End If
'要求刷新 '要求刷新
Refresh() RunInUi(AddressOf Refresh) '不直接调用 Refresh,以防止死循环(#6245)
Catch ex As Exception Catch ex As Exception
Log(ex, $"下载主页失败({Address})", If(ModeDebug, LogLevel.Msgbox, LogLevel.Hint)) Log(ex, $"下载主页失败({Address})", If(ModeDebug, LogLevel.Msgbox, LogLevel.Hint))
End Try End Try
@@ -215,7 +219,7 @@ Download:
SyncLock LoadContentLock SyncLock LoadContentLock
'如果加载目标内容一致则不加载 '如果加载目标内容一致则不加载
Dim Hash = Content.GetHashCode() Dim Hash = Content.GetHashCode()
If Hash = LoadedContentHash Then Exit Sub If Hash = LoadedContentHash Then Return
LoadedContentHash = Hash LoadedContentHash = Hash
'实际加载内容 '实际加载内容
PanCustom.Children.Clear() PanCustom.Children.Clear()
@@ -223,10 +227,13 @@ Download:
Log($"[Page] 实例化:清空主页 UI,来源为空") Log($"[Page] 实例化:清空主页 UI,来源为空")
Return Return
End If End If
Dim LoadStartTime As Date = Date.Now
Try Try
'修改时应同时修改 PageOtherHelpDetail.Init '修改时应同时修改 PageOtherHelpDetail.Init
Content = HelpArgumentReplace(Content) Content = HelpArgumentReplace(Content)
If Content.Contains("xmlns") Then Content = Content.RegexReplace("xmlns[^""']*(""|')[^""']*(""|')", "").Replace("xmlns", "") '禁止声明命名空间 Do While Content.Contains("xmlns")
Content = Content.RegexReplace("xmlns[^""']*(""|')[^""']*(""|')", "").Replace("xmlns", "") '禁止声明命名空间
Loop
Content = "<StackPanel xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation"" xmlns:sys=""clr-namespace:System;assembly=mscorlib"" xmlns:x=""http://schemas.microsoft.com/winfx/2006/xaml"" xmlns:local=""clr-namespace:PCL;assembly=Plain Craft Launcher 2"">" & Content & "</StackPanel>" Content = "<StackPanel xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation"" xmlns:sys=""clr-namespace:System;assembly=mscorlib"" xmlns:x=""http://schemas.microsoft.com/winfx/2006/xaml"" xmlns:local=""clr-namespace:PCL;assembly=Plain Craft Launcher 2"">" & Content & "</StackPanel>"
Log($"[Page] 实例化:加载主页 UI 开始,最终内容长度:{Content.Count}") Log($"[Page] 实例化:加载主页 UI 开始,最终内容长度:{Content.Count}")
PanCustom.Children.Add(GetObjectFromXML(Content)) PanCustom.Children.Add(GetObjectFromXML(Content))
@@ -240,8 +247,11 @@ Download:
Else Else
Log(ex, "加载主页界面失败", LogLevel.Hint) Log(ex, "加载主页界面失败", LogLevel.Hint)
End If End If
Return
End Try End Try
Log($"[Page] 实例化:加载主页 UI 完成") Dim LoadCostTime = (Date.Now - LoadStartTime).Milliseconds
Log($"[Page] 实例化:加载主页 UI 完成,耗时 {LoadCostTime}ms")
If LoadCostTime > 3000 Then Hint($"主页加载过于缓慢(花费了 {Math.Round(LoadCostTime / 1000, 1)} 秒),请向主页作者反馈此问题,或暂时停止使用该主页")
End SyncLock End SyncLock
Return Return
Refresh: Refresh:
@@ -49,11 +49,10 @@
Log("[Launch] 要求更换角色,但登录加载器繁忙", LogLevel.Debug) Log("[Launch] 要求更换角色,但登录加载器繁忙", LogLevel.Debug)
If CType(McLoginLoader.Input, McLoginServer).ForceReselectProfile Then If CType(McLoginLoader.Input, McLoginServer).ForceReselectProfile Then
Hint("正在尝试更换,请稍候!") Hint("正在尝试更换,请稍候!")
Exit Sub
Else Else
Hint("正在登录中,请稍后再更换角色!", HintType.Critical) Hint("正在登录中,请稍后再更换角色!", HintType.Critical)
Exit Sub
End If End If
Return
End If End If
Hint("正在尝试更换,请稍候!") Hint("正在尝试更换,请稍候!")
Setup.Set("CacheAuthUuid", "") '清空选择缓存 Setup.Set("CacheAuthUuid", "") '清空选择缓存
@@ -5,8 +5,8 @@
xmlns:d="http://schemas.microsoft.com/expression/blend/2008" xmlns:d="http://schemas.microsoft.com/expression/blend/2008"
xmlns:local="clr-namespace:PCL" xmlns:local="clr-namespace:PCL"
mc:Ignorable="d" d:DesignWidth="297.6"> mc:Ignorable="d" d:DesignWidth="297.6">
<StackPanel Margin="0,0,0,5"> <StackPanel Margin="0,0,0,5" x:Name="PanMain">
<local:MyHint x:Name="HintChinese" Text="玩家名如果包含英文、数字、下划线以外的内容,可能会无法进入 Minecraft 1.18 以后的世界!" Margin="0,0,0,15" Visibility="Collapsed" /> <local:MyHint x:Name="HintChinese" Theme="Red" Text="玩家名如果包含英文、数字、下划线以外的内容,可能会无法进入 Minecraft 1.18 以后的世界!" Margin="0,0,0,15" Visibility="Collapsed" />
<local:MySkin HorizontalAlignment="Center" x:Name="Skin" HasCape="False" Margin="0,0,0,15" /> <local:MySkin HorizontalAlignment="Center" x:Name="Skin" HasCape="False" Margin="0,0,0,15" />
<local:MyComboBox IsEditable="True" x:Name="ComboName" Height="28" IsTextSearchEnabled="False" HintText="游戏用户名" /> <local:MyComboBox IsEditable="True" x:Name="ComboName" Height="28" IsTextSearchEnabled="False" HintText="游戏用户名" />
</StackPanel> </StackPanel>
@@ -64,6 +64,7 @@ Public Class PageLoginLegacy
Private Sub ComboLegacy_TextChanged(sender As Object, e As TextChangedEventArgs) Handles ComboName.TextChanged Private Sub ComboLegacy_TextChanged(sender As Object, e As TextChangedEventArgs) Handles ComboName.TextChanged
If Setup.Get("LaunchSkinType") = 0 Then PageLaunchLeft.SkinLegacy.Start(IsForceRestart:=True) If Setup.Get("LaunchSkinType") = 0 Then PageLaunchLeft.SkinLegacy.Start(IsForceRestart:=True)
HintChinese.Visibility = If(RegexCheck(ComboName.Text, "^[0-9A-Za-z_]*$"), Visibility.Collapsed, Visibility.Visible) HintChinese.Visibility = If(RegexCheck(ComboName.Text, "^[0-9A-Za-z_]*$"), Visibility.Collapsed, Visibility.Visible)
RunInUi(Sub() PanMain.InvalidateMeasure(), True) '由于 WPF 的 Bug,它不一定会自动更新 HintChinese 的大小(#6627)
End Sub End Sub
Private Sub Skin_Click() Handles Skin.Click Private Sub Skin_Click() Handles Skin.Click
If (Setup.Get("UiHiddenPageSetup") OrElse Setup.Get("UiHiddenSetupLaunch")) AndAlso Not PageSetupUI.HiddenForceShow Then If (Setup.Get("UiHiddenPageSetup") OrElse Setup.Get("UiHiddenSetupLaunch")) AndAlso Not PageSetupUI.HiddenForceShow Then
@@ -25,7 +25,7 @@
ComboAccounts.SelectedIndex = If(KeepInput, Math.Max(0, IndexBefore), 0) ComboAccounts.SelectedIndex = If(KeepInput, Math.Max(0, IndexBefore), 0)
End Sub End Sub
Private Sub ComboAccounts_SelectionChanged(sender As Object, e As SelectionChangedEventArgs) Handles ComboAccounts.SelectionChanged Private Sub ComboAccounts_SelectionChanged(sender As Object, e As SelectionChangedEventArgs) Handles ComboAccounts.SelectionChanged
If AniControlEnabled <> 0 OrElse ComboAccounts.SelectedItem Is Nothing OrElse ComboAccounts.ContentPresenter Is Nothing Then Exit Sub If AniControlEnabled <> 0 OrElse ComboAccounts.SelectedItem Is Nothing OrElse ComboAccounts.ContentPresenter Is Nothing Then Return
If TypeOf ComboAccounts.SelectedItem Is MyListItem Then If TypeOf ComboAccounts.SelectedItem Is MyListItem Then
ComboAccounts.ContentPresenter.Content = CType(ComboAccounts.SelectedItem, MyListItem).Title ComboAccounts.ContentPresenter.Content = CType(ComboAccounts.SelectedItem, MyListItem).Title
ElseIf TypeOf ComboAccounts.SelectedItem Is MyComboBoxItem Then ElseIf TypeOf ComboAccounts.SelectedItem Is MyComboBoxItem Then
@@ -23,10 +23,11 @@
<local:MyIconButton.ContextMenu> <local:MyIconButton.ContextMenu>
<ContextMenu Closed="HidePanel" HorizontalOffset="10" VerticalOffset="18"> <ContextMenu Closed="HidePanel" HorizontalOffset="10" VerticalOffset="18">
<local:MyMenuItem Click="BtnSkinEdit_Click" Header="修改皮肤"/> <local:MyMenuItem Click="BtnSkinEdit_Click" Header="修改皮肤"/>
<local:MyMenuItem Click="BtnSkinSave_Click" Header="保存皮肤"/> <local:MyMenuItem Click="BtnSkinSave_Click" Header="保存皮肤文件"/>
<local:MyMenuItem Click="BtnSkinRefresh_Click" Header="刷新头像"/>
<Separator /> <Separator />
<local:MyMenuItem Click="BtnSkinCape_Click" Header="修改披风"/> <local:MyMenuItem Click="BtnSkinCape_Click" Header="修改披风"/>
<Separator />
<local:MyMenuItem Click="BtnSkinRefresh_Click" Header="刷新"/>
</ContextMenu> </ContextMenu>
</local:MyIconButton.ContextMenu> </local:MyIconButton.ContextMenu>
</local:MyIconButton> </local:MyIconButton>
@@ -33,7 +33,7 @@
AniStart(AaOpacity(PanButtons, 1 - PanButtons.Opacity, 120), "PageLoginMsSkin Button") AniStart(AaOpacity(PanButtons, 1 - PanButtons.Opacity, 120), "PageLoginMsSkin Button")
End Sub End Sub
Public Sub HidePanel() Handles PanData.MouseLeave Public Sub HidePanel() Handles PanData.MouseLeave
If BtnEdit.ContextMenu.IsOpen OrElse BtnSkin.ContextMenu.IsOpen OrElse PanData.IsMouseOver Then Exit Sub If BtnEdit.ContextMenu.IsOpen OrElse BtnSkin.ContextMenu.IsOpen OrElse PanData.IsMouseOver Then Return
AniStart(AaOpacity(PanButtons, -PanButtons.Opacity, 120), "PageLoginMsSkin Button") AniStart(AaOpacity(PanButtons, -PanButtons.Opacity, 120), "PageLoginMsSkin Button")
End Sub End Sub
@@ -74,14 +74,14 @@
'检查条件,获取新皮肤 '检查条件,获取新皮肤
If IsChanging Then If IsChanging Then
Hint("正在更改皮肤中,请稍候!") Hint("正在更改皮肤中,请稍候!")
Exit Sub Return
End If End If
If McLoginLoader.State = LoadState.Failed Then If McLoginLoader.State = LoadState.Failed Then
Hint("登录失败,无法更改皮肤!", HintType.Critical) Hint("登录失败,无法更改皮肤!", HintType.Critical)
Exit Sub Return
End If End If
Dim SkinInfo As McSkinInfo = McSkinSelect() Dim SkinInfo As McSkinInfo = McSkinSelect()
If Not SkinInfo.IsVaild Then Exit Sub If Not SkinInfo.IsVaild Then Return
Hint("正在更改皮肤……") Hint("正在更改皮肤……")
IsChanging = True IsChanging = True
'开始实际获取 '开始实际获取
@@ -107,8 +107,8 @@ Retry:
McLoginMsLoader.Start(GetLoginData(), IsForceRestart:=True) McLoginMsLoader.Start(GetLoginData(), IsForceRestart:=True)
GoTo Retry GoTo Retry
ElseIf Result.Contains("""error""") Then ElseIf Result.Contains("""error""") Then
Hint("更改皮肤失败:" & GetJson(Result)("error"), HintType.Critical) Hint("更改皮肤失败:" & GetJson(Result)("error").ToString, HintType.Critical)
Exit Sub Return
End If End If
'获取新皮肤地址 '获取新皮肤地址
Log("[Skin] 皮肤修改返回值:" & vbCrLf & Result) Log("[Skin] 皮肤修改返回值:" & vbCrLf & Result)
@@ -117,7 +117,7 @@ Retry:
For Each Skin As JObject In ResultJson("skins") For Each Skin As JObject In ResultJson("skins")
If Skin("state").ToString = "ACTIVE" Then If Skin("state").ToString = "ACTIVE" Then
MySkin.ReloadCache(Skin("url")) MySkin.ReloadCache(Skin("url"))
Exit Sub Return
End If End If
Next Next
Throw New Exception("未知错误(" & Result & ")") Throw New Exception("未知错误(" & Result & ")")
@@ -103,7 +103,6 @@
<RowDefinition Height="Auto" /> <RowDefinition Height="Auto" />
<RowDefinition Height="1*" /> <RowDefinition Height="1*" />
</Grid.RowDefinitions> </Grid.RowDefinitions>
<!--<local:MyHint IsWarn="True" Text="这是错误文本。" x:Name="HintTypeError" Visibility="Collapsed" Grid.ColumnSpan="5" Grid.RowSpan="5" Margin="15,15,15,0" VerticalAlignment="Top" />-->
<local:MyCard x:Name="BtnSelectCreate" Grid.Column="1" Grid.Row="1"> <local:MyCard x:Name="BtnSelectCreate" Grid.Column="1" Grid.Row="1">
<Grid Margin="35,0,25,0" IsHitTestVisible="False"> <Grid Margin="35,0,25,0" IsHitTestVisible="False">
<Grid.RowDefinitions> <Grid.RowDefinitions>
@@ -18,7 +18,7 @@
Private IsLoad As Boolean = False Private IsLoad As Boolean = False
Private Sub OnLoaded() Handles Me.Loaded Private Sub OnLoaded() Handles Me.Loaded
FormMain.EndProgramForce(ProcessReturnValues.Aborted) FormMain.EndProgramForce(ProcessReturnValues.Aborted)
If IsLoad Then Exit Sub If IsLoad Then Return
IsLoad = True IsLoad = True
'启动监视线程 '启动监视线程
If Not IsWatcherStarted Then RunInNewThread(AddressOf WatcherThread, "Hiper Watcher") If Not IsWatcherStarted Then RunInNewThread(AddressOf WatcherThread, "Hiper Watcher")
@@ -149,7 +149,7 @@
'每 1 秒执行的 Timer '每 1 秒执行的 Timer
Private Sub WatcherTimer1() Private Sub WatcherTimer1()
If HiperState <> LoadState.Finished Then Exit Sub If HiperState <> LoadState.Finished Then Return
RunInUi(Sub() RunInUi(Sub()
'索引码剩余时间 '索引码剩余时间
Dim Span As TimeSpan = HiperCertTime - Date.Now Dim Span As TimeSpan = HiperCertTime - Date.Now
@@ -178,7 +178,7 @@
HiperExit(True) HiperExit(True)
ShowWindowToTop(Handle) ShowWindowToTop(Handle)
Beep() Beep()
Exit Sub Return
End If End If
'网络质量 '网络质量
Dim QualityScore As Integer = If(IpIsInChina, 0, -2) Dim QualityScore As Integer = If(IpIsInChina, 0, -2)
@@ -272,7 +272,7 @@
Log("[Hiper] 连接步骤:" & Intro) Log("[Hiper] 连接步骤:" & Intro)
LoadStep = [Step] LoadStep = [Step]
RunInUiWait(Sub() RunInUiWait(Sub()
If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.LabLoadDesc.IsLoaded Then Exit Sub If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.LabLoadDesc.IsLoaded Then Return
FrmLinkHiper.LabLoadDesc.Text = Intro FrmLinkHiper.LabLoadDesc.Text = Intro
FrmLinkHiper.UpdateProgress() FrmLinkHiper.UpdateProgress()
End Sub) End Sub)
@@ -280,7 +280,7 @@
'承接重试 '承接重试
Private Sub CardLoad_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles CardLoad.MouseLeftButtonUp Private Sub CardLoad_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles CardLoad.MouseLeftButtonUp
If Not InitLoader.State = LoadState.Failed Then Exit Sub If Not InitLoader.State = LoadState.Failed Then Return
InitLoader.Start(IsForceRestart:=True) InitLoader.Start(IsForceRestart:=True)
End Sub End Sub
@@ -299,7 +299,7 @@
Private Sub UpdateProgress(Optional Value As Double = -1) Private Sub UpdateProgress(Optional Value As Double = -1)
If Value = -1 Then Value = InitLoader.Progress If Value = -1 Then Value = InitLoader.Progress
Dim DisplayingProgress As Double = ColumnProgressA.Width.Value Dim DisplayingProgress As Double = ColumnProgressA.Width.Value
If Math.Round(Value - DisplayingProgress, 3) = 0 Then Exit Sub If Math.Round(Value - DisplayingProgress, 3) = 0 Then Return
If DisplayingProgress > Value Then If DisplayingProgress > Value Then
ColumnProgressA.Width = New GridLength(Value, GridUnitType.Star) ColumnProgressA.Width = New GridLength(Value, GridUnitType.Star)
ColumnProgressB.Width = New GridLength(1 - Value, GridUnitType.Star) ColumnProgressB.Width = New GridLength(1 - Value, GridUnitType.Star)
@@ -327,7 +327,7 @@
'退出 '退出
Private Sub BtnFinishExit_Click(sender As Object, e As EventArgs) Handles BtnFinishExit.Click Private Sub BtnFinishExit_Click(sender As Object, e As EventArgs) Handles BtnFinishExit.Click
If IsServerSide AndAlso MyMsgBox("你确定要关闭联机房间吗?", "确认退出", "确定", "取消", IsWarn:=True) = 2 Then Exit Sub If IsServerSide AndAlso MyMsgBox("你确定要关闭联机房间吗?", "确认退出", "确定", "取消", IsWarn:=True) = 2 Then Return
HiperExit(False) HiperExit(False)
End Sub End Sub
@@ -338,7 +338,7 @@
'Ping 房主 'Ping 房主
Private Sub BtnFinishPing_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishPing.MouseLeftButtonUp Private Sub BtnFinishPing_MouseLeftButtonUp(sender As Object, e As MouseButtonEventArgs) Handles BtnFinishPing.MouseLeftButtonUp
LabFinishPing.Text = "检测中" LabFinishPing.Text = "检测中"
If TaskPingHost.State = LoadState.Loading Then Exit Sub If TaskPingHost.State = LoadState.Loading Then Return
TaskPingHost.Start(True, IsForceRestart:=True) TaskPingHost.Start(True, IsForceRestart:=True)
End Sub End Sub
Private Shared TaskPingHost As New LoaderTask(Of Boolean, Integer)("HiPer Ping Host", Private Shared TaskPingHost As New LoaderTask(Of Boolean, Integer)("HiPer Ping Host",
@@ -362,7 +362,7 @@
Return _CurrentSubpage Return _CurrentSubpage
End Get End Get
Set(value As Subpages) Set(value As Subpages)
If _CurrentSubpage = value Then Exit Property If _CurrentSubpage = value Then Return
_CurrentSubpage = value _CurrentSubpage = value
Log("[Hiper] 子页面更改为 " & GetStringFromEnum(value)) Log("[Hiper] 子页面更改为 " & GetStringFromEnum(value))
PageOnContentExit() PageOnContentExit()
@@ -384,7 +384,7 @@
If InitLoader.State = LoadState.Loading Then InitLoader.Abort() If InitLoader.State = LoadState.Loading Then InitLoader.Abort()
If InitLoader.State = LoadState.Failed Then InitLoader.State = LoadState.Waiting If InitLoader.State = LoadState.Failed Then InitLoader.State = LoadState.Waiting
RunInUi(Sub() RunInUi(Sub()
If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.IsLoaded Then Exit Sub If FrmLinkHiper Is Nothing OrElse Not FrmLinkHiper.IsLoaded Then Return
FrmLinkHiper.CurrentSubpage = If(ExitToCertPage, Subpages.PanCert, Subpages.PanSelect) FrmLinkHiper.CurrentSubpage = If(ExitToCertPage, Subpages.PanCert, Subpages.PanSelect)
FrmLinkHiper.PageOnContentExit() FrmLinkHiper.PageOnContentExit()
End Sub) End Sub)
@@ -10,7 +10,7 @@
<StackPanel Orientation="Vertical" Margin="25,10"> <StackPanel Orientation="Vertical" Margin="25,10">
<local:MyCard Margin="0,15,0,0" x:Name="CardUser" Title="已连接的玩家 (0)"> <local:MyCard Margin="0,15,0,0" x:Name="CardUser" Title="已连接的玩家 (0)">
<StackPanel Margin="20,37,20,15"> <StackPanel Margin="20,37,20,15">
<local:MyHint Margin="5,2,5,8" x:Name="LabHint" IsWarn="False" /> <local:MyHint Margin="5,2,5,8" x:Name="LabHint" />
<StackPanel x:Name="PanUserList" /> <StackPanel x:Name="PanUserList" />
<Grid Height="35" Margin="5,8,5,5"> <Grid Height="35" Margin="5,8,5,5">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
@@ -3,10 +3,10 @@
Private IsLoad As Boolean = False Private IsLoad As Boolean = False
Private IsPageSwitched As Boolean = False '如果在 Loaded 前切换到其他页面,会导致触发 Loaded 时再次切换一次 Private IsPageSwitched As Boolean = False '如果在 Loaded 前切换到其他页面,会导致触发 Loaded 时再次切换一次
Private Sub PageLinkLeft_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded Private Sub PageLinkLeft_Loaded(sender As Object, e As RoutedEventArgs) Handles Me.Loaded
If IsLoad Then Exit Sub If IsLoad Then Return
IsLoad = True IsLoad = True
'切换默认页面 '切换默认页面
If IsPageSwitched Then Exit Sub If IsPageSwitched Then Return
ItemHiper.SetChecked(True, False, False) ItemHiper.SetChecked(True, False, False)
End Sub End Sub
Private Sub PageOtherLeft_Unloaded(sender As Object, e As RoutedEventArgs) Handles Me.Unloaded Private Sub PageOtherLeft_Unloaded(sender As Object, e As RoutedEventArgs) Handles Me.Unloaded
@@ -56,7 +56,7 @@
''' 切换现有页面。 ''' 切换现有页面。
''' </summary> ''' </summary>
Public Sub PageChange(ID As FormMain.PageSubType) Public Sub PageChange(ID As FormMain.PageSubType)
If PageID = ID Then Exit Sub If PageID = ID Then Return
AniControlEnabled += 1 AniControlEnabled += 1
IsPageSwitched = True IsPageSwitched = True
Try Try
@@ -17,7 +17,7 @@
<ColumnDefinition /> <ColumnDefinition />
<ColumnDefinition Width="150" /> <ColumnDefinition Width="150" />
</Grid.ColumnDefinitions> </Grid.ColumnDefinitions>
<local:MyListItem IsHitTestVisible="False" Title="龙腾猫跃" Margin="-5,0,15,0" Info="Plain Craft Launcher 的作者!" Grid.Row="0" Grid.Column="1" /> <local:MyListItem IsHitTestVisible="False" Title="龙腾猫跃" Margin="-5,0,15,0" Info="Plain Craft Launcher 的开发者!" Grid.Row="0" Grid.Column="1" />
<local:MyListItem IsHitTestVisible="False" Title="Plain Craft Launcher 2" Margin="-5,0,15,0" Info="当前版本:%VERSION%(%VERSIONCODE%.%BRANCH%)" Grid.Row="1" Grid.Column="1" x:Name="ItemAboutPcl" /> <local:MyListItem IsHitTestVisible="False" Title="Plain Craft Launcher 2" Margin="-5,0,15,0" Info="当前版本:%VERSION%(%VERSIONCODE%.%BRANCH%)" Grid.Row="1" Grid.Column="1" x:Name="ItemAboutPcl" />
<Image Source="/Plain Craft Launcher 2;component/Images/Heads/Logo.png" Grid.Row="1" Margin="3"> <Image Source="/Plain Craft Launcher 2;component/Images/Heads/Logo.png" Grid.Row="1" Margin="3">
<Image.Clip> <Image.Clip>
@@ -29,7 +29,7 @@
<EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" /> <EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" />
</Image.Clip> </Image.Clip>
</Image> </Image>
<local:MyButton Text="赞助作者" Grid.Column="2" Grid.Row="0" Height="35" EventType="打开网页" EventData="https://afdian.com/a/LTCat" /> <local:MyButton Text="赞助 PCL !" Grid.Column="2" Grid.Row="0" Height="35" EventType="打开网页" EventData="https://afdian.com/a/LTCat" ColorType="Highlight" />
<local:MyButton Text="查看源代码" Grid.Column="2" Grid.Row="1" Height="35" EventType="打开网页" EventData="https://github.com/Hex-Dragon/PCL2" /> <local:MyButton Text="查看源代码" Grid.Column="2" Grid.Row="1" Height="35" EventType="打开网页" EventData="https://github.com/Hex-Dragon/PCL2" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
@@ -51,11 +51,12 @@
<ColumnDefinition Width="150" /> <ColumnDefinition Width="150" />
</Grid.ColumnDefinitions> </Grid.ColumnDefinitions>
<local:MyListItem Title="bangbang93" Margin="-5,0,15,0" IsHitTestVisible="False" Info="提供 BMCLAPI 镜像源和 Forge 安装工具,详见 https://bmclapi.bangbang93.com" Grid.Row="0" Grid.Column="1" /> <local:MyListItem Title="bangbang93" Margin="-5,0,15,0" IsHitTestVisible="False" Info="提供 BMCLAPI 镜像源和 Forge 安装工具,详见 https://bmclapi.bangbang93.com" Grid.Row="0" Grid.Column="1" />
<local:MyButton x:Name="BtnAboutBmclapi" Text="赞助镜像源" Grid.Row="0" Grid.Column="2" Height="35" /> <local:MyButton Text="赞助镜像源" Grid.Row="0" Grid.Column="2" Height="35" EventType="打开网页" EventData="https://afdian.com/a/bangbang93" />
<local:MyListItem Title="MC 百科" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="提供了 Mod 名称的中文翻译和更多相关信息!" Grid.Row="1" Grid.Column="1" /> <local:MyListItem Title="MC 百科" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="提供了 Mod 名称的中文翻译和更多相关信息!" Grid.Row="1" Grid.Column="1" />
<local:MyButton x:Name="BtnAboutWiki" Text="打开百科" Grid.Row="1" Grid.Column="2" Height="35" /> <local:MyButton Text="打开百科" Grid.Row="1" Grid.Column="2" Height="35" EventType="打开网页" EventData="https://www.mcmod.cn" />
<local:MyListItem Title="00ll00" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="提供了 Java Launch Wrapper 和一些重要服务支持!" Grid.Row="2" Grid.Column="1" /> <local:MyListItem Title="z0z0r4" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="提供了 MCIM 社区资源镜像源和帮助库图床!" Grid.Row="2" Grid.Column="1" />
<local:MyListItem Title="z0z0r4" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="提供了 MCIM 中国 Mod 下载镜像源和帮助库图床!" Grid.Row="3" Grid.Column="1" /> <local:MyButton Text="MCIM 主页" Grid.Row="2" Grid.Column="2" Height="35" EventType="打开网页" EventData="https://github.com/mcmod-info-mirror" />
<local:MyListItem Title="00ll00" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="提供了 Java Launch Wrapper 和一些重要服务支持!" Grid.Row="3" Grid.Column="1" />
<local:MyListItem Title="Patrick" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="设计并制作了 PCL 图标,让我从做图标的水深火热中得到了解脱……" Grid.Row="4" Grid.Column="1" /> <local:MyListItem Title="Patrick" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="设计并制作了 PCL 图标,让我从做图标的水深火热中得到了解脱……" Grid.Row="4" Grid.Column="1" />
<local:MyListItem Title="Hao_Tian" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="在内测中找出了一大堆没人想得到的诡异 Bug,有非同寻常的 Bug 体质" Grid.Row="5" Grid.Column="1" /> <local:MyListItem Title="Hao_Tian" Margin="-5,0,0,0" IsHitTestVisible="False" Grid.ColumnSpan="2" Info="在内测中找出了一大堆没人想得到的诡异 Bug,有非同寻常的 Bug 体质" Grid.Row="5" Grid.Column="1" />
<local:MyListItem Title="Minecraft 中文论坛" Margin="-5,0,15,0" IsHitTestVisible="False" Info="虽然已经关站了,但感谢此前提供了 MCBBS 镜像源……" Grid.Row="6" Grid.Column="1" /> <local:MyListItem Title="Minecraft 中文论坛" Margin="-5,0,15,0" IsHitTestVisible="False" Info="虽然已经关站了,但感谢此前提供了 MCBBS 镜像源……" Grid.Row="6" Grid.Column="1" />
@@ -70,12 +71,12 @@
<EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" /> <EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" />
</Image.Clip> </Image.Clip>
</Image> </Image>
<Image Source="/Plain Craft Launcher 2;component/Images/Heads/00ll00.png" Grid.Row="2" Margin="3"> <Image Source="/Plain Craft Launcher 2;component/Images/Heads/z0z0r4.png" Grid.Row="2" Margin="3">
<Image.Clip> <Image.Clip>
<EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" /> <EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" />
</Image.Clip> </Image.Clip>
</Image> </Image>
<Image Source="/Plain Craft Launcher 2;component/Images/Heads/z0z0r4.png" Grid.Row="3" Margin="3"> <Image Source="/Plain Craft Launcher 2;component/Images/Heads/00ll00.png" Grid.Row="3" Margin="3">
<Image.Clip> <Image.Clip>
<EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" /> <EllipseGeometry Center="17 17" RadiusX="17" RadiusY="17" />
</Image.Clip> </Image.Clip>
@@ -104,197 +105,245 @@
</local:MyCard> </local:MyCard>
<local:MyCard Margin="0,0,0,15" Title="赞助者"> <local:MyCard Margin="0,0,0,15" Title="赞助者">
<StackPanel Margin="25,40,10,20"> <StackPanel Margin="25,40,10,20">
<TextBlock HorizontalAlignment="Left" Text="以下是 2025 年 3 月的高级赞助者们!感谢各位对 PCL 和伟大的咕咕咕事业的支持!" Margin="0,0,25,5.5" TextTrimming="None" TextWrapping="WrapWithOverflow" /> <TextBlock HorizontalAlignment="Left" Text="以下是 2025 年 7 月的高级赞助者们!感谢各位对 PCL 和伟大的咕咕咕事业的支持!" Margin="0,0,25,5.5" TextTrimming="None" TextWrapping="WrapWithOverflow" />
<WrapPanel Margin="0,0,0,10"> <TextBlock Width="120" Margin="0,1.5" Text="micheal276" /> <WrapPanel Margin="0,0,0,10"> <TextBlock Width="120" Margin="0,1.5" Text="ZSF" />
<TextBlock Width="120" Margin="0,1.5" Text="吃面不加葱" /> <TextBlock Width="120" Margin="0,1.5" Text="TizhleF" />
<TextBlock Width="120" Margin="0,1.5" Text="想去看那倒悬山" /> <TextBlock Width="120" Margin="0,1.5" Text="方源" />
<TextBlock Width="120" Margin="0,1.5" Text="隳之狐" /> <TextBlock Width="120" Margin="0,1.5" Text="日月空呵" />
<TextBlock Width="120" Margin="0,1.5" Text="QY熹微" /> <TextBlock Width="120" Margin="0,1.5" Text="贾明志" />
<TextBlock Width="120" Margin="0,1.5" Text="LZL" /> <TextBlock Width="120" Margin="0,1.5" Text="百瑞" />
<TextBlock Width="120" Margin="0,1.5" Text="老卡费" /> <TextBlock Width="120" Margin="0,1.5" Text="Flying___pig" />
<TextBlock Width="120" Margin="0,1.5" Text="散." /> <TextBlock Width="120" Margin="0,1.5" Text="绝世" />
<TextBlock Width="120" Margin="0,1.5" Text="续笙_xusheng" /> <TextBlock Width="120" Margin="0,1.5" Text="Jwac" />
<TextBlock Width="120" Margin="0,1.5" Text="HappyGhast0123" /> <TextBlock Width="120" Margin="0,1.5" Text="万玖" />
<TextBlock Width="120" Margin="0,1.5" Text="Tong" /> <TextBlock Width="120" Margin="0,1.5" Text="墨忆" />
<TextBlock Width="120" Margin="0,1.5" Text="15158206433" /> <TextBlock Width="120" Margin="0,1.5" Text="天刹" />
<TextBlock Width="120" Margin="0,1.5" Text="一抹蓝色和粉色" /> <TextBlock Width="120" Margin="0,1.5" Text="Cess" />
<TextBlock Width="120" Margin="0,1.5" Text="UcFB" /> <TextBlock Width="120" Margin="0,1.5" Text="ender_glass" />
<TextBlock Width="120" Margin="0,1.5" Text="哦" /> <TextBlock Width="120" Margin="0,1.5" Text="TT" />
<TextBlock Width="120" Margin="0,1.5" Text="T2222" /> <TextBlock Width="120" Margin="0,1.5" Text="白玄.雪狼" />
<TextBlock Width="120" Margin="0,1.5" Text="Toudesu" /> <TextBlock Width="120" Margin="0,1.5" Text="MUCT" />
<TextBlock Width="120" Margin="0,1.5" Text="苏利" /> <TextBlock Width="120" Margin="0,1.5" Text="崇昀" />
<TextBlock Width="120" Margin="0,1.5" Text="DW." /> <TextBlock Width="120" Margin="0,1.5" Text="绪" />
<TextBlock Width="120" Margin="0,1.5" Text="抛抛不是泡泡" /> <TextBlock Width="120" Margin="0,1.5" Text="吾皇万岁" />
<TextBlock Width="120" Margin="0,1.5" Text="无名小卒" /> <TextBlock Width="120" Margin="0,1.5" Text="Ander·Les" />
<TextBlock Width="120" Margin="0,1.5" Text="lgl" /> <TextBlock Width="120" Margin="0,1.5" Text="Eoctopus" />
<TextBlock Width="120" Margin="0,1.5" Text="mk" /> <TextBlock Width="120" Margin="0,1.5" Text="时光飞逝一下午" />
<TextBlock Width="120" Margin="0,1.5" Text="鲨鱼不是鱼" /> <TextBlock Width="120" Margin="0,1.5" Text="Carl7412" />
<TextBlock Width="120" Margin="0,1.5" Text="Momizi_Azusa" /> <TextBlock Width="120" Margin="0,1.5" Text="ShinyChariot" />
<TextBlock Width="120" Margin="0,1.5" Text="oseki" /> <TextBlock Width="120" Margin="0,1.5" Text="骨故谷" />
<TextBlock Width="120" Margin="0,1.5" Text="精?华?夏?" /> <TextBlock Width="120" Margin="0,1.5" Text="?" />
<TextBlock Width="120" Margin="0,1.5" Text="术士的黑猫" /> <TextBlock Width="120" Margin="0,1.5" Text="Jinji希子" />
<TextBlock Width="120" Margin="0,1.5" Text="theagin" /> <TextBlock Width="120" Margin="0,1.5" Text="自然选择" />
<TextBlock Width="120" Margin="0,1.5" Text="狗杞わ枸子" /> <TextBlock Width="120" Margin="0,1.5" Text="云念" />
<TextBlock Width="120" Margin="0,1.5" Text="别凶不二啦" /> <TextBlock Width="120" Margin="0,1.5" Text="钱尹鹏" />
<TextBlock Width="120" Margin="0,1.5" Text="枫叶落江" /> <TextBlock Width="120" Margin="0,1.5" Text="TBONC" />
<TextBlock Width="120" Margin="0,1.5" Text="Tianwai来物" /> <TextBlock Width="120" Margin="0,1.5" Text="祈农" />
<TextBlock Width="120" Margin="0,1.5" Text="如风FC" /> <TextBlock Width="120" Margin="0,1.5" Text="凤凰院凶真" />
<TextBlock Width="120" Margin="0,1.5" Text="fan" /> <TextBlock Width="120" Margin="0,1.5" Text="ShuangDaoRen" />
<TextBlock Width="120" Margin="0,1.5" Text="雨恋芳歌" /> <TextBlock Width="120" Margin="0,1.5" Text="PXZ233" />
<TextBlock Width="120" Margin="0,1.5" Text="neko" /> <TextBlock Width="120" Margin="0,1.5" Text="二十二今天有没有" />
<TextBlock Width="120" Margin="0,1.5" Text="陌上云暮迟迟归" /> <TextBlock Width="120" Margin="0,1.5" Text="天魕" />
<TextBlock Width="120" Margin="0,1.5" Text="121" /> <TextBlock Width="120" Margin="0,1.5" Text="南华清" />
<TextBlock Width="120" Margin="0,1.5" Text="SGYH" /> <TextBlock Width="120" Margin="0,1.5" Text="66112447" />
<TextBlock Width="120" Margin="0,1.5" Text="Lelouch" /> <TextBlock Width="120" Margin="0,1.5" Text="夏行子" />
<TextBlock Width="120" Margin="0,1.5" Text="tisky" /> <TextBlock Width="120" Margin="0,1.5" Text="周俊成" />
<TextBlock Width="120" Margin="0,1.5" Text="禹餘" /> <TextBlock Width="120" Margin="0,1.5" Text="乌漆嘛黑" />
<TextBlock Width="120" Margin="0,1.5" Text="MoYou" /> <TextBlock Width="120" Margin="0,1.5" Text="肘击恶魔佐巴扬" />
<TextBlock Width="240" Margin="0,1.5" Text="?HONEY HONEY BOOM?" /> <TextBlock Width="120" Margin="0,1.5" Text="Pari~" />
<TextBlock Width="120" Margin="0,1.5" Text="流雪无痕" /> <TextBlock Width="120" Margin="0,1.5" Text="红云" />
<TextBlock Width="120" Margin="0,1.5" Text="yourenA" /> <TextBlock Width="120" Margin="0,1.5" Text="Link-an" />
<TextBlock Width="120" Margin="0,1.5" Text="当归与蜜糖" /> <TextBlock Width="120" Margin="0,1.5" Text="想要钱用不完" />
<TextBlock Width="120" Margin="0,1.5" Text="提瓦特太保" /> <TextBlock Width="120" Margin="0,1.5" Text="花宝" />
<TextBlock Width="120" Margin="0,1.5" Text="weidao-云天" /> <TextBlock Width="120" Margin="0,1.5" Text="生于春天的雷电" />
<TextBlock Width="120" Margin="0,1.5" Text="Yangxl" /> <TextBlock Width="120" Margin="0,1.5" Text="被偷去的睡眠" />
<TextBlock Width="120" Margin="0,1.5" Text="zero" /> <TextBlock Width="120" Margin="0,1.5" Text="liuxuan" />
<TextBlock Width="120" Margin="0,1.5" Text="guoomg" /> <TextBlock Width="120" Margin="0,1.5" Text="寒枫凌" />
<TextBlock Width="120" Margin="0,1.5" Text="孤念鬱海" /> <TextBlock Width="120" Margin="0,1.5" Text="雀色时" />
<TextBlock Width="120" Margin="0,1.5" Text="李晨曦" /> <TextBlock Width="120" Margin="0,1.5" Text="架" />
<TextBlock Width="120" Margin="0,1.5" Text="dyh" /> <TextBlock Width="120" Margin="0,1.5" Text="终成究竟觉" />
<TextBlock Width="120" Margin="0,1.5" Text="didibubu" /> <TextBlock Width="120" Margin="0,1.5" Text="S0D1UM" />
<TextBlock Width="120" Margin="0,1.5" Text="way_" /> <TextBlock Width="120" Margin="0,1.5" Text="吞仔送命" />
<TextBlock Width="120" Margin="0,1.5" Text="浅冥" /> <TextBlock Width="120" Margin="0,1.5" Text="白浪宇宙" />
<TextBlock Width="120" Margin="0,1.5" Text="LightTeaHear" /> <TextBlock Width="120" Margin="0,1.5" Text="Crimson" />
<TextBlock Width="120" Margin="0,1.5" Text="kiki" /> <TextBlock Width="120" Margin="0,1.5" Text="Mibo_MkIX" />
<TextBlock Width="120" Margin="0,1.5" Text="洛山阳" /> <TextBlock Width="120" Margin="0,1.5" Text="G.snine18^7" />
<TextBlock Width="120" Margin="0,1.5" Text="月下独酌" /> <TextBlock Width="120" Margin="0,1.5" Text="两把雨伞" />
<TextBlock Width="120" Margin="0,1.5" Text="阿晴" /> <TextBlock Width="120" Margin="0,1.5" Text="古明地苑" />
<TextBlock Width="120" Margin="0,1.5" Text="论猫的液体可能性" /> <TextBlock Width="240" Margin="0,1.5" Text="MarbleMionshevic" />
<TextBlock Width="120" Margin="0,1.5" Text="微尔丶白折" /> <TextBlock Width="120" Margin="0,1.5" Text=":〈" />
<TextBlock Width="120" Margin="0,1.5" Text="超凡大谱系" /> <TextBlock Width="120" Margin="0,1.5" Text="紫罗兰" />
<TextBlock Width="120" Margin="0,1.5" Text="麻圣" /> <TextBlock Width="120" Margin="0,1.5" Text="asai" />
<TextBlock Width="120" Margin="0,1.5" Text="八宝饭" /> <TextBlock Width="120" Margin="0,1.5" Text="隔壁小明" />
<TextBlock Width="120" Margin="0,1.5" Text="张不易" /> <TextBlock Width="120" Margin="0,1.5" Text="就爱唱歌" />
<TextBlock Width="120" Margin="0,1.5" Text="1" /> <TextBlock Width="120" Margin="0,1.5" Text="沫神鹤" />
<TextBlock Width="120" Margin="0,1.5" Text="望Wang" /> <TextBlock Width="120" Margin="0,1.5" Text="风已消逝" />
<TextBlock Width="120" Margin="0,1.5" Text="alrin" /> <TextBlock Width="120" Margin="0,1.5" Text="光意留闪" />
<TextBlock Width="120" Margin="0,1.5" Text="无心态" /> <TextBlock Width="120" Margin="0,1.5" Text="我们长征的路上" />
<TextBlock Width="120" Margin="0,1.5" Text="MelonEater88" /> <TextBlock Width="120" Margin="0,1.5" Text="芸芷" />
<TextBlock Width="120" Margin="0,1.5" Text="白日梦" /> <TextBlock Width="120" Margin="0,1.5" Text="函数极限" />
<TextBlock Width="120" Margin="0,1.5" Text="FEssyyzplane" /> <TextBlock Width="120" Margin="0,1.5" Text="冰川泥" />
<TextBlock Width="120" Margin="0,1.5" Text="札卜铎徳勒" /> <TextBlock Width="120" Margin="0,1.5" Text="XunWei" />
<TextBlock Width="120" Margin="0,1.5" Text="星河" /> <TextBlock Width="120" Margin="0,1.5" Text="sirous" />
<TextBlock Width="120" Margin="0,1.5" Text="老王1233" /> <TextBlock Width="120" Margin="0,1.5" Text="路过某打酱油的" />
<TextBlock Width="120" Margin="0,1.5" Text="王等等等" /> <TextBlock Width="120" Margin="0,1.5" Text="Gnight07" />
<TextBlock Width="120" Margin="0,1.5" Text="橘子233" /> <TextBlock Width="120" Margin="0,1.5" Text="结构德古拉" />
<TextBlock Width="120" Margin="0,1.5" Text="wyhll" /> <TextBlock Width="120" Margin="0,1.5" Text="myyukee" />
<TextBlock Width="120" Margin="0,1.5" Text="SiMen_774" /> <TextBlock Width="240" Margin="0,1.5" Text="云之彼端约定的地方" />
<TextBlock Width="120" Margin="0,1.5" Text="Klcos" /> <TextBlock Width="120" Margin="0,1.5" Text="苏玖" />
<TextBlock Width="120" Margin="0,1.5" Text="pepsi" /> <TextBlock Width="120" Margin="0,1.5" Text="赤沃净" />
<TextBlock Width="120" Margin="0,1.5" Text="FORGE" /> <TextBlock Width="120" Margin="0,1.5" Text="YYC" />
<TextBlock Width="120" Margin="0,1.5" Text="李青团" /> <TextBlock Width="120" Margin="0,1.5" Text="晨曦酒庄高冷男" />
<TextBlock Width="120" Margin="0,1.5" Text="Zmr2333" /> <TextBlock Width="120" Margin="0,1.5" Text="herald112" />
<TextBlock Width="120" Margin="0,1.5" Text="CWKF" /> <TextBlock Width="120" Margin="0,1.5" Text="Foxman" />
<TextBlock Width="240" Margin="0,1.5" Text="兜帽人evei622130" /> <TextBlock Width="120" Margin="0,1.5" Text="KoreQAQ" />
<TextBlock Width="120" Margin="0,1.5" Text="毒奶神探女" /> <TextBlock Width="120" Margin="0,1.5" Text="TechOfRevo" />
<TextBlock Width="120" Margin="0,1.5" Text="赤诚之心" /> <TextBlock Width="120" Margin="0,1.5" Text="lqs" />
<TextBlock Width="120" Margin="0,1.5" Text="藏白" /> <TextBlock Width="120" Margin="0,1.5" Text="简某" />
<TextBlock Width="120" Margin="0,1.5" Text="某零子" /> <TextBlock Width="120" Margin="0,1.5" Text="源起于此" />
<TextBlock Width="120" Margin="0,1.5" Text="WJMAS" /> <TextBlock Width="120" Margin="0,1.5" Text="爱莉希雅" />
<TextBlock Width="120" Margin="0,1.5" Text="骨头" /> <TextBlock Width="120" Margin="0,1.5" Text=" 和忧" />
<TextBlock Width="120" Margin="0,1.5" Text="Starying" /> <TextBlock Width="240" Margin="0,1.5" Text="全明星小面包批发商DIO" />
<TextBlock Width="120" Margin="0,1.5" Text="钱小穷" /> <TextBlock Width="120" Margin="0,1.5" Text="碎序" />
<TextBlock Width="120" Margin="0,1.5" Text="casper" /> <TextBlock Width="120" Margin="0,1.5" Text="U" />
<TextBlock Width="120" Margin="0,1.5" Text="Summer丿皓月" /> <TextBlock Width="120" Margin="0,1.5" Text="Dumlet" />
<TextBlock Width="120" Margin="0,1.5" Text="小促" /> <TextBlock Width="120" Margin="0,1.5" Text="johnqian" />
<TextBlock Width="120" Margin="0,1.5" Text="御坂美琴" /> <TextBlock Width="120" Margin="0,1.5" Text="KANG" />
<TextBlock Width="120" Margin="0,1.5" Text="闲的没事干啥呢" /> <TextBlock Width="120" Margin="0,1.5" Text="owod" />
<TextBlock Width="120" Margin="0,1.5" Text="aiyu" /> <TextBlock Width="120" Margin="0,1.5" Text="九" />
<TextBlock Width="120" Margin="0,1.5" Text="shuaitiao" /> <TextBlock Width="120" Margin="0,1.5" Text="苑煜" />
<TextBlock Width="120" Margin="0,1.5" Text="小真寻" /> <TextBlock Width="120" Margin="0,1.5" Text="壹" />
<TextBlock Width="120" Margin="0,1.5" Text="清离风" /> <TextBlock Width="120" Margin="0,1.5" Text="UA-Ming" />
<TextBlock Width="240" Margin="0,1.5" Text="FateIsYetUncertain" /> <TextBlock Width="120" Margin="0,1.5" Text="可爱小探姬" />
<TextBlock Width="120" Margin="0,1.5" Text="Olympia" /> <TextBlock Width="120" Margin="0,1.5" Text="霜月" />
<TextBlock Width="120" Margin="0,1.5" Text="橘如望九" /> <TextBlock Width="120" Margin="0,1.5" Text="bud" />
<TextBlock Width="120" Margin="0,1.5" Text="木涵" /> <TextBlock Width="120" Margin="0,1.5" Text="小虐SAIKYO" />
<TextBlock Width="120" Margin="0,1.5" Text="2147483647" /> <TextBlock Width="120" Margin="0,1.5" Text="zealotand" />
<TextBlock Width="120" Margin="0,1.5" Text="YJ-StarBlock" /> <TextBlock Width="120" Margin="0,1.5" Text="comico" />
<TextBlock Width="120" Margin="0,1.5" Text="欲予卿" /> <TextBlock Width="120" Margin="0,1.5" Text="万山松" />
<TextBlock Width="120" Margin="0,1.5" Text="haolanne" /> <TextBlock Width="120" Margin="0,1.5" Text="依梦明天" />
<TextBlock Width="120" Margin="0,1.5" Text="浅夏" /> <TextBlock Width="120" Margin="0,1.5" Text="化形彧九尾" />
<TextBlock Width="120" Margin="0,1.5" Text="MCxiaobai" /> <TextBlock Width="120" Margin="0,1.5" Text="知崎" />
<TextBlock Width="120" Margin="0,1.5" Text="未知数x酱" /> <TextBlock Width="120" Margin="0,1.5" Text="LOG175" />
<TextBlock Width="120" Margin="0,1.5" Text="有事打钱" /> <TextBlock Width="120" Margin="0,1.5" Text="绵" />
<TextBlock Width="120" Margin="0,1.5" Text="Setsuna" /> <TextBlock Width="120" Margin="0,1.5" Text="scp00813" />
<TextBlock Width="120" Margin="0,1.5" Text="电脑" /> <TextBlock Width="120" Margin="0,1.5" Text="宝宝" />
<TextBlock Width="120" Margin="0,1.5" Text="mpty" /> <TextBlock Width="120" Margin="0,1.5" Text="9527" />
<TextBlock Width="120" Margin="0,1.5" Text="小兔噗噗" /> <TextBlock Width="120" Margin="0,1.5" Text="ICE_xwx" />
<TextBlock Width="120" Margin="0,1.5" Text="超级白羊大王" /> <TextBlock Width="120" Margin="0,1.5" Text="羽笙喵喵" />
<TextBlock Width="120" Margin="0,1.5" Text="奈奈" /> <TextBlock Width="120" Margin="0,1.5" Text="ssvgg(☉ x ☉)" />
<TextBlock Width="120" Margin="0,1.5" Text="12345" /> <TextBlock Width="120" Margin="0,1.5" Text="Happymeals" />
<TextBlock Width="120" Margin="0,1.5" Text="fshj" /> <TextBlock Width="120" Margin="0,1.5" Text="shen12244" />
<TextBlock Width="120" Margin="0,1.5" Text="Langfeige" /> <TextBlock Width="120" Margin="0,1.5" Text="一般路过AAA" />
<TextBlock Width="120" Margin="0,1.5" Text="聆风岱岳" /> <TextBlock Width="120" Margin="0,1.5" Text="Niko" />
<TextBlock Width="120" Margin="0,1.5" Text="Fier" /> <TextBlock Width="120" Margin="0,1.5" Text="qroiwopqri" />
<TextBlock Width="120" Margin="0,1.5" Text="张怀民" /> <TextBlock Width="120" Margin="0,1.5" Text="TringDron" />
<TextBlock Width="120" Margin="0,1.5" Text="minecraftmc22" /> <TextBlock Width="120" Margin="0,1.5" Text="有屳則名" />
<TextBlock Width="120" Margin="0,1.5" Text="爱蹈琯子" /> <TextBlock Width="120" Margin="0,1.5" Text="TX2006" />
<TextBlock Width="120" Margin="0,1.5" Text="何心慈" /> <TextBlock Width="120" Margin="0,1.5" Text="滑天下之大稽" />
<TextBlock Width="120" Margin="0,1.5" Text="睏欤" /> <TextBlock Width="120" Margin="0,1.5" Text="中东悍匪" />
<TextBlock Width="120" Margin="0,1.5" Text="熙里糊涂" /> <TextBlock Width="120" Margin="0,1.5" Text="鬼泣々离殇" />
<TextBlock Width="120" Margin="0,1.5" Text="落叶" /> <TextBlock Width="120" Margin="0,1.5" Text="蒼崎青子" />
<TextBlock Width="120" Margin="0,1.5" Text="阿坎尔德" /> <TextBlock Width="120" Margin="0,1.5" Text="wyh114514" />
<TextBlock Width="120" Margin="0,1.5" Text="杜野凛世" /> <TextBlock Width="120" Margin="0,1.5" Text="飞飞在睡觉。" />
<TextBlock Width="120" Margin="0,1.5" Text="呆呆" /> <TextBlock Width="120" Margin="0,1.5" Text="柚西" />
<TextBlock Width="240" Margin="0,1.5" Text="我和琳妮特有个孩子" /> <TextBlock Width="120" Margin="0,1.5" Text="XIAOSHUAI" />
<TextBlock Width="120" Margin="0,1.5" Text="Fishking_qwe" /> <TextBlock Width="120" Margin="0,1.5" Text="saxioh" />
<TextBlock Width="120" Margin="0,1.5" Text="惠惠" /> <TextBlock Width="120" Margin="0,1.5" Text="baibaibai" />
<TextBlock Width="120" Margin="0,1.5" Text="黑暗风暴" /> <TextBlock Width="120" Margin="0,1.5" Text="事屑Jerry" />
<TextBlock Width="120" Margin="0,1.5" Text="Oxsheep" /> <TextBlock Width="120" Margin="0,1.5" Text="Rs32" />
<TextBlock Width="120" Margin="0,1.5" Text="Clove_Cloud" /> <TextBlock Width="120" Margin="0,1.5" Text="SPDish" />
<TextBlock Width="120" Margin="0,1.5" Text="今は最高" /> <TextBlock Width="120" Margin="0,1.5" Text="风早九夜" />
<TextBlock Width="120" Margin="0,1.5" Text="YuiuY" /> <TextBlock Width="120" Margin="0,1.5" Text="Reg" />
<TextBlock Width="120" Margin="0,1.5" Text="George0307" /> <TextBlock Width="120" Margin="0,1.5" Text="hellord" />
<TextBlock Width="120" Margin="0,1.5" Text="游子桀" /> <TextBlock Width="120" Margin="0,1.5" Text="时本ki" />
<TextBlock Width="120" Margin="0,1.5" Text="玄之" /> <TextBlock Width="120" Margin="0,1.5" Text="mamana" />
<TextBlock Width="120" Margin="0,1.5" Text="海绵宝宝低顺钠" /> <TextBlock Width="120" Margin="0,1.5" Text="放肆的微笑" />
<TextBlock Width="120" Margin="0,1.5" Text="杜先生" /> <TextBlock Width="120" Margin="0,1.5" Text="人没逝" />
<TextBlock Width="120" Margin="0,1.5" Text="黑火c" /> <TextBlock Width="120" Margin="0,1.5" Text="wddjww" />
<TextBlock Width="120" Margin="0,1.5" Text="落日余音" /> <TextBlock Width="120" Margin="0,1.5" Text="xiao澄" />
<TextBlock Width="120" Margin="0,1.5" Text="mojanng_" /> <TextBlock Width="120" Margin="0,1.5" Text="银狼碎片" />
<TextBlock Width="120" Margin="0,1.5" Text="聿丏" /> <TextBlock Width="120" Margin="0,1.5" Text="OniKata_Kayoko" />
<TextBlock Width="120" Margin="0,1.5" Text="ClarkeTAT" /> <TextBlock Width="120" Margin="0,1.5" Text="曦" />
<TextBlock Width="120" Margin="0,1.5" Text="东方浅浅" /> <TextBlock Width="120" Margin="0,1.5" Text="Echo" />
<TextBlock Width="120" Margin="0,1.5" Text="王ZEAN" /> <TextBlock Width="120" Margin="0,1.5" Text="画卿颜" />
<TextBlock Width="120" Margin="0,1.5" Text="ayu" /> <TextBlock Width="120" Margin="0,1.5" Text="夏 " />
<TextBlock Width="120" Margin="0,1.5" Text="无所畏惧冷圈人" /> <TextBlock Width="120" Margin="0,1.5" Text="jiege45" />
<TextBlock Width="120" Margin="0,1.5" Text="馨軟" /> <TextBlock Width="120" Margin="0,1.5" Text="甜食先生" />
<TextBlock Width="120" Margin="0,1.5" Text="白加黑" /> <TextBlock Width="120" Margin="0,1.5" Text="虚莫妄玄" />
<TextBlock Width="120" Margin="0,1.5" Text="梦境之中" /> <TextBlock Width="120" Margin="0,1.5" Text="天恒" />
<TextBlock Width="120" Margin="0,1.5" Text="青枝望月" /> <TextBlock Width="120" Margin="0,1.5" Text="我有馄饨" />
<TextBlock Width="120" Margin="0,1.5" Text="m1nato__" /> <TextBlock Width="120" Margin="0,1.5" Text="布布曼" />
<TextBlock Width="120" Margin="0,1.5" Text="dingwenbo" /> <TextBlock Width="120" Margin="0,1.5" Text="qwqewe" />
<TextBlock Width="120" Margin="0,1.5" Text="法老" /> <TextBlock Width="120" Margin="0,1.5" Text="114514" />
<TextBlock Width="120" Margin="0,1.5" Text="和十奕" /> <TextBlock Width="120" Margin="0,1.5" Text="YJ_42" />
<TextBlock Width="120" Margin="0,1.5" Text="give" /> <TextBlock Width="120" Margin="0,1.5" Text="Xricron" />
<TextBlock Width="120" Margin="0,1.5" Text="我是只面包猫" /> <TextBlock Width="120" Margin="0,1.5" Text="抛弃大脑" />
<TextBlock Width="120" Margin="0,1.5" Text="柒安" /> <TextBlock Width="120" Margin="0,1.5" Text="10455885" />
<TextBlock Width="120" Margin="0,1.5" Text="YUU" /> <TextBlock Width="120" Margin="0,1.5" Text="羽渡白砂" />
<TextBlock Width="120" Margin="0,1.5" Text="月下初拥" /> <TextBlock Width="120" Margin="0,1.5" Text="沙" />
<TextBlock Width="120" Margin="0,1.5" Text="白叶夕秋" /> <TextBlock Width="120" Margin="0,1.5" Text="sukous" />
<TextBlock Width="120" Margin="0,1.5" Text="酸奶炸鱼" /> <TextBlock Width="120" Margin="0,1.5" Text="册那" />
<TextBlock Width="120" Margin="0,1.5" Text="灵喻" /> <TextBlock Width="120" Margin="0,1.5" Text="KMYLS" />
<TextBlock Width="120" Margin="0,1.5" Text="_暮霭" /> <TextBlock Width="120" Margin="0,1.5" Text="kakadeso" />
<TextBlock Width="120" Margin="0,1.5" Text="TylerDeng" /> <TextBlock Width="120" Margin="0,1.5" Text="懒猫" />
<TextBlock Width="120" Margin="0,1.5" Text="我不在线" /> <TextBlock Width="120" Margin="0,1.5" Text="清岚" />
<TextBlock Width="120" Margin="0,1.5" Text="Hugh" /> <TextBlock Width="120" Margin="0,1.5" Text="Atopos" />
<TextBlock Width="120" Margin="0,1.5" Text="Qiyue" /> <TextBlock Width="120" Margin="0,1.5" Text="苦尽柑来" />
<TextBlock Width="120" Margin="0,1.5" Text="CHAKKS" /> <TextBlock Width="120" Margin="0,1.5" Text="脑洞大开的血魔" />
<TextBlock Width="120" Margin="0,1.5" Text="Silver_1572" /> <TextBlock Width="120" Margin="0,1.5" Text="ももかわるこ" />
<TextBlock Width="120" Margin="0,1.5" Text="WIFTAB" /> <TextBlock Width="120" Margin="0,1.5" Text="空中的风" />
<TextBlock Width="120" Margin="0,1.5" Text="hmal" /> <TextBlock Width="120" Margin="0,1.5" Text="黑夜幽灵" />
<TextBlock Width="120" Margin="0,1.5" Text="通大小学弟" /> <TextBlock Width="120" Margin="0,1.5" Text="H1saNe" />
<TextBlock Width="120" Margin="0,1.5" Text="htenet" /> <TextBlock Width="120" Margin="0,1.5" Text="故风" />
<TextBlock Width="120" Margin="0,1.5" Text="臭氧化碳" />
<TextBlock Width="120" Margin="0,1.5" Text="云阿云" />
<TextBlock Width="120" Margin="0,1.5" Text="小命" />
<TextBlock Width="120" Margin="0,1.5" Text="南宫若兮" />
<TextBlock Width="120" Margin="0,1.5" Text="Landsilde" />
<TextBlock Width="120" Margin="0,1.5" Text="zzz" />
<TextBlock Width="120" Margin="0,1.5" Text="星期三" />
<TextBlock Width="120" Margin="0,1.5" Text="Ashburn" />
<TextBlock Width="120" Margin="0,1.5" Text="123" />
<TextBlock Width="120" Margin="0,1.5" Text="九日" />
<TextBlock Width="120" Margin="0,1.5" Text="古神" />
<TextBlock Width="120" Margin="0,1.5" Text="月宫星耀" />
<TextBlock Width="120" Margin="0,1.5" Text="郁子恒是FW" />
<TextBlock Width="240" Margin="0,1.5" Text="每天吃吃吃吃吃不饱" />
<TextBlock Width="120" Margin="0,1.5" Text="Freezhao" />
<TextBlock Width="120" Margin="0,1.5" Text="ZHypocrite" />
<TextBlock Width="120" Margin="0,1.5" Text="十下小雨" />
<TextBlock Width="120" Margin="0,1.5" Text="九 十" />
<TextBlock Width="120" Margin="0,1.5" Text="RuthlessXdream" />
<TextBlock Width="120" Margin="0,1.5" Text="zv-vz" />
<TextBlock Width="120" Margin="0,1.5" Text="汐沄的随记" />
<TextBlock Width="120" Margin="0,1.5" Text="REMOTE" />
<TextBlock Width="120" Margin="0,1.5" Text="昔阳" />
<TextBlock Width="120" Margin="0,1.5" Text="七度ユキノ" />
<TextBlock Width="120" Margin="0,1.5" Text="KNISX" />
<TextBlock Width="120" Margin="0,1.5" Text="RainbowDashRD" />
<TextBlock Width="120" Margin="0,1.5" Text="夢曦" />
<TextBlock Width="120" Margin="0,1.5" Text="跳雨风" />
<TextBlock Width="120" Margin="0,1.5" Text="望言苏" />
<TextBlock Width="120" Margin="0,1.5" Text="四分白Fortenz" />
<TextBlock Width="120" Margin="0,1.5" Text="UUZ" />
<TextBlock Width="120" Margin="0,1.5" Text="Ankairis" />
<TextBlock Width="120" Margin="0,1.5" Text="Jn1E" />
<TextBlock Width="120" Margin="0,1.5" Text="云山如昨好" />
<TextBlock Width="120" Margin="0,1.5" Text="LYJ0415" />
<TextBlock Width="120" Margin="0,1.5" Text="空?" />
<TextBlock Width="120" Margin="0,1.5" Text="Awfrlu+" />
<TextBlock Width="120" Margin="0,1.5" Text="懒帝" />
<TextBlock Width="120" Margin="0,1.5" Text="北安丶七叔" />
<TextBlock Width="120" Margin="0,1.5" Text="xkw" />
<TextBlock Width="120" Margin="0,1.5" Text="KINO" />
<TextBlock Width="120" Margin="0,1.5" Text="POTATO" />
<TextBlock Width="120" Margin="0,1.5" Text="少昊氏" />
<TextBlock Width="240" Margin="0,1.5" Text="狂踹瘸子那條好腿丶" />
<TextBlock Width="240" Margin="0,1.5" Text="Thallium_Ash【铊尘】(坨坨)" />
<TextBlock Width="120" Margin="0,1.5" Text="陌雨泠涯" />
<TextBlock Width="120" Margin="0,1.5" Text="bajie79" />
<TextBlock Width="120" Margin="0,1.5" Text="紘垰" />
</WrapPanel> </WrapPanel>
<Grid Height="35"> <Grid Height="35">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
@@ -309,11 +358,13 @@
</Grid> </Grid>
</StackPanel> </StackPanel>
</local:MyCard> </local:MyCard>
<local:MyCard Margin="0,0,0,15" Title="法律信息" IsSwaped="True" CanSwap="True"> <local:MyCard Margin="0,0,0,15" Title="法律信息" IsSwapped="True" CanSwap="True">
<StackPanel Margin="25,39,23,20"> <StackPanel Margin="25,39,23,20">
<TextBlock Text="隐私说明" TextWrapping="Wrap" Margin="0,6,0,4" FontWeight="Bold" /> <TextBlock Text="匿名数据收集" TextWrapping="Wrap" Margin="0,6,0,4" FontWeight="Bold" />
<TextBlock Margin="0,0,0,2" LineHeight="17" Text="本软件的 User Agent 中包含启动器的版本号,以统计各版本的用户数量。&#13;除此之外,本软件不会向开发者上传任何其他信息。" TextWrapping="Wrap" /> <TextBlock Margin="0,0,0,2" LineHeight="17" Text="当下载失败、PCL 出错、游戏崩溃等事件时,PCL 会匿名上报信息,以通知龙猫 “哦吼,出错了”,让龙猫能更好地修 Bug……(PCL 不会上传或收集任何个人信息,包括上报的东西里面也没有!)&#xa;你可以在 设置 → 其他 → 启动器 中关闭上报,不过龙猫就不知道你遇到了什么 Bug 了……" TextWrapping="Wrap" />
<TextBlock Text="其他信息" TextWrapping="Wrap" Margin="0,12,0,4" FontWeight="Bold" /> <TextBlock Text="隐私声明与个人信息保护政策" TextWrapping="Wrap" Margin="0,10,0,4" FontWeight="Bold" />
<TextBlock Margin="0,0,0,2" LineHeight="17" Text="PCL 没有收集个人信息,所以这里其实啥都不用写……&#xa;留个这个其实只是为了让你知道 PCL 没有收集个人信息,诶嘿。" TextWrapping="Wrap" />
<TextBlock Text="其他信息" TextWrapping="Wrap" Margin="0,10,0,4" FontWeight="Bold" />
<TextBlock Margin="0,0,0,2" LineHeight="17" Text="Copyright © 龙腾猫跃 2016. All Rights Reserved.&#13;计算机软件著作权登记号:2020SR0875133&#13;违法违规行为举报投诉邮箱:hexdragon@vip.qq.com&#13;非 MINECRAFT 官方产品。未经 MOJANG 或 MICROSOFT 批准,也不与 MOJANG 或 MICROSOFT 关联。" TextWrapping="Wrap" /> <TextBlock Margin="0,0,0,2" LineHeight="17" Text="Copyright © 龙腾猫跃 2016. All Rights Reserved.&#13;计算机软件著作权登记号:2020SR0875133&#13;违法违规行为举报投诉邮箱:hexdragon@vip.qq.com&#13;非 MINECRAFT 官方产品。未经 MOJANG 或 MICROSOFT 批准,也不与 MOJANG 或 MICROSOFT 关联。" TextWrapping="Wrap" />
<StackPanel Orientation="Horizontal" Height="35" HorizontalAlignment="Left" Margin="0,12,0,0"> <StackPanel Orientation="Horizontal" Height="35" HorizontalAlignment="Left" Margin="0,12,0,0">
<local:MyButton Text="用户协议与免责声明" Width="170" Padding="13,0" Margin="0,0,20,0" ColorType="Highlight" EventType="打开网页" EventData="https://shimo.im/docs/rGrd8pY8xWkt6ryW" /> <local:MyButton Text="用户协议与免责声明" Width="170" Padding="13,0" Margin="0,0,20,0" ColorType="Highlight" EventType="打开网页" EventData="https://shimo.im/docs/rGrd8pY8xWkt6ryW" />
@@ -321,7 +372,7 @@
</StackPanel> </StackPanel>
</StackPanel> </StackPanel>
</local:MyCard> </local:MyCard>
<local:MyCard Margin="0,0,0,15" Title="许可与版权声明" IsSwaped="True" CanSwap="True"> <local:MyCard Margin="0,0,0,15" Title="许可与版权声明" IsSwapped="True" CanSwap="True">
<Grid Margin="25,42,23,4"> <Grid Margin="25,42,23,4">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" /> <ColumnDefinition Width="Auto" />
@@ -7,7 +7,7 @@
PanBack.ScrollToHome() PanBack.ScrollToHome()
'非重复加载部分 '非重复加载部分
If IsLoaded Then Exit Sub If IsLoaded Then Return
IsLoaded = True IsLoaded = True
ItemAboutPcl.Info = ItemAboutPcl.Info.Replace("%VERSION%", VersionDisplayName).Replace("%VERSIONCODE%", VersionCode).Replace("%BRANCH%", VersionBranchCode) ItemAboutPcl.Info = ItemAboutPcl.Info.Replace("%VERSION%", VersionDisplayName).Replace("%VERSIONCODE%", VersionCode).Replace("%BRANCH%", VersionBranchCode)
@@ -18,12 +18,6 @@
End Sub End Sub
Private Sub BtnAboutBmclapi_Click(sender As Object, e As EventArgs) Handles BtnAboutBmclapi.Click
OpenWebsite("https://afdian.com/a/bangbang93")
End Sub
Private Sub BtnAboutWiki_Click(sender As Object, e As EventArgs) Handles BtnAboutWiki.Click
OpenWebsite("https://www.mcmod.cn")
End Sub
Public Shared Sub CopyUniqueAddress() Handles BtnDonateCopy.Click Public Shared Sub CopyUniqueAddress() Handles BtnDonateCopy.Click
ClipboardSet(UniqueAddress) ClipboardSet(UniqueAddress)
End Sub End Sub
@@ -55,7 +55,7 @@
If Type = "指南" Then If Type = "指南" Then
MyCard.StackInstall(NewStack, 11, "指南") MyCard.StackInstall(NewStack, 11, "指南")
Else Else
NewCard.IsSwaped = True NewCard.IsSwapped = True
End If End If
PanList.Children.Add(NewCard) PanList.Children.Add(NewCard)
Next Next
@@ -10,12 +10,12 @@
If ItemTest.Checked AndAlso Setup.Get("UiHiddenOtherTest") Then IsHiddenPage = True If ItemTest.Checked AndAlso Setup.Get("UiHiddenOtherTest") Then IsHiddenPage = True
If PageSetupUI.HiddenForceShow Then IsHiddenPage = False If PageSetupUI.HiddenForceShow Then IsHiddenPage = False
'若页面错误,或尚未加载,则继续 '若页面错误,或尚未加载,则继续
If IsLoad AndAlso Not IsHiddenPage Then Exit Sub If IsLoad AndAlso Not IsHiddenPage Then Return
IsLoad = True IsLoad = True
'刷新子页面隐藏情况 '刷新子页面隐藏情况
PageSetupUI.HiddenRefresh() PageSetupUI.HiddenRefresh()
'选择第一个未被禁用的子页面 '选择第一个未被禁用的子页面
If IsPageSwitched Then Exit Sub If IsPageSwitched Then Return
If Not Setup.Get("UiHiddenOtherHelp") Then If Not Setup.Get("UiHiddenOtherHelp") Then
ItemHelp.SetChecked(True, False, False) ItemHelp.SetChecked(True, False, False)
ElseIf Not Setup.Get("UiHiddenOtherAbout") Then ElseIf Not Setup.Get("UiHiddenOtherAbout") Then
@@ -76,7 +76,7 @@
''' 切换现有页面。 ''' 切换现有页面。
''' </summary> ''' </summary>
Public Sub PageChange(ID As FormMain.PageSubType) Public Sub PageChange(ID As FormMain.PageSubType)
If PageID = ID Then Exit Sub If PageID = ID Then Return
AniControlEnabled += 1 AniControlEnabled += 1
IsPageSwitched = True IsPageSwitched = True
Try Try
@@ -126,29 +126,29 @@
'打开网页 '打开网页
Private Sub TryFeedback(sender As Object, e As RouteEventArgs) Handles ItemFeedback.Changed Private Sub TryFeedback(sender As Object, e As RouteEventArgs) Handles ItemFeedback.Changed
If Not ItemFeedback.Checked Then Exit Sub If Not ItemFeedback.Checked Then Return
TryFeedback() TryFeedback()
e.Handled = True e.Handled = True
End Sub End Sub
Public Shared Sub TryFeedback() Public Shared Sub TryFeedback()
If Not CanFeedback(True) Then Exit Sub If Not CanFeedback(True) Then Return
Select Case MyMsgBox("在提交新反馈前,建议先搜索反馈列表,以避免重复提交。" & vbCrLf & "如果无法打开该网页,请尝试使用加速器或 VPN。", Select Case MyMsgBox("在提交新反馈前,建议先搜索反馈列表,以避免重复提交。" & vbCrLf & "如果无法打开该网页,请使用 VPN 以改善网络环境。",
"反馈", "提交新反馈", "查看反馈列表", "取消") "反馈", "提交新反馈", "查看反馈列表", "取消")
Case 1 Case 1
Feedback(True, False) Feedback(True, False)
Case 2 Case 2
OpenWebsite("https://github.com/Hex-Dragon/PCL2/issues/") OpenWebsite("https://github.com/Meloong-Git/PCL/issues/")
End Select End Select
End Sub End Sub
Private Sub TryVote(sender As Object, e As RouteEventArgs) Handles ItemVote.Changed Private Sub TryVote(sender As Object, e As RouteEventArgs) Handles ItemVote.Changed
If Not ItemVote.Checked Then Exit Sub If Not ItemVote.Checked Then Return
TryVote() TryVote()
e.Handled = True e.Handled = True
End Sub End Sub
Public Shared Sub TryVote() Public Shared Sub TryVote()
If MyMsgBox("是否要打开新功能投票网页?" & vbCrLf & "如果无法打开该网页,请尝试使用加速器或 VPN。", If MyMsgBox("是否要打开新功能投票网页?" & vbCrLf & "如果无法打开该网页,请使用 VPN 以改善网络环境。",
"新功能投票", "打开", "取消") = 2 Then Exit Sub "新功能投票", "打开", "取消") = 2 Then Return
OpenWebsite("https://github.com/Hex-Dragon/PCL2/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8?discussions_q=category%3A%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8+sort%3Adate_created") OpenWebsite("https://github.com/Meloong-Git/PCL/discussions/categories/%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8?discussions_q=category%3A%E5%8A%9F%E8%83%BD%E6%8A%95%E7%A5%A8+sort%3Adate_created")
End Sub End Sub
End Class End Class
@@ -21,7 +21,7 @@
Exit For Exit For
End If End If
Next Next
If IsEqual Then Exit Sub If IsEqual Then Return
End If End If
McFolderListLast = McFolderList McFolderListLast = McFolderList
@@ -127,7 +127,7 @@
For i = 0 To McFolderList.Count - 1 For i = 0 To McFolderList.Count - 1
If McFolderList(i).Path = PathMcFolder Then If McFolderList(i).Path = PathMcFolder Then
CType(FrmSelectLeft.PanList.Children(i + 1), MyListItem).Checked = True '去掉第一个标题 CType(FrmSelectLeft.PanList.Children(i + 1), MyListItem).Checked = True '去掉第一个标题
Exit Sub Return
End If End If
Next Next
If Not McFolderList.Any() Then If Not McFolderList.Any() Then
@@ -151,20 +151,20 @@
'检查是否有下载任务 '检查是否有下载任务
If HasDownloadingTask() Then If HasDownloadingTask() Then
Hint("在下载任务进行时,无法添加游戏文件夹!", HintType.Critical) Hint("在下载任务进行时,无法添加游戏文件夹!", HintType.Critical)
Exit Sub Return
End If End If
Try Try
'获取输入 '获取输入
NewFolder = SelectFolder() NewFolder = SelectFolder()
If NewFolder = "" Then Exit Sub If NewFolder = "" Then Return
If NewFolder.Contains("!") OrElse NewFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号!", HintType.Critical) : Exit Sub If NewFolder.Contains("!") OrElse NewFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号!", HintType.Critical) : Return
'要求输入显示名称 '要求输入显示名称
Dim SplitedNames As String() = NewFolder.TrimEnd("\").Split("\") Dim SplitedNames As String() = NewFolder.TrimEnd("\").Split("\")
Dim DefaultName As String = If(SplitedNames.Last = ".minecraft", If(SplitedNames.Count >= 3, SplitedNames(SplitedNames.Count - 2), ""), SplitedNames.Last) Dim DefaultName As String = If(SplitedNames.Last = ".minecraft", If(SplitedNames.Count >= 3, SplitedNames(SplitedNames.Count - 2), ""), SplitedNames.Last)
If DefaultName.Length > 40 Then DefaultName = DefaultName.Substring(0, 39) If DefaultName.Length > 40 Then DefaultName = DefaultName.Substring(0, 39)
Dim NewName As String = MyMsgBoxInput("输入显示名称", "输入该文件夹在左边栏列表中显示的名称。", DefaultName, Dim NewName As String = MyMsgBoxInput("输入显示名称", "输入该文件夹在左边栏列表中显示的名称。", DefaultName,
New ObjectModel.Collection(Of Validate) From {New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})}) New ObjectModel.Collection(Of Validate) From {New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})})
If String.IsNullOrWhiteSpace(NewName) Then Exit Sub If String.IsNullOrWhiteSpace(NewName) Then Return
'添加文件夹 '添加文件夹
AddFolder(NewFolder, NewName, True) AddFolder(NewFolder, NewName, True)
Catch ex As Exception Catch ex As Exception
@@ -183,7 +183,7 @@
If Not CheckPermission(FolderPath) Then If Not CheckPermission(FolderPath) Then
If ShowHint Then If ShowHint Then
Hint("添加文件夹失败:PCL 没有访问该文件夹的权限!", HintType.Critical) Hint("添加文件夹失败:PCL 没有访问该文件夹的权限!", HintType.Critical)
Exit Sub Return
Else Else
Throw New Exception("PCL 没有访问文件夹的权限:" & FolderPath) Throw New Exception("PCL 没有访问文件夹的权限:" & FolderPath)
End If End If
@@ -208,7 +208,7 @@
IsAdded = True IsAdded = True
If Folder.Split(">")(0) = DisplayName Then If Folder.Split(">")(0) = DisplayName Then
If ShowHint Then Hint("此文件夹已在列表中!", HintType.Info) If ShowHint Then Hint("此文件夹已在列表中!", HintType.Info)
Exit Sub Return
Else Else
Folders(i) = DisplayName & ">" & FolderPath Folders(i) = DisplayName & ">" & FolderPath
IsReplace = True IsReplace = True
@@ -225,15 +225,15 @@
Setup.Set("LaunchFolderSelect", FolderPath.Replace(Path, "$")) Setup.Set("LaunchFolderSelect", FolderPath.Replace(Path, "$"))
McFolderListLoader.Start(IsForceRestart:=True) McFolderListLoader.Start(IsForceRestart:=True)
'提示 '提示
If IsReplace Then Exit Sub If IsReplace Then Return
If ShowHint Then Hint("文件夹 " & DisplayName & " 已添加!", HintType.Finish) If ShowHint Then Hint("文件夹 " & DisplayName & " 已添加!", HintType.Finish)
'检查是否为根目录整合包,自动关闭版本隔离 '检查是否为根目录整合包,自动关闭版本隔离
'1. 根目录中存在数个 Mod '1. 根目录中存在数个 Mod
Dim ModFolder As New DirectoryInfo(FolderPath & "mods\") Dim ModFolder As New DirectoryInfo(FolderPath & "mods\")
If Not (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Count >= 3) Then Exit Sub If Not (ModFolder.Exists AndAlso ModFolder.EnumerateFiles.Count >= 3) Then Return
'2. 版本数较少,可能为整合包 '2. 版本数较少,可能为整合包
Dim VersionFolder As New DirectoryInfo(FolderPath & "versions\") Dim VersionFolder As New DirectoryInfo(FolderPath & "versions\")
If Not (VersionFolder.Exists AndAlso VersionFolder.EnumerateDirectories.Count <= 3) Then Exit Sub If Not (VersionFolder.Exists AndAlso VersionFolder.EnumerateDirectories.Count <= 3) Then Return
'3. 能够找到可安装 Mod 的版本 '3. 能够找到可安装 Mod 的版本
For Each VersionPath In VersionFolder.EnumerateDirectories For Each VersionPath In VersionFolder.EnumerateDirectories
Dim Version As New McVersion(VersionPath.FullName) Dim Version As New McVersion(VersionPath.FullName)
@@ -241,7 +241,7 @@
If Not Version.Modable Then Continue For If Not Version.Modable Then Continue For
'4. 该版本的隔离文件夹下不存在 mods '4. 该版本的隔离文件夹下不存在 mods
Dim ModIndieFolder As New DirectoryInfo(Version.Path & "mods\") Dim ModIndieFolder As New DirectoryInfo(Version.Path & "mods\")
If ModIndieFolder.Exists AndAlso ModIndieFolder.EnumerateFiles.Any Then Exit Sub If ModIndieFolder.Exists AndAlso ModIndieFolder.EnumerateFiles.Any Then Return
'满足以上全部条件则视为根目录整合包 '满足以上全部条件则视为根目录整合包
Setup.Set("VersionArgumentIndie", 2, Version:=Version) Setup.Set("VersionArgumentIndie", 2, Version:=Version)
Setup.Set("VersionArgumentIndieV2", False, Version:=Version) Setup.Set("VersionArgumentIndieV2", False, Version:=Version)
@@ -258,7 +258,7 @@
'检查是否有下载任务 '检查是否有下载任务
If HasDownloadingTask() Then If HasDownloadingTask() Then
Hint("在下载任务进行时,无法创建游戏文件夹!", HintType.Critical) Hint("在下载任务进行时,无法创建游戏文件夹!", HintType.Critical)
Exit Sub Return
End If End If
If Not Directory.Exists(Path & ".minecraft\") Then If Not Directory.Exists(Path & ".minecraft\") Then
Directory.CreateDirectory(Path & ".minecraft\") Directory.CreateDirectory(Path & ".minecraft\")
@@ -290,7 +290,7 @@
'不删除 '不删除
Case 3 Case 3
'取消 '取消
Exit Sub Return
End Select End Select
End If End If
'若修改了本部分代码,应对应修改 Delete_Click 中的代码 '若修改了本部分代码,应对应修改 Delete_Click 中的代码
@@ -317,8 +317,8 @@
Public Sub Delete_Click(sender As Object, e As RoutedEventArgs) Public Sub Delete_Click(sender As Object, e As RoutedEventArgs)
Dim Folder As McFolder = CType(CType(CType(sender.Parent, ContextMenu).Parent, Primitives.Popup).PlacementTarget, MyListItem).Tag Dim Folder As McFolder = CType(CType(CType(sender.Parent, ContextMenu).Parent, Primitives.Popup).PlacementTarget, MyListItem).Tag
Dim DeleteText As String = If((Folder.Type = McFolderType.Original OrElse Folder.Type = McFolderType.RenamedOriginal) AndAlso Folder.Path = Path & ".minecraft\" AndAlso McFolderList.Count = 1, "清空", "删除") Dim DeleteText As String = If((Folder.Type = McFolderType.Original OrElse Folder.Type = McFolderType.RenamedOriginal) AndAlso Folder.Path = Path & ".minecraft\" AndAlso McFolderList.Count = 1, "清空", "删除")
If MyMsgBox("你确定要" & DeleteText & "这个文件夹吗?" & vbCrLf & "目标文件夹:" & Folder.Path & vbCrLf & vbCrLf & "这会导致该文件夹中的所有存档与其他文件永久丢失,且不可恢复!", "删除警告", "取消", "确认", "取消") <> 2 Then Exit Sub If MyMsgBox("你确定要" & DeleteText & "这个文件夹吗?" & vbCrLf & "目标文件夹:" & Folder.Path & vbCrLf & vbCrLf & "这会导致该文件夹中的所有存档与其他文件永久丢失,且不可恢复!", "删除警告", "取消", "确认", "取消") <> 2 Then Return
If MyMsgBox("如果你在该文件夹中存放了除 MC 以外的其他文件,这些文件也会被一同删除!" & vbCrLf & "继续删除会导致该文件夹中的所有文件永久丢失,请在仔细确认后再继续!" & vbCrLf & "目标文件夹:" & Folder.Path & vbCrLf & vbCrLf & "这是最后一次警告!", "删除警告", "确认" & DeleteText, "取消", IsWarn:=True) <> 1 Then Exit Sub If MyMsgBox("如果你在该文件夹中存放了除 MC 以外的其他文件,这些文件也会被一同删除!" & vbCrLf & "继续删除会导致该文件夹中的所有文件永久丢失,请在仔细确认后再继续!" & vbCrLf & "目标文件夹:" & Folder.Path & vbCrLf & vbCrLf & "这是最后一次警告!", "删除警告", "确认" & DeleteText, "取消", IsWarn:=True) <> 1 Then Return
'移出列表 '移出列表
If Folder.Type = McFolderType.Custom Then If Folder.Type = McFolderType.Custom Then
Dim Folders As New List(Of String)(Setup.Get("LaunchFolders").ToString.Split("|")) Dim Folders As New List(Of String)(Setup.Get("LaunchFolders").ToString.Split("|"))
@@ -369,7 +369,7 @@
Dim NewName As String = Dim NewName As String =
MyMsgBoxInput("输入新名称", "", Folder.Name, MyMsgBoxInput("输入新名称", "", Folder.Name,
New ObjectModel.Collection(Of Validate) From {New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})}) New ObjectModel.Collection(Of Validate) From {New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})})
If String.IsNullOrWhiteSpace(NewName) Then Exit Sub If String.IsNullOrWhiteSpace(NewName) Then Return
'修改自定义名 '修改自定义名
Dim Folders As New List(Of String)(Setup.Get("LaunchFolders").ToString.Split("|")) Dim Folders As New List(Of String)(Setup.Get("LaunchFolders").ToString.Split("|"))
Dim IsAdded As Boolean = False Dim IsAdded As Boolean = False
@@ -380,7 +380,7 @@
IsAdded = True IsAdded = True
If FolderCurrent.Split(">")(0) = NewName Then If FolderCurrent.Split(">")(0) = NewName Then
'名称未修改 '名称未修改
Exit Sub Return
Else Else
Folders(i) = NewName & ">" & Folder.Path Folders(i) = NewName & ">" & Folder.Path
End If End If
@@ -400,12 +400,12 @@
'点击选项 '点击选项
Public Sub Folder_Change(sender As MyListItem, e As RouteEventArgs) Public Sub Folder_Change(sender As MyListItem, e As RouteEventArgs)
If Not e.RaiseByMouse OrElse Not sender.Checked Then Exit Sub If Not e.RaiseByMouse OrElse Not sender.Checked Then Return
'检查是否有下载任务 '检查是否有下载任务
If HasDownloadingTask(True) Then If HasDownloadingTask(True) Then
Hint("在下载任务进行时,无法切换游戏文件夹!", HintType.Critical) Hint("在下载任务进行时,无法切换游戏文件夹!", HintType.Critical)
e.Handled = True e.Handled = True
Exit Sub Return
End If End If
'更换 '更换
Setup.Set("LaunchFolderSelect", CType(sender.Tag, McFolder).Path.Replace(Path, "$")) Setup.Set("LaunchFolderSelect", CType(sender.Tag, McFolder).Path.Replace(Path, "$"))
@@ -81,15 +81,15 @@
PanMain.Children.Add(NewCard) PanMain.Children.Add(NewCard)
'确定卡片是否展开 '确定卡片是否展开
If Card.Key = McVersionCardType.Rubbish OrElse Card.Key = McVersionCardType.Error OrElse Card.Key = McVersionCardType.Fool Then If Card.Key = McVersionCardType.Rubbish OrElse Card.Key = McVersionCardType.Error OrElse Card.Key = McVersionCardType.Fool Then
NewCard.IsSwaped = True NewCard.IsSwapped = True
Else Else
MyCard.StackInstall(NewStack, 0, CardTitle) MyCard.StackInstall(NewStack, 0, CardTitle)
End If End If
Next Next
'若只有一个卡片,则强制展开 '若只有一个卡片,则强制展开
If PanMain.Children.Count = 1 AndAlso CType(PanMain.Children(0), MyCard).IsSwaped Then If PanMain.Children.Count = 1 AndAlso CType(PanMain.Children(0), MyCard).IsSwapped Then
CType(PanMain.Children(0), MyCard).IsSwaped = False CType(PanMain.Children(0), MyCard).IsSwapped = False
End If End If
'判断应该显示哪一个页面 '判断应该显示哪一个页面
@@ -227,11 +227,11 @@
DeleteDirectory(Version.Path) DeleteDirectory(Version.Path)
Hint("版本 " & Version.Name & " 已永久删除!", HintType.Finish) Hint("版本 " & Version.Name & " 已永久删除!", HintType.Finish)
Else Else
FileIO.FileSystem.DeleteDirectory(Version.Path, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin) FileIO.FileSystem.DeleteDirectory(Version.Path, FileIO.UIOption.AllDialogs, FileIO.RecycleOption.SendToRecycleBin)
Hint("版本 " & Version.Name & " 已删除到回收站!", HintType.Finish) Hint("版本 " & Version.Name & " 已删除到回收站!", HintType.Finish)
End If End If
Case 2 Case 2
Exit Sub Return
End Select End Select
'从 UI 中移除 '从 UI 中移除
If Version.DisplayType = McVersionCardType.Hidden OrElse Not Version.IsStar Then If Version.DisplayType = McVersionCardType.Hidden OrElse Not Version.IsStar Then
@@ -14,7 +14,6 @@
{"HintDownloadThread", New SetupEntry(False, Source:=SetupSource.Registry)}, {"HintDownloadThread", New SetupEntry(False, Source:=SetupSource.Registry)},
{"HintNotice", New SetupEntry(0, Source:=SetupSource.Registry)}, {"HintNotice", New SetupEntry(0, Source:=SetupSource.Registry)},
{"HintDownload", New SetupEntry(0, Source:=SetupSource.Registry)}, {"HintDownload", New SetupEntry(0, Source:=SetupSource.Registry)},
{"HintInstallBack", New SetupEntry(False, Source:=SetupSource.Registry)},
{"HintHide", New SetupEntry(False, Source:=SetupSource.Registry)}, {"HintHide", New SetupEntry(False, Source:=SetupSource.Registry)},
{"HintHandInstall", New SetupEntry(False, Source:=SetupSource.Registry)}, {"HintHandInstall", New SetupEntry(False, Source:=SetupSource.Registry)},
{"HintBuy", New SetupEntry(False, Source:=SetupSource.Registry)}, {"HintBuy", New SetupEntry(False, Source:=SetupSource.Registry)},
@@ -42,6 +41,7 @@
{"SystemSystemCache", New SetupEntry("", Source:=SetupSource.Registry)}, {"SystemSystemCache", New SetupEntry("", Source:=SetupSource.Registry)},
{"SystemSystemUpdate", New SetupEntry(0)}, {"SystemSystemUpdate", New SetupEntry(0)},
{"SystemSystemActivity", New SetupEntry(0)}, {"SystemSystemActivity", New SetupEntry(0)},
{"SystemSystemTelemetry", New SetupEntry(True, Source:=SetupSource.Registry)},
{"CacheExportConfig", New SetupEntry("", Source:=SetupSource.Registry)}, {"CacheExportConfig", New SetupEntry("", Source:=SetupSource.Registry)},
{"CacheSavedPageUrl", New SetupEntry("", Source:=SetupSource.Registry)}, {"CacheSavedPageUrl", New SetupEntry("", Source:=SetupSource.Registry)},
{"CacheSavedPageVersion", New SetupEntry("", Source:=SetupSource.Registry)}, {"CacheSavedPageVersion", New SetupEntry("", Source:=SetupSource.Registry)},
@@ -124,7 +124,7 @@
{"ToolDownloadTranslateV2", New SetupEntry(1, Source:=SetupSource.Registry)}, {"ToolDownloadTranslateV2", New SetupEntry(1, Source:=SetupSource.Registry)},
{"ToolDownloadIgnoreQuilt", New SetupEntry(True, Source:=SetupSource.Registry)}, {"ToolDownloadIgnoreQuilt", New SetupEntry(True, Source:=SetupSource.Registry)},
{"ToolDownloadCert", New SetupEntry(False, Source:=SetupSource.Registry)}, {"ToolDownloadCert", New SetupEntry(False, Source:=SetupSource.Registry)},
{"ToolDownloadMod", New SetupEntry(1, Source:=SetupSource.Registry)}, {"ToolDownloadMod", New SetupEntry(2, Source:=SetupSource.Registry)},
{"ToolModLocalNameStyle", New SetupEntry(0, Source:=SetupSource.Registry)}, {"ToolModLocalNameStyle", New SetupEntry(0, Source:=SetupSource.Registry)},
{"ToolUpdateAlpha", New SetupEntry(0, Source:=SetupSource.Registry, Encoded:=True)}, {"ToolUpdateAlpha", New SetupEntry(0, Source:=SetupSource.Registry, Encoded:=True)},
{"ToolUpdateRelease", New SetupEntry(False, Source:=SetupSource.Registry)}, {"ToolUpdateRelease", New SetupEntry(False, Source:=SetupSource.Registry)},
@@ -246,7 +246,7 @@
Value = CTypeDynamic(Value, E.Type) Value = CTypeDynamic(Value, E.Type)
If E.State = 2 Then If E.State = 2 Then
'如果已应用,且值相同,则无需再次更改 '如果已应用,且值相同,则无需再次更改
If E.Value = Value AndAlso Not ForceReload Then Exit Sub If E.Value = Value AndAlso Not ForceReload Then Return
Else Else
'如果未应用,则直接更改并应用 '如果未应用,则直接更改并应用
If E.Source <> SetupSource.Version Then E.State = 2 If E.Source <> SetupSource.Version Then E.State = 2
@@ -363,7 +363,7 @@
''' </summary> ''' </summary>
Private Sub Read(Key As String, ByRef E As SetupEntry, Version As McVersion) Private Sub Read(Key As String, ByRef E As SetupEntry, Version As McVersion)
Try Try
If Not E.State = 0 Then Exit Sub If Not E.State = 0 Then Return
Dim SourceValue As String = Nothing '先用 String 储存,避免类型转换 Dim SourceValue As String = Nothing '先用 String 储存,避免类型转换
Select Case E.Source Select Case E.Source
Case SetupSource.Normal Case SetupSource.Normal
@@ -423,7 +423,7 @@
'游戏内存 '游戏内存
Public Sub LaunchRamType(Type As Integer) Public Sub LaunchRamType(Type As Integer)
If FrmSetupLaunch Is Nothing Then Exit Sub If FrmSetupLaunch Is Nothing Then Return
FrmSetupLaunch.RamType(Type) FrmSetupLaunch.RamType(Type)
End Sub End Sub
@@ -494,11 +494,9 @@
Public Sub UiLauncherTransparent(Value As Integer) Public Sub UiLauncherTransparent(Value As Integer)
FrmMain.Opacity = Value / 1000 + 0.4 FrmMain.Opacity = Value / 1000 + 0.4
End Sub End Sub
#If Not BETA Then
Public Sub UiLauncherTheme(Value As Integer) Public Sub UiLauncherTheme(Value As Integer)
ThemeRefresh(Value) ThemeRefresh(Value)
End Sub End Sub
#End If
Public Sub UiBackgroundColorful(Value As Boolean) Public Sub UiBackgroundColorful(Value As Boolean)
ThemeRefresh() ThemeRefresh()
End Sub End Sub
@@ -516,7 +514,7 @@
FrmMain.ImgBack.Margin = New Thickness(-(Value + 1) / 1.8) FrmMain.ImgBack.Margin = New Thickness(-(Value + 1) / 1.8)
End Sub End Sub
Public Sub UiBackgroundSuit(Value As Integer) Public Sub UiBackgroundSuit(Value As Integer)
If IsNothing(FrmMain.ImgBack.Background) Then Exit Sub If IsNothing(FrmMain.ImgBack.Background) Then Return
Dim Width As Double = CType(FrmMain.ImgBack.Background, ImageBrush).ImageSource.Width Dim Width As Double = CType(FrmMain.ImgBack.Background, ImageBrush).ImageSource.Width
Dim Height As Double = CType(FrmMain.ImgBack.Background, ImageBrush).ImageSource.Height Dim Height As Double = CType(FrmMain.ImgBack.Background, ImageBrush).ImageSource.Height
If Value = 0 Then If Value = 0 Then
@@ -587,7 +585,7 @@
'主页 '主页
Public Sub UiCustomType(Value As Integer) Public Sub UiCustomType(Value As Integer)
If FrmSetupUI Is Nothing Then Exit Sub If FrmSetupUI Is Nothing Then Return
Select Case Value Select Case Value
Case 0 '无 Case 0 '无
FrmSetupUI.PanCustomPreset.Visibility = Visibility.Collapsed FrmSetupUI.PanCustomPreset.Visibility = Visibility.Collapsed
@@ -612,7 +610,7 @@
FrmSetupUI.HintCustomWarn.Visibility = If(Setup.Get("HintCustomWarn"), Visibility.Collapsed, Visibility.Visible) FrmSetupUI.HintCustomWarn.Visibility = If(Setup.Get("HintCustomWarn"), Visibility.Collapsed, Visibility.Visible)
FrmSetupUI.HintCustom.Text = $"从指定网址联网获取主页内容。服主也可以用于动态更新服务器公告。{vbCrLf}如果你制作了稳定运行的联网主页,可以点击这条提示投稿,若合格即可加入预设!" FrmSetupUI.HintCustom.Text = $"从指定网址联网获取主页内容。服主也可以用于动态更新服务器公告。{vbCrLf}如果你制作了稳定运行的联网主页,可以点击这条提示投稿,若合格即可加入预设!"
FrmSetupUI.HintCustom.EventType = "打开网页" FrmSetupUI.HintCustom.EventType = "打开网页"
FrmSetupUI.HintCustom.EventData = "https://github.com/Hex-Dragon/PCL2/discussions/2528" FrmSetupUI.HintCustom.EventData = "https://github.com/Meloong-Git/PCL/discussions/2528"
Case 3 '预设 Case 3 '预设
FrmSetupUI.PanCustomPreset.Visibility = Visibility.Visible FrmSetupUI.PanCustomPreset.Visibility = Visibility.Visible
FrmSetupUI.PanCustomLocal.Visibility = Visibility.Collapsed FrmSetupUI.PanCustomLocal.Visibility = Visibility.Collapsed
@@ -749,16 +747,16 @@
'游戏内存 '游戏内存
Public Sub VersionRamType(Type As Integer) Public Sub VersionRamType(Type As Integer)
If FrmVersionSetup Is Nothing Then Exit Sub If FrmVersionSetup Is Nothing Then Return
FrmVersionSetup.RamType(Type) FrmVersionSetup.RamType(Type)
End Sub End Sub
'服务器 '服务器
Public Sub VersionServerLogin(Type As Integer) Public Sub VersionServerLogin(Type As Integer)
If FrmVersionSetup Is Nothing Then Exit Sub If FrmVersionSetup Is Nothing Then Return
'为第三方登录清空缓存以更新描述 '为第三方登录清空缓存以更新描述
WriteIni(PathMcFolder & "PCL.ini", "VersionCache", "") WriteIni(PathMcFolder & "PCL.ini", "VersionCache", "")
If PageVersionLeft.Version Is Nothing Then Exit Sub If PageVersionLeft.Version Is Nothing Then Return
PageVersionLeft.Version = New McVersion(PageVersionLeft.Version.Name).Load() PageVersionLeft.Version = New McVersion(PageVersionLeft.Version.Name).Load()
LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\") LoaderFolderRun(McVersionListLoader, PathMcFolder, LoaderFolderRunType.ForceRun, MaxDepth:=1, ExtraPath:="versions\")
End Sub End Sub
@@ -118,7 +118,7 @@
</local:MyCard> </local:MyCard>
<local:MyCard Margin="0,0,0,15" Title="游戏内存"> <local:MyCard Margin="0,0,0,15" Title="游戏内存">
<StackPanel Margin="25,40,25,15"> <StackPanel Margin="25,40,25,15">
<local:MyHint x:Name="LabRamWarn" Text="32 位 Java 最多只能分配 1 GB 内存,建议安装 64 位 Java!" IsWarn="True" Margin="0,0,0,12" /> <local:MyHint x:Name="LabRamWarn" Visibility="Visible" Text="32 位 Java 只能分配最多 1 GB 的内存。强烈建议换用 64 位的 Java!" Theme="Yellow" Margin="0,0,0,12" />
<Grid Margin="0,0,0,3"> <Grid Margin="0,0,0,3">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" /> <ColumnDefinition Width="Auto" />
@@ -171,9 +171,9 @@
</Grid> </Grid>
</StackPanel> </StackPanel>
</local:MyCard> </local:MyCard>
<local:MyCard x:Name="CardSkin" Margin="0,0,0,15" Title="离线皮肤" CanSwap="True" IsSwaped="True"> <local:MyCard x:Name="CardSkin" Margin="0,0,0,15" Title="离线皮肤" CanSwap="True" IsSwapped="True">
<StackPanel Margin="25,40,25,15"> <StackPanel Margin="25,40,25,15">
<local:MyHint Text="由于技术问题,此功能只保证对 1.19.2 以前的版本有效!" IsWarn="True" Margin="0,0,0,10" /> <local:MyHint Text="由于技术问题,此功能只保证对 1.19.2 以前的版本有效!" Theme="Yellow" Margin="0,0,0,10" />
<Grid Margin="-1,0,0,0"> <Grid Margin="-1,0,0,0">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
<ColumnDefinition /> <ColumnDefinition />
@@ -205,7 +205,7 @@
<ColumnDefinition Width="Auto" SharedSizeGroup="Button" /> <ColumnDefinition Width="Auto" SharedSizeGroup="Button" />
</Grid.ColumnDefinitions> </Grid.ColumnDefinitions>
<local:MyButton x:Name="BtnSkinSave" Text="保存皮肤" MinWidth="140" Padding="13,0" Margin="0,0,20,0" Grid.Row="1" /> <local:MyButton x:Name="BtnSkinSave" Text="保存皮肤" MinWidth="140" Padding="13,0" Margin="0,0,20,0" Grid.Row="1" />
<local:MyButton x:Name="BtnSkinCache" Text="刷新缓存" MinWidth="140" Padding="13,0" Margin="0,0,20,0" ToolTip="刷新并重新下载 PCL 当前显示的皮肤" Grid.Row="1" Grid.Column="1" /> <local:MyButton x:Name="BtnSkinCache" Text="刷新" MinWidth="140" Padding="13,0" Margin="0,0,20,0" ToolTip="刷新并重新下载 PCL 当前显示的皮肤" Grid.Row="1" Grid.Column="1" />
</Grid> </Grid>
</Grid> </Grid>
<Grid x:Name="PanSkinChange" Margin="0,14,0,2" Height="35" Visibility="Collapsed"> <Grid x:Name="PanSkinChange" Margin="0,14,0,2" Height="35" Visibility="Collapsed">
@@ -218,7 +218,7 @@
</Grid> </Grid>
</StackPanel> </StackPanel>
</local:MyCard> </local:MyCard>
<local:MyCard Margin="0,0,0,15" Title="高级启动选项" IsSwaped="True" CanSwap="True"> <local:MyCard Margin="0,0,0,15" Title="高级启动选项" IsSwapped="True" CanSwap="True">
<Grid Margin="25,40,25,15"> <Grid Margin="25,40,25,15">
<Grid.ColumnDefinitions> <Grid.ColumnDefinitions>
<ColumnDefinition Width="Auto" /> <ColumnDefinition Width="Auto" />
@@ -226,37 +226,37 @@
</Grid.ColumnDefinitions> </Grid.ColumnDefinitions>
<Grid.RowDefinitions> <Grid.RowDefinitions>
<RowDefinition Height="Auto" /> <RowDefinition Height="Auto" />
<RowDefinition Height="9" />
<RowDefinition Height="28" />
<RowDefinition Height="9" />
<RowDefinition Height="28" />
<RowDefinition Height="Auto" /> <RowDefinition Height="Auto" />
<RowDefinition Height="9" />
<RowDefinition Height="28" />
<RowDefinition Height="9" />
<RowDefinition Height="28" />
<RowDefinition Height="Auto" /> <RowDefinition Height="Auto" />
<RowDefinition Height="Auto" /> <RowDefinition Height="Auto" />
</Grid.RowDefinitions> </Grid.RowDefinitions>
<local:MyHint Text="你可以在版本独立设置中找到更多高级启动选项。" Margin="0,2,0,12" IsWarn="False" Grid.ColumnSpan="2" <StackPanel VerticalAlignment="Center" Orientation="Horizontal" HorizontalAlignment="Left" Margin="0,0,25,0">
CanClose="True" RelativeSetup="HintMoreAdvancedSetup" /> <TextBlock Text="Java 虚拟机参数" VerticalAlignment="Center" />
<StackPanel Grid.Row="1" VerticalAlignment="Center" Orientation="Horizontal" HorizontalAlignment="Left" Margin="0,0,25,0">
<TextBlock Text="JVM 参数头部" VerticalAlignment="Center" />
<local:MyIconButton Height="23" Margin="0,1,0,0" x:Name="BtnAdvanceJvmReset" VerticalAlignment="Center" <local:MyIconButton Height="23" Margin="0,1,0,0" x:Name="BtnAdvanceJvmReset" VerticalAlignment="Center"
ToolTip="还原" ToolTipService.Placement="Right" ToolTipService.InitialShowDelay="200" ToolTipService.VerticalOffset="-1" ToolTip="还原" ToolTipService.Placement="Right" ToolTipService.InitialShowDelay="200" ToolTipService.VerticalOffset="-1"
Logo="M530 0c287 0 521 229 521 511s-233 511-521 511c-233 0-436-151-500-368a63 63 0 0 1 44-79 65 65 0 0 1 80 43c48 162 200 276 375 276 215 0 390-171 390-383s-174-383-390-383c-103 0-199 39-270 106l21-5a63 63 0 0 1 33 123l-157 42a65 65 0 0 1-90-42l-49-183a65 65 0 1 1 126-33l6 26A524 524 0 0 1 530 0z" LogoScale="0.9" /> Logo="M530 0c287 0 521 229 521 511s-233 511-521 511c-233 0-436-151-500-368a63 63 0 0 1 44-79 65 65 0 0 1 80 43c48 162 200 276 375 276 215 0 390-171 390-383s-174-383-390-383c-103 0-199 39-270 106l21-5a63 63 0 0 1 33 123l-157 42a65 65 0 0 1-90-42l-49-183a65 65 0 1 1 126-33l6 26A524 524 0 0 1 530 0z" LogoScale="0.9" />
</StackPanel> </StackPanel>
<local:MyTextBox x:Name="TextAdvanceJvm" Grid.Row="1" Grid.ColumnSpan="2" Tag="LaunchAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,除非有确定把握,否则请不要修改" MaxLength="4000" <local:MyTextBox x:Name="TextAdvanceJvm" Grid.ColumnSpan="2" Tag="LaunchAdvanceJvm" Grid.Column="1" ToolTip="启动 Minecraft 时使用的额外 JVM 参数,除非有确定把握,否则请不要修改。&#xa;支持 Minecraft 版本 JSON 中的字符串替换标记,例如 ${library_directory}。" MaxLength="4000"
Height="100" AcceptsReturn="True" TextWrapping="Wrap" VerticalContentAlignment="Top" Padding="0,5" VerticalScrollBarVisibility="Auto" /> Height="100" AcceptsReturn="True" TextWrapping="Wrap" VerticalContentAlignment="Top" Padding="0,5" VerticalScrollBarVisibility="Auto" />
<TextBlock Grid.Row="3" VerticalAlignment="Center" HorizontalAlignment="Left" Text="游戏参数尾部" Margin="0,0,25,0" /> <TextBlock Grid.Row="2" VerticalAlignment="Center" HorizontalAlignment="Left" Text="游戏参数" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceGame" Grid.Row="3" Grid.ColumnSpan="2" Tag="LaunchAdvanceGame" Grid.Column="1" ToolTip="文本框中的内容将会被直接拼合在启动参数的末尾。&#xa;例如输入 --demo 则会以试玩模式启动游戏。" /> <local:MyTextBox x:Name="TextAdvanceGame" Grid.Row="2" Grid.ColumnSpan="2" Tag="LaunchAdvanceGame" Grid.Column="1" ToolTip="文本框中的内容将会被直接拼合在启动参数的末尾。&#xa;例如,输入 --demo 则会以试玩模式启动游戏。&#xa;支持 Minecraft 版本 JSON 中的字符串替换标记,例如 ${library_directory}。" />
<TextBlock Grid.Row="5" VerticalAlignment="Center" HorizontalAlignment="Left" Text="启动前执行命令" Margin="0,0,25,0" /> <TextBlock Grid.Row="4" VerticalAlignment="Center" HorizontalAlignment="Left" Text="启动前执行命令" Margin="0,0,25,0" />
<local:MyTextBox x:Name="TextAdvanceRun" Grid.Row="5" Grid.ColumnSpan="2" Tag="LaunchAdvanceRun" Grid.Column="1" HintText="" <local:MyTextBox x:Name="TextAdvanceRun" Grid.Row="4" Grid.ColumnSpan="2" Tag="LaunchAdvanceRun" Grid.Column="1" HintText=""
ToolTip="在 MC 启动前执行特定命令或程序,语法与 Windows 的命令提示符一致。&#xa;&#xa;可以使用以下替换标记实现相对路径(路径均以 \ 结尾):&#xa; · {path}:PCL 的 exe 文件所在的文件夹&#xa; · {minecraft}:.minecraft 文件夹&#xa; · {verpath}:版本文件夹(.minecraft\versions\版本名\)&#xa; · {verindie}:开启版本隔离时等同版本文件夹,未开启时等同 .minecraft 文件夹&#xa; · {java}:游戏运行时的 Java 文件夹&#xa;&#xa;除此之外,也支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {uuid}:玩家的 UUID&#xa; · {name}:游戏版本名&#xa; · {date}、{time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号&#xa;&#xa;例如:&#xa; · &quot;{verpath}test.exe&quot; :运行版本文件夹下的 test.exe 程序&#xa; · &quot;{java}java.exe&quot; -jar &quot;{verpath}test.jar&quot; :用 Java 运行版本文件夹下的 test.jar&#xa; · notepad &quot;{verindie}options.txt&quot; :使用记事本打开该版本的设置文件&#xa;&#xa;涉及路径的操作最好都打上双引号,以避免路径中的空格导致运行失败。&#xa;执行命令时,命令行所在的目录是当前的 .minecraft 文件夹。" /> ToolTip="在 MC 启动前执行特定命令或程序,语法与 Windows 的命令提示符一致。&#xa;&#xa;可以使用以下替换标记实现相对路径(路径均以 \ 结尾):&#xa; · {path}:PCL 的 exe 文件所在的文件夹&#xa; · {minecraft}:.minecraft 文件夹&#xa; · {verpath}:版本文件夹(.minecraft\versions\版本名\)&#xa; · {verindie}:开启版本隔离时等同版本文件夹,未开启时等同 .minecraft 文件夹&#xa; · {java}:游戏运行时的 Java 文件夹&#xa;&#xa;除此之外,也支持以下替换标记:&#xa; · {user}:玩家名字&#xa; · {login}:玩家的登录方式&#xa; · {uuid}:玩家的 UUID&#xa; · {name}:游戏版本名&#xa; · {date}、{time}:当前的系统时间&#xa; · {version}:游戏对应的原版版本号&#xa;&#xa;例如:&#xa; · &quot;{verpath}test.exe&quot; :运行版本文件夹下的 test.exe 程序&#xa; · &quot;{java}java.exe&quot; -jar &quot;{verpath}test.jar&quot; :用 Java 运行版本文件夹下的 test.jar&#xa; · notepad &quot;{verindie}options.txt&quot; :使用记事本打开该版本的设置文件&#xa;&#xa;涉及路径的操作最好都打上双引号,以避免路径中的空格导致运行失败。&#xa;执行命令时,命令行所在的目录是当前的 .minecraft 文件夹。" />
<local:MyCheckBox Grid.Row="6" Grid.Column="1" x:Name="CheckAdvanceRunWait" Tag="LaunchAdvanceRunWait" Visibility="Collapsed" <local:MyCheckBox Grid.Row="5" Grid.Column="1" x:Name="CheckAdvanceRunWait" Tag="LaunchAdvanceRunWait" Visibility="Collapsed"
Text="等待命令执行完成后再继续启动" Margin="0,8,0,7" /> Text="等待命令执行完成后再继续启动" Margin="0,8,0,7" />
<StackPanel Margin="0,12,0,4" Grid.Row="7" Grid.ColumnSpan="2" HorizontalAlignment="Left"> <StackPanel Margin="0,12,0,4" Grid.Row="6" Grid.ColumnSpan="2" HorizontalAlignment="Left">
<local:MyCheckBox Height="28" Text="禁用 Java Launch Wrapper" x:Name="CheckAdvanceDisableJLW" Tag="LaunchAdvanceDisableJLW" <local:MyCheckBox Height="28" Text="禁用 Java Launch Wrapper" x:Name="CheckAdvanceDisableJLW" Tag="LaunchAdvanceDisableJLW"
ToolTipService.Placement="Right" ToolTip="PCL 会使用 Java Launch Wrapper 来修复老版本 Java 在中文路径下无法启动的问题。&#xa;如果这被反作弊拦截,或遇到其他问题,也可以将其关闭。" /> ToolTipService.Placement="Right" ToolTip="PCL 会使用 Java Launch Wrapper 来修复老版本 Java 在中文路径下无法启动的问题。&#xa;如果这被反作弊拦截,或遇到其他问题,也可以将其关闭。" />
<local:MyCheckBox Height="28" Text="要求 Java 使用高性能显卡" x:Name="CheckAdvanceGraphicCard" Tag="LaunchAdvanceGraphicCard" <local:MyCheckBox Height="28" Text="要求 Java 使用高性能显卡" x:Name="CheckAdvanceGraphicCard" Tag="LaunchAdvanceGraphicCard"
ToolTipService.Placement="Right" ToolTip="自动在 Windows 设置 → 系统 → 屏幕 → 显示卡 中将 Java 改为使用高性能显卡。&#xa;如果电脑同时有集显和独显,这能确保 MC 使用独显进行渲染,以大幅提高性能。" /> ToolTipService.Placement="Right" ToolTip="自动在 Windows 设置 → 系统 → 屏幕 → 显示卡 中将 Java 改为使用高性能显卡。&#xa;如果电脑同时有集显和独显,这能确保 MC 使用独显进行渲染,以大幅提高性能。" />
</StackPanel> </StackPanel>
<local:MyHint Text="你还可以在版本独立设置中找到更多高级启动选项。" Margin="0,5,0,10" Theme="Blue" Grid.Row="7" Grid.ColumnSpan="2"
CanClose="True" RelativeSetup="HintMoreAdvancedSetup" />
</Grid> </Grid>
</local:MyCard> </local:MyCard>
<local:MyExtraTextButton HorizontalAlignment="Center" Margin="0,-5,0,15" <local:MyExtraTextButton HorizontalAlignment="Center" Margin="0,-5,0,15"

Some files were not shown because too many files have changed in this diff Show More