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.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