238 lines
12 KiB
VB.net
238 lines
12 KiB
VB.net
Imports System.IO
|
||
Imports PCL.Core.App
|
||
Imports PCL.Core.Utils
|
||
Imports PCL.Core.Utils.OS
|
||
|
||
Public Class Application
|
||
|
||
#If DEBUGRESERVED Then
|
||
''' <summary>
|
||
''' 用于开始程序时的一些测试。
|
||
''' </summary>
|
||
Private Sub Test()
|
||
Try
|
||
ModDevelop.Start()
|
||
Catch ex As Exception
|
||
Log(ex, "开发者模式测试出错", LogLevel.Msgbox)
|
||
End Try
|
||
End Sub
|
||
#End If
|
||
|
||
Public Sub New()
|
||
Basics.VersionName = VersionBaseName
|
||
Basics.VersionNumber = VersionCode
|
||
'注册生命周期事件
|
||
Lifecycle.When(LifecycleState.Loaded, AddressOf Application_Startup)
|
||
End Sub
|
||
|
||
'开始
|
||
Private Sub Application_Startup() '(sender As Object, e As StartupEventArgs) Handles Me.Startup
|
||
Try
|
||
Encoding.RegisterProvider(CodePagesEncodingProvider.Instance)
|
||
'创建自定义跟踪监听器，用于检测是否存在 Binding 失败
|
||
PresentationTraceSources.DataBindingSource.Listeners.Add(New BindingErrorTraceListener())
|
||
PresentationTraceSources.DataBindingSource.Switch.Level = SourceLevels.Error
|
||
SecretOnApplicationStart()
|
||
'检查参数调用
|
||
Dim args = Environment.GetCommandLineArgs.Skip(1).ToArray()
|
||
If args.Length > 0 Then
|
||
If args(0) = "--update" Then
|
||
'自动更新
|
||
UpdateReplace(args(1), args(2).Trim(""""), args(3).Trim(""""), args(4))
|
||
Environment.Exit(ProcessReturnValues.TaskDone)
|
||
ElseIf args(0) = "--gpu" Then
|
||
'调整显卡设置
|
||
Try
|
||
SetGPUPreference(args(1).Trim(""""))
|
||
Environment.Exit(ProcessReturnValues.TaskDone)
|
||
Catch ex As Exception
|
||
Environment.Exit(ProcessReturnValues.Fail)
|
||
End Try
|
||
ElseIf args(0).StartsWithF("--memory") Then
|
||
'内存优化
|
||
Dim Ram = KernelInterop.GetAvailablePhysicalMemoryBytes()
|
||
Try
|
||
PageOtherTest.MemoryOptimizeInternal(False)
|
||
Catch ex As Exception
|
||
MsgBox(ex.Message, MsgBoxStyle.Critical, "内存优化失败")
|
||
Environment.Exit(-1)
|
||
End Try
|
||
If KernelInterop.GetAvailablePhysicalMemoryBytes() < Ram Then '避免 ULong 相减出现负数
|
||
Environment.Exit(0)
|
||
Else
|
||
Environment.Exit((KernelInterop.GetAvailablePhysicalMemoryBytes() - Ram) / 1024) '返回清理的内存量（K）
|
||
End If
|
||
#If DEBUGRESERVED Then
|
||
'制作更新包
|
||
ElseIf args(0) = "--edit1" Then
|
||
ExeEdit(args(1), True)
|
||
Environment.Exit(ProcessReturnValues.TaskDone)
|
||
ElseIf args(0) = "--edit2" Then
|
||
ExeEdit(args(1), False)
|
||
Environment.Exit(ProcessReturnValues.TaskDone)
|
||
#End If
|
||
End If
|
||
End If
|
||
'初始化文件结构
|
||
Directory.CreateDirectory(ExePath & "PCL\Pictures")
|
||
Directory.CreateDirectory(ExePath & "PCL\Musics")
|
||
Try
|
||
Directory.CreateDirectory(PathTemp)
|
||
If Not CheckPermission(PathTemp) Then Throw New Exception("PCL 没有对 " & PathTemp & " 的访问权限")
|
||
Catch ex As Exception
|
||
If PathTemp = IO.Path.GetTempPath() & "PCL\" Then
|
||
MyMsgBox("PCL 无法访问缓存文件夹，可能导致程序出错或无法正常使用！" & vbCrLf & "错误原因：" & ex.ToString(), "缓存文件夹不可用")
|
||
Else
|
||
MyMsgBox("手动设置的缓存文件夹不可用，PCL 将使用默认缓存文件夹。" & vbCrLf & "错误原因：" & ex.ToString(), "缓存文件夹不可用")
|
||
Setup.Set("SystemSystemCache", "")
|
||
PathTemp = IO.Path.GetTempPath() & "PCL\"
|
||
End If
|
||
End Try
|
||
Directory.CreateDirectory(PathTemp & "Cache")
|
||
Directory.CreateDirectory(PathTemp & "Download")
|
||
Directory.CreateDirectory(PathAppdata)
|
||
#If False Then
|
||
'检测单例
|
||
Dim ShouldWaitForExit As Boolean = args.Length > 0 AndAlso args(0) = "--wait" '要求等待已有的 PCL 退出
|
||
Dim WaitRetryCount As Integer = 0
|
||
WaitRetry:
|
||
Dim WindowHwnd As IntPtr = FindWindow(Nothing, "Plain Craft Launcher Community Edition ")
|
||
If WindowHwnd = IntPtr.Zero Then FindWindow(Nothing, "Plain Craft Launcher 2 Community Edition ")
|
||
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))
|
||
'设置初始窗口
|
||
If Setup.Get("UiLauncherLogo") Then
|
||
FrmStart = New SplashScreen("Images\icon.ico")
|
||
FrmStart.Show(False, True)
|
||
End If
|
||
'添加日志
|
||
Log($"[Start] 程序版本：{VersionBaseName} (Channel: {VersionBranchName},Code: {VersionCode}{If(CommitHash = "", "", $"，#{CommitHash}")})")
|
||
Log($"[Start] 识别码：{UniqueAddress}")
|
||
Log($"[Start] 程序路径：{ExePathWithName}")
|
||
Log($"[Start] 系统版本：{Environment.OSVersion.Version}, 架构：{Runtime.InteropServices.RuntimeInformation.OSArchitecture}")
|
||
Log($"[Start] 系统编码：{Encoding.Default.HeaderName} ({Encoding.Default.CodePage}, GBK={IsGBKEncoding})")
|
||
Log($"[Start] 管理员权限：{ProcessInterop.IsAdmin()}")
|
||
'检测异常环境
|
||
Dim problemList As New List(Of String)
|
||
Dim currentOSVersion = KernelInterop.GetCurrentOSVersion()
|
||
If currentOSVersion.Build < 17763 Then problemList.Add("- Windows 版本不满足推荐要求，推荐至少 Windows 10 1809，建议考虑升级 Windows 系统")
|
||
If Is32BitSystem then problemList.Add("- 当前系统为 32 位，不受 PCL 和新版 Minecraft 支持，非常建议重装为 64 位系统后再进行游戏")
|
||
If ExePath.Contains(IO.Path.GetTempPath()) OrElse ExePath.Contains("AppData\Local\Temp\") Then problemList.Add("- PCL 正在临时目录运行，请将 PCL 从压缩包中解压之后再使用，否则可能导致游戏存档或设置丢失")
|
||
If ExePath.ContainsF("wechat_files", True) OrElse ExePath.ContainsF("WeChat Files", True) OrElse ExePath.ContainsF("Tencent Files", True) Then problemList.Add("- PCL 正在 QQ、微信、TIM 等社交软件的下载目录运行，请考虑移动到其他位置，否则可能导致游戏存档或设置丢失")
|
||
If problemList.Count <> 0 Then
|
||
MyMsgBox("PCL CE 在启动时检测到环境问题：" & vbCrLf & vbCrLf &
|
||
problemList.Join(vbCrLf) & vbCrLf & vbCrLf &
|
||
"不解决这些问题可能会导致部分功能无法正常工作……", "环境警告", "我知道了", IsWarn:=True)
|
||
End If
|
||
'设置初始化
|
||
Setup.Load("SystemDebugMode")
|
||
Setup.Load("SystemDebugAnim")
|
||
Setup.Load("SystemHttpProxy")
|
||
Setup.Load("SystemHttpProxyCustomUsername")
|
||
Setup.Load("SystemHttpProxyType")
|
||
Setup.Load("ToolDownloadThread")
|
||
Setup.Load("ToolDownloadSpeed")
|
||
Setup.Load("UiFont")
|
||
Dim updateBranchCfg = Config.System.UpdateBranchConfig
|
||
If updateBranchCfg.IsDefault() Then
|
||
updateBranchCfg.SetValue(If(VersionBaseName.Contains("beta"), 1, 0))
|
||
End If
|
||
'删除旧日志
|
||
For i = 1 To 5
|
||
Dim oldLogFile = $"{ExePath}PCL\Log-CE{i}.log"
|
||
If File.Exists(oldLogFile) Then File.Delete(oldLogFile)
|
||
Next
|
||
'Pipe RPC 初始化
|
||
StartEchoPipe()
|
||
'计时
|
||
Log("[Start] 第一阶段加载用时：" & TimeUtils.GetTimeTick() - ApplicationStartTick & " ms")
|
||
ApplicationStartTick = TimeUtils.GetTimeTick()
|
||
'执行测试
|
||
#If DEBUGRESERVED Then
|
||
Test()
|
||
#End If
|
||
AniControlEnabled += 1
|
||
Catch ex As Exception
|
||
Dim FilePath As String = Nothing
|
||
Try
|
||
FilePath = ExePathWithName
|
||
Catch
|
||
End Try
|
||
MsgBox(ex.ToString() & 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
|
||
|
||
#If False
|
||
|
||
'异常
|
||
Private Sub Application_DispatcherUnhandledException(sender As Object, e As DispatcherUnhandledExceptionEventArgs) Handles Me.DispatcherUnhandledException
|
||
On Error Resume Next
|
||
e.Handled = True
|
||
If IsProgramEnded Then Return
|
||
FeedbackInfo()
|
||
Dim Detail As String = e.Exception.ToString()
|
||
If Detail.Contains("System.Windows.Threading.Dispatcher.Invoke") OrElse Detail.Contains("MS.Internal.AppModel.ITaskbarList.HrInit") OrElse Detail.Contains("未能加载文件或程序集") Then ' “自动错误判断” 的结果分析
|
||
OpenWebsite("https://get.dot.net/8")
|
||
Log(e.Exception, "你的 .NET 桌面运行时版本过低或损坏，请下载并重新安装 .NET 8！", LogLevel.Critical, "运行环境错误")
|
||
Else
|
||
Log(e.Exception, "程序出现未知错误", LogLevel.Critical, "锟斤拷烫烫烫")
|
||
End If
|
||
End Sub
|
||
|
||
Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryA" (lpPathName As String) As Boolean
|
||
|
||
#End If
|
||
|
||
'切换窗口
|
||
|
||
'控件模板事件
|
||
Private Sub MyIconButton_Click(sender As Object, e As EventArgs)
|
||
End Sub
|
||
|
||
Public Shared ReadOnly ShowingTooltips As New List(Of Border)
|
||
Private Sub TooltipLoaded(sender As Object, e As EventArgs)
|
||
ShowingTooltips.Add(CType(sender, Border))
|
||
End Sub
|
||
Private Sub TooltipUnloaded(sender As Object, e As RoutedEventArgs)
|
||
ShowingTooltips.Remove(CType(sender, Border))
|
||
End Sub
|
||
|
||
' 自定义监听器类
|
||
Public Class BindingErrorTraceListener
|
||
Inherits TraceListener
|
||
|
||
Public Overrides Sub Write(message As String)
|
||
Log($"警告，检测到 Binding 失败：{message}")
|
||
End Sub
|
||
|
||
Public Overrides Sub WriteLine(message As String)
|
||
Log($"警告，检测到 Binding 失败：{message}")
|
||
End Sub
|
||
End Class
|
||
|
||
End Class
|