282 lines
16 KiB
VB.net
282 lines
16 KiB
VB.net
Imports System.Reflection
|
||
Imports System.Windows.Threading
|
||
|
||
Public Class Application
|
||
|
||
'开始
|
||
Private Sub Application_Startup(sender As Object, e As StartupEventArgs) Handles Me.Startup
|
||
Try
|
||
'执行开发版测试
|
||
If BuildType = BuildTypes.Debug Then
|
||
Try
|
||
ModDevelop.Start()
|
||
Catch ex As Exception
|
||
Log(ex, "开发者模式测试出错", NotifyLevel.MsgBox)
|
||
End Try
|
||
End If
|
||
'提升主线程优先级
|
||
Thread.CurrentThread.Priority = ThreadPriority.Highest
|
||
'确保 .NET Framework 版本
|
||
Try
|
||
Dim VersionTest As New FormattedText("", Globalization.CultureInfo.CurrentCulture, FlowDirection.LeftToRight, Fonts.SystemTypefaces.First, 96, New MyColor, DPI)
|
||
Catch ex As UriFormatException '修复 #3555
|
||
Environment.SetEnvironmentVariable("windir", Environment.GetEnvironmentVariable("SystemRoot"), EnvironmentVariableTarget.User)
|
||
Dim VersionTest As New FormattedText("", Globalization.CultureInfo.CurrentCulture, FlowDirection.LeftToRight, Fonts.SystemTypefaces.First, 96, New MyColor, DPI)
|
||
End Try
|
||
'检测当前文件夹权限
|
||
Try
|
||
DirectoryUtils.Create(PathExeFolder & "PCL\")
|
||
Catch ex As Exception
|
||
MsgBox($"PCL 无法创建 PCL 文件夹（{PathExeFolder & "PCL"}），请尝试：" & vbCrLf &
|
||
"1. 将 PCL 移动到其他文件夹" & If(PathExeFolder.StartsWithF("C:", True), "，例如 C 盘和桌面以外的其他位置。", "。") & vbCrLf &
|
||
"2. 删除当前目录中的 PCL 文件夹，然后再试。" & vbCrLf &
|
||
"3. 右键 PCL 选择属性，打开 兼容性 中的 以管理员身份运行此程序。",
|
||
MsgBoxStyle.Critical, "运行环境错误")
|
||
Environment.[Exit](ProcessReturnValues.Cancel)
|
||
End Try
|
||
If Not CheckPermission(PathExeFolder & "PCL") Then
|
||
MsgBox("PCL 没有对当前文件夹的写入权限，请尝试：" & vbCrLf &
|
||
"1. 将 PCL 移动到其他文件夹" & If(PathExeFolder.StartsWithF("C:", True), "，例如 C 盘和桌面以外的其他位置。", "。") & vbCrLf &
|
||
"2. 删除当前目录中的 PCL 文件夹，然后再试。" & vbCrLf &
|
||
"3. 右键 PCL 选择属性，打开 兼容性 中的 以管理员身份运行此程序。",
|
||
MsgBoxStyle.Critical, "运行环境错误")
|
||
Environment.[Exit](ProcessReturnValues.Cancel)
|
||
End If
|
||
'检查参数调用
|
||
If e.Args.Length > 0 Then
|
||
If e.Args(0) = "--update" Then
|
||
'自动更新
|
||
UpdateReplace(e.Args(1), e.Args(2).Trim(""""), e.Args(3).Trim(""""), e.Args(4))
|
||
Environment.Exit(ProcessReturnValues.TaskDone)
|
||
ElseIf e.Args(0) = "--gpu" Then
|
||
'调整显卡设置
|
||
Try
|
||
SetGPUPreference(e.Args(1).Trim(""""))
|
||
Environment.Exit(ProcessReturnValues.TaskDone)
|
||
Catch ex As Exception
|
||
Environment.Exit(ProcessReturnValues.Fail)
|
||
End Try
|
||
ElseIf e.Args(0).StartsWithF("--memory") Then
|
||
'内存优化
|
||
Dim Ram = My.Computer.Info.AvailablePhysicalMemory
|
||
Try
|
||
PageOtherTest.MemoryOptimizeInternal(False)
|
||
Catch ex As Exception
|
||
MsgBox(ex.Message, MsgBoxStyle.Critical, "内存优化失败")
|
||
Environment.Exit(-1)
|
||
End Try
|
||
If My.Computer.Info.AvailablePhysicalMemory < Ram Then '避免 ULong 相减出现负数
|
||
Environment.Exit(0)
|
||
Else
|
||
Environment.Exit((My.Computer.Info.AvailablePhysicalMemory - Ram) / 1024) '返回清理的内存量（K）
|
||
End If
|
||
End If
|
||
End If
|
||
'初始化文件结构
|
||
DirectoryUtils.Create(PathExeFolder & "PCL\Pictures\")
|
||
DirectoryUtils.Create(PathExeFolder & "PCL\Musics\")
|
||
Try
|
||
DirectoryUtils.Create(PathTemp)
|
||
If Not CheckPermission(PathTemp) Then Throw New Exception("PCL 没有对 " & PathTemp & " 的访问权限")
|
||
Catch ex As Exception
|
||
If PathTemp = Path.GetTempPath() & "PCL\" Then
|
||
MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用")
|
||
Else
|
||
MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & vbCrLf & "错误原因：" & ex.GetDetail(), "缓存文件夹不可用")
|
||
Settings.Set("SystemSystemCache", "")
|
||
PathTemp = Path.GetTempPath() & "PCL\"
|
||
End If
|
||
End Try
|
||
DirectoryUtils.Create(PathTemp & "Cache\")
|
||
DirectoryUtils.Create(PathAppdata)
|
||
'要求单例
|
||
If BuildType <> BuildTypes.Debug Then
|
||
Dim ShouldWaitForExit As Boolean = e.Args.Length > 0 AndAlso e.Args(0) = "--wait" '要求等待已有的 PCL 退出
|
||
Dim WaitRetryCount As Integer = 0
|
||
WaitRetry:
|
||
Dim WindowHwnd As IntPtr = FindWindow(Nothing, "Plain Craft Launcher ")
|
||
If WindowHwnd = IntPtr.Zero Then FindWindow(Nothing, "Plain Craft Launcher 2 ")
|
||
If WindowHwnd <> IntPtr.Zero Then
|
||
If ShouldWaitForExit AndAlso WaitRetryCount < 20 Then '至多等待 10 秒
|
||
WaitRetryCount += 1
|
||
Thread.Sleep(500)
|
||
GoTo WaitRetry
|
||
End If
|
||
'将已有的 PCL 窗口拖出来
|
||
ShowWindowToTop(WindowHwnd)
|
||
'播放提示音并退出
|
||
Beep()
|
||
Environment.[Exit](ProcessReturnValues.Cancel)
|
||
End If
|
||
End If
|
||
'设置 ToolTipService 默认值
|
||
ToolTipService.InitialShowDelayProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(300))
|
||
ToolTipService.BetweenShowDelayProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(400))
|
||
ToolTipService.ShowDurationProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(9999999))
|
||
ToolTipService.PlacementProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(Primitives.PlacementMode.Bottom))
|
||
ToolTipService.HorizontalOffsetProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(8.0))
|
||
ToolTipService.VerticalOffsetProperty.OverrideMetadata(GetType(DependencyObject), New FrameworkPropertyMetadata(4.0))
|
||
'设置网络配置默认值
|
||
ServicePointManager.Expect100Continue = False
|
||
ServicePointManager.SecurityProtocol = SecurityProtocolType.Ssl3 Or SecurityProtocolType.Tls Or SecurityProtocolType.Tls11 Or SecurityProtocolType.Tls12
|
||
ServicePointManager.DefaultConnectionLimit = 10000
|
||
ServicePointManager.UseNagleAlgorithm = False
|
||
ServicePointManager.EnableDnsRoundRobin = True
|
||
ServicePointManager.ReusePort = True
|
||
'设置初始窗口
|
||
If Settings.Get("UiLauncherLogo") Then
|
||
FrmStart = New SplashScreen("Images\icon.ico")
|
||
FrmStart.Show(False, True)
|
||
End If
|
||
'日志初始化
|
||
LogStart()
|
||
'添加日志
|
||
Log($"[Start] 程序版本：{VersionDisplay} ({VersionCode}{If(CommitHash = "", "", $"，#{CommitHash}")})")
|
||
If BuildType = BuildTypes.Snapshot Then
|
||
Log($"[Start] 识别码：{Identify}{If(ThemeCheckOne(9), "，已解锁反馈主题", "，未解锁反馈主题")}")
|
||
Else
|
||
Log($"[Start] 识别码：{Identify}")
|
||
End If
|
||
Log($"[Start] 程序路径：{PathExe}")
|
||
Log($"[Start] 系统编码：{Encoding.Default.HeaderName} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})")
|
||
Log($"[Start] 管理员权限：{IsAdmin()}")
|
||
'检测异常环境
|
||
If PathExeFolder.Contains(Path.GetTempPath()) OrElse PathExeFolder.Contains("AppData\Local\Temp\") Then
|
||
MyMsgBox("请将 PCL 从压缩包中解压后再使用！" & vbCrLf & "如果不会解压，可以在网上寻找教程。", "需要解压！", "我知道了", IsWarn:=True, ForceWait:=True)
|
||
FormMain.EndProgramForce(ProcessReturnValues.Cancel)
|
||
End If
|
||
If Is32BitSystem Then
|
||
MyMsgBox("PCL 和新版 Minecraft 均不再支持 32 位系统，部分功能将无法使用。" & vbCrLf & "非常建议重装为 64 位系统后再进行游戏！", "环境警告", "我知道了", IsWarn:=True)
|
||
End If
|
||
'计时
|
||
Log("[Start] 第一阶段加载用时：" & GetTimeMs() - ApplicationStartTick & " ms")
|
||
ApplicationStartTick = GetTimeMs()
|
||
AniControlEnabled += 1
|
||
Catch ex As Exception
|
||
Dim FilePath As String = Nothing
|
||
Try
|
||
FilePath = PathExe
|
||
Catch
|
||
End Try
|
||
MsgBox(ex.GetDetail(True) & vbCrLf & "PCL 所在路径：" & If(String.IsNullOrEmpty(FilePath), "获取失败", FilePath), MsgBoxStyle.Critical, "PCL 初始化错误")
|
||
FormMain.EndProgramForce(ProcessReturnValues.Exception)
|
||
End Try
|
||
End Sub
|
||
|
||
'结束
|
||
Private Sub Application_SessionEnding(sender As Object, e As SessionEndingCancelEventArgs) Handles Me.SessionEnding
|
||
FrmMain?.EndProgram(False)
|
||
End Sub
|
||
|
||
'异常
|
||
Private Sub Application_DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Handles Me.DispatcherUnhandledException
|
||
On Error Resume Next
|
||
'触发页面的 Dispatcher
|
||
If FrmMain?.PageLeft IsNot Nothing AndAlso TypeOf FrmMain.PageLeft Is IDispatcherUnhandledException Then
|
||
CType(FrmMain.PageLeft, IDispatcherUnhandledException).DispatcherUnhandledException(sender, e)
|
||
If e.Handled Then Return
|
||
End If
|
||
If FrmMain?.PageRight IsNot Nothing AndAlso TypeOf FrmMain.PageRight Is IDispatcherUnhandledException Then
|
||
CType(FrmMain.PageRight, IDispatcherUnhandledException).DispatcherUnhandledException(sender, e)
|
||
If e.Handled Then Return
|
||
End If
|
||
'正常处理
|
||
e.Handled = True
|
||
If IsProgramEnded Then Return
|
||
FeedbackInfo()
|
||
Dim Detail As String = e.Exception.GetDetail(True)
|
||
If Detail.Contains("System.Windows.Threading.Dispatcher.Invoke") OrElse Detail.Contains("MS.Internal.AppModel.ITaskbarList.HrInit") OrElse Detail.Contains("未能加载文件或程序集") OrElse
|
||
Detail.Contains(".NET Framework") Then ' “自动错误判断” 的结果分析
|
||
OpenWebsite("https://dotnet.microsoft.com/zh-cn/download/dotnet-framework/thank-you/net462-offline-installer")
|
||
Log(e.Exception, "你的 .NET Framework 版本过低或损坏，请下载并重新安装 .NET Framework 4.6.2！" & vbCrLf & "若无法安装，可在卸载高版本的 .NET Framework 后再试。", NotifyLevel.Critical, "运行环境错误")
|
||
Else
|
||
Log(e.Exception, "程序出现未知错误", NotifyLevel.Critical, "锟斤拷烫烫烫")
|
||
End If
|
||
End Sub
|
||
|
||
'动态 DLL 加载
|
||
Private Sub New() '这里必须尽早调用，且不能使用任何库，否则加载 MeloongCore 就会导致崩溃
|
||
Static Prefixes As String() = {"NAudio", "Newtonsoft.Json", "Ookii.Dialogs.Wpf", "Imazen.WebP", "CacheCow.Common", "CacheCow.Client.FileStore", "CacheCow.Client", "System.Net.Http.Formatting", "System.ValueTuple", "PCLCS", "MeloongCore.Wpf", "MeloongCore"}
|
||
Static Locks As New Dictionary(Of String, Object)(StringComparer.Ordinal)
|
||
Static LoadedAssembly As New Dictionary(Of String, Assembly)(StringComparer.Ordinal) '缓存
|
||
AddHandler AppDomain.CurrentDomain.AssemblyResolve,
|
||
Function(sender As Object, Args As ResolveEventArgs) As Assembly
|
||
Dim Prefix As String = Prefixes.FirstOrDefault(Function(p) Args.Name.StartsWith(p, StringComparison.Ordinal))
|
||
If Prefix Is Nothing Then Return Nothing
|
||
If Not Locks.ContainsKey(Prefix) Then Locks(Prefix) = New Object()
|
||
SyncLock Locks(Prefix)
|
||
If Not LoadedAssembly.ContainsKey(Prefix) Then
|
||
LoadedAssembly(Prefix) = Assembly.Load(My.Resources.ResourceManager.GetObject(Prefix))
|
||
If Prefix = "Imazen.WebP" Then ExtractLibwebp() 'WebP 特判
|
||
End If
|
||
Return LoadedAssembly(Prefix)
|
||
End SyncLock
|
||
End Function
|
||
End Sub
|
||
Private Shared Sub ExtractLibwebp() '这个方法会调用 ModBase，进而调用 MeloongCore，所以不能放在 New 里
|
||
SetDllDirectory(PathPure.TrimEnd("\"c))
|
||
Try
|
||
FileUtils.Write(PathPure & "libwebp.dll", GetResources("libwebp64"))
|
||
Catch ex As Exception
|
||
Log(ex, "写入 libwebp.dll 失败") '防止同时加载多个图片时，同时写入文件导致文件占用，进而导致崩溃
|
||
End Try
|
||
End Sub
|
||
Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean
|
||
|
||
'切换窗口
|
||
|
||
'控件模板事件
|
||
Private Sub MyIconButton_Click(sender As Object, e As EventArgs)
|
||
Select Case Settings.Get("LoginType")
|
||
Case McLoginType.Ms
|
||
'微软
|
||
Dim MsJson As JObject = GetJson(Settings.Get("LoginMsJson"))
|
||
MsJson.Remove(sender.Tag)
|
||
Settings.Set("LoginMsJson", MsJson.ToString(Newtonsoft.Json.Formatting.None))
|
||
If FrmLoginMs.ComboAccounts.SelectedItem Is sender.Parent Then FrmLoginMs.ComboAccounts.SelectedIndex = 0
|
||
FrmLoginMs.ComboAccounts.Items.Remove(sender.Parent)
|
||
Case McLoginType.Legacy
|
||
'离线
|
||
Dim Names As New List(Of String)
|
||
Names.AddRange(Settings.Get("LoginLegacyName").ToString.Split("¨"))
|
||
Names.Remove(sender.Tag)
|
||
Settings.Set("LoginLegacyName", Names.Join("¨"c))
|
||
FrmLoginLegacy.ComboName.ItemsSource = Names
|
||
FrmLoginLegacy.ComboName.Text = If(Names.Any, Names(0), "")
|
||
Case Else
|
||
'第三方
|
||
Dim Token As String = GetStringFromEnum(Settings.Get("LoginType"))
|
||
Dim Dict As New Dictionary(Of String, String)
|
||
Dim Names As New List(Of String)
|
||
Dim Passs As New List(Of String)
|
||
If Not Settings.Get("Login" & Token & "Email") = "" Then Names.AddRange(Settings.Get("Login" & Token & "Email").ToString.Split("¨"))
|
||
If Not Settings.Get("Login" & Token & "Pass") = "" Then Passs.AddRange(Settings.Get("Login" & Token & "Pass").ToString.Split("¨"))
|
||
For i = 0 To Names.Count - 1
|
||
Dict.Add(Names(i), Passs(i))
|
||
Next
|
||
Dict.Remove(sender.Tag)
|
||
Settings.Set("Login" & Token & "Email", Dict.Keys.Join("¨"c))
|
||
Settings.Set("Login" & Token & "Pass", Dict.Values.Join("¨"c))
|
||
Select Case Token
|
||
Case "Nide"
|
||
FrmLoginNide.ComboName.ItemsSource = Dict.Keys
|
||
FrmLoginNide.ComboName.Text = If(Dict.Keys.Any, Dict.Keys(0), "")
|
||
FrmLoginNide.TextPass.Password = If(Dict.Values.Any, Dict.Values(0), "")
|
||
Case "Auth"
|
||
FrmLoginAuth.ComboName.ItemsSource = Dict.Keys
|
||
FrmLoginAuth.ComboName.Text = If(Dict.Keys.Any, Dict.Keys(0), "")
|
||
FrmLoginAuth.TextPass.Password = If(Dict.Values.Any, Dict.Values(0), "")
|
||
End Select
|
||
End Select
|
||
End Sub
|
||
|
||
Public Shared ShowingTooltips As New List(Of Border)
|
||
Private Sub TooltipLoaded(sender As Border, e As EventArgs)
|
||
ShowingTooltips.Add(sender)
|
||
End Sub
|
||
Private Sub TooltipUnloaded(sender As Border, e As RoutedEventArgs)
|
||
ShowingTooltips.Remove(sender)
|
||
End Sub
|
||
|
||
End Class
|