上传公开代码
This commit is contained in:
龙腾猫跃
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,700 @@
|
||||
Public Module ModLoader
|
||||
|
||||
'各类加载器
|
||||
''' <summary>
|
||||
''' 加载器的统一基类。
|
||||
''' </summary>
|
||||
Public MustInherit Class LoaderBase
|
||||
Implements ILoadingTrigger
|
||||
|
||||
Public ReadOnly Property IsLoader As Boolean = True Implements ILoadingTrigger.IsLoader
|
||||
|
||||
'基础属性
|
||||
''' <summary>
|
||||
''' 加载器的标识编号。
|
||||
''' </summary>
|
||||
Public Uuid As Integer = GetUuid()
|
||||
''' <summary>
|
||||
''' 加载器的名称。
|
||||
''' </summary>
|
||||
Public Name As String = "未命名任务 " & Uuid & "#"
|
||||
''' <summary>
|
||||
''' 用于状态改变检测的同步锁。
|
||||
''' </summary>
|
||||
Public ReadOnly LockState As New Object
|
||||
''' <summary>
|
||||
''' 父加载器。
|
||||
''' </summary>
|
||||
Public Parent As LoaderBase = Nothing
|
||||
''' <summary>
|
||||
''' 最上级的加载器。
|
||||
''' </summary>
|
||||
Public ReadOnly Property RealParent As LoaderBase
|
||||
Get
|
||||
Try
|
||||
RealParent = Parent
|
||||
While RealParent IsNot Nothing AndAlso RealParent.Parent IsNot Nothing
|
||||
RealParent = RealParent.Parent
|
||||
End While
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取父加载器失败（" & Name & "）", LogLevel.Feedback)
|
||||
Return Nothing
|
||||
End Try
|
||||
End Get
|
||||
End Property
|
||||
|
||||
Public Overridable Sub InitParent(Parent As LoaderBase)
|
||||
Me.Parent = Parent
|
||||
End Sub
|
||||
|
||||
'事件
|
||||
|
||||
''' <summary>
|
||||
''' 当状态改变时，在工作线程触发代码。在添加事件后，必须将 HasOnStateChangedThread 设为 True。
|
||||
''' </summary>
|
||||
Public Event OnStateChangedThread(Loader As LoaderBase, NewState As LoadState, OldState As LoadState)
|
||||
Public HasOnStateChangedThread As Boolean = False
|
||||
|
||||
''' <summary>
|
||||
''' 当状态改变时，在 UI 线程触发代码。
|
||||
''' </summary>
|
||||
Public Event OnStateChangedUi(Loader As LoaderBase, NewState As LoadState, OldState As LoadState)
|
||||
''' <summary>
|
||||
''' 简易的在 UI 线程添加触发事件的方式。主要用于在新建 Loader 时直接使用 With 绑定事件，以及进行老代码兼容。
|
||||
''' </summary>
|
||||
Public WriteOnly Property OnStateChanged As Action(Of LoaderBase)
|
||||
Set(value As Action(Of LoaderBase))
|
||||
AddHandler OnStateChangedUi, Sub(Loader As LoaderBase, NewState As LoadState, OldState As LoadState) value(Loader)
|
||||
End Set
|
||||
End Property
|
||||
|
||||
''' <summary>
|
||||
''' 在加载器目标事件执行完成，加载器状态即将变为 Finish 时调用。可以视为扩展加载器目标事件。
|
||||
''' </summary>
|
||||
Public Event PreviewFinish(Loader As LoaderBase)
|
||||
Protected Sub RaisePreviewFinish()
|
||||
RaiseEvent PreviewFinish(Me)
|
||||
End Sub
|
||||
|
||||
'状态监控
|
||||
''' <summary>
|
||||
''' 加载器的状态。
|
||||
''' </summary>
|
||||
Public Property State As LoadState
|
||||
Get
|
||||
Return _State
|
||||
End Get
|
||||
Set(value As LoadState)
|
||||
If _State = value Then Exit Property
|
||||
Dim OldState = _State
|
||||
If value = LoadState.Finished AndAlso Setup.Get("SystemDebugDelay") Then Thread.Sleep(RandomInteger(100, 2000))
|
||||
_State = value
|
||||
Log("[Loader] 加载器 " & Name & " 状态改变：" & GetStringFromEnum(value))
|
||||
'实现 ILoadingTrigger 接口与 OnStateChanged 回调
|
||||
RunInUi(Sub()
|
||||
Select Case value
|
||||
Case LoadState.Loading
|
||||
LoadingState = MyLoading.MyLoadingState.Run
|
||||
Case LoadState.Failed
|
||||
LoadingState = MyLoading.MyLoadingState.Error
|
||||
Case Else
|
||||
LoadingState = MyLoading.MyLoadingState.Stop
|
||||
End Select
|
||||
RaiseEvent OnStateChangedUi(Me, value, OldState)
|
||||
End Sub)
|
||||
If HasOnStateChangedThread Then RunInThread(Sub() RaiseEvent OnStateChangedThread(Me, value, OldState))
|
||||
End Set
|
||||
End Property
|
||||
Private _State As LoadState = LoadState.Waiting
|
||||
Public Property LoadingState As MyLoading.MyLoadingState Implements ILoadingTrigger.LoadingState
|
||||
Get
|
||||
Return _LoadingState
|
||||
End Get
|
||||
Set(value As MyLoading.MyLoadingState)
|
||||
If _LoadingState = value Then Exit Property
|
||||
Dim OldState = _LoadingState
|
||||
_LoadingState = value
|
||||
RaiseEvent LoadingStateChanged(value, OldState)
|
||||
End Set
|
||||
End Property
|
||||
Private _LoadingState As MyLoading.MyLoadingState = MyLoading.MyLoadingState.Stop
|
||||
Public Event LoadingStateChanged(NewState As MyLoading.MyLoadingState, OldState As MyLoading.MyLoadingState) Implements ILoadingTrigger.LoadingStateChanged
|
||||
''' <summary>
|
||||
''' 若加载器出错，可提供给外部参考的异常。
|
||||
''' </summary>
|
||||
Public Property [Error] As Exception = Nothing
|
||||
''' <summary>
|
||||
''' 使用 LoaderCombo 加载时，该任务是否会阻碍后续任务的进行。
|
||||
''' </summary>
|
||||
Public Block As Boolean = True
|
||||
''' <summary>
|
||||
''' 该加载器是否显示在列表中。
|
||||
''' </summary>
|
||||
Public Show As Boolean = True
|
||||
''' <summary>
|
||||
''' 当前加载器是否由 IsForceRestart 强制调起。
|
||||
''' 这个属性自身不会干任何事，而是提供给加载器执行的函数，使得加载器调用另一个加载器时，可以继承强制重启属性。
|
||||
''' </summary>
|
||||
Public IsForceRestarting As Boolean = False
|
||||
|
||||
'进度监控
|
||||
''' <summary>
|
||||
''' 加载器的执行进度，为 0 至 1 的小数。
|
||||
''' </summary>
|
||||
Public Overridable Property Progress As Double
|
||||
Get
|
||||
Select Case State
|
||||
Case LoadState.Waiting
|
||||
Return 0
|
||||
Case LoadState.Loading
|
||||
Return If(_Progress = -1, 0.02, _Progress)
|
||||
Case Else
|
||||
Return 1
|
||||
End Select
|
||||
End Get
|
||||
Set(value As Double)
|
||||
_Progress = value
|
||||
End Set
|
||||
End Property
|
||||
Private _Progress As Double = -1
|
||||
''' <summary>
|
||||
''' 计算总进度时的权重。它应该为预计时间（秒）。
|
||||
''' </summary>
|
||||
Public Property ProgressWeight As Double = 1
|
||||
|
||||
'状态变化
|
||||
Public MustOverride Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
|
||||
Public MustOverride Sub Abort()
|
||||
|
||||
'等待结束
|
||||
Public Const WaitForExitTimeoutMessage As String = "等待加载器执行超时。"
|
||||
|
||||
''' <summary>
|
||||
''' 无限期地等待加载器完成，直到结束或抛出异常。若加载器尚未开始，则会开始执行。
|
||||
''' </summary>
|
||||
Public Sub WaitForExit(Optional Input As Object = Nothing, Optional LoaderToSyncProgress As LoaderBase = Nothing, Optional IsForceRestart As Boolean = False)
|
||||
Start(Input, IsForceRestart)
|
||||
Do While State = LoadState.Loading
|
||||
If LoaderToSyncProgress IsNot Nothing Then LoaderToSyncProgress.Progress = Progress
|
||||
Thread.Sleep(10)
|
||||
Loop
|
||||
If State = LoadState.Finished Then
|
||||
Exit Sub
|
||||
ElseIf State = LoadState.Aborted Then
|
||||
Throw New ThreadInterruptedException("加载器执行已中断。")
|
||||
ElseIf IsNothing([Error]) Then
|
||||
Throw New Exception("未知错误！")
|
||||
Else
|
||||
Throw New Exception([Error].Message, [Error]) '保留调用堆栈，同时不影响信息输出与单元测试
|
||||
End If
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 等待加载器完成，直到结束、抛出异常或超时。若加载器尚未开始，则会开始执行。
|
||||
''' </summary>
|
||||
''' <param name="Timeout">等待的超时时间，以毫秒为单位。</param>
|
||||
''' <param name="TimeoutMessage">若执行超时，将会抛出的异常信息。</param>
|
||||
Public Sub WaitForExitTime(Timeout As Integer, Optional Input As Object = Nothing, Optional TimeoutMessage As String = WaitForExitTimeoutMessage, Optional LoaderToSyncProgress As Object = Nothing, Optional IsForceRestart As Boolean = False)
|
||||
Start(Input, IsForceRestart)
|
||||
Do While State = LoadState.Loading
|
||||
If LoaderToSyncProgress IsNot Nothing Then LoaderToSyncProgress.Progress = Progress
|
||||
Thread.Sleep(10)
|
||||
Timeout -= 10
|
||||
If Timeout < 0 Then Throw New TimeoutException(TimeoutMessage)
|
||||
Loop
|
||||
If State = LoadState.Finished Then
|
||||
Exit Sub
|
||||
ElseIf State = LoadState.Aborted Then
|
||||
Throw New ThreadInterruptedException("加载器执行已中断。")
|
||||
ElseIf IsNothing([Error]) Then
|
||||
Throw New Exception("未知错误！")
|
||||
Else
|
||||
Throw [Error]
|
||||
End If
|
||||
End Sub
|
||||
|
||||
'相同重载
|
||||
Public Overrides Function Equals(obj As Object) As Boolean
|
||||
Dim base = TryCast(obj, LoaderBase)
|
||||
Return base IsNot Nothing AndAlso Uuid = base.Uuid
|
||||
End Function
|
||||
|
||||
End Class
|
||||
''' <summary>
|
||||
''' 用于异步执行并监控单一函数的加载器。
|
||||
''' </summary>
|
||||
Public Class LoaderTask(Of InputType, OutputType)
|
||||
Inherits LoaderBase
|
||||
|
||||
'线程设定
|
||||
Protected Friend ThreadPriority As ThreadPriority
|
||||
'执行事件
|
||||
Protected Friend LoadDelegate As Action(Of LoaderTask(Of InputType, OutputType))
|
||||
Protected Friend InputDelegate As Func(Of Object)
|
||||
'状态指示
|
||||
''' <summary>
|
||||
''' 当前执行线程是否应当中断。只应用在加载器的工作线程中判断，不可跨线程调用。
|
||||
''' </summary>
|
||||
Public ReadOnly Property IsAborted As Boolean
|
||||
Get
|
||||
Return LastRunningThread Is Nothing OrElse Not ReferenceEquals(Thread.CurrentThread, LastRunningThread)
|
||||
End Get
|
||||
End Property
|
||||
''' <summary>
|
||||
''' 在输入相同时使用原有结果的超时，单位为毫秒。
|
||||
''' </summary>
|
||||
Public ReloadTimeout As Integer = -1
|
||||
''' <summary>
|
||||
''' 上次完成加载时的时间。
|
||||
''' </summary>
|
||||
Public LastFinishedTime As Long = 0
|
||||
''' <summary>
|
||||
''' 最后一次运行加载器的线程。可能为 Nothing，或线程已结束。
|
||||
''' </summary>
|
||||
Public LastRunningThread As Thread = Nothing
|
||||
'输入输出
|
||||
Public Input As InputType = Nothing
|
||||
Public Output As OutputType = Nothing
|
||||
|
||||
'获取输入
|
||||
Public Function StartGetInput(Optional Input As InputType = Nothing, Optional InputDelegate As Func(Of Object) = Nothing) As InputType
|
||||
If InputDelegate Is Nothing Then InputDelegate = Me.InputDelegate
|
||||
Dim NewInput As InputType = Nothing '若 InputType 不能为 Nothing，则会导致 Input Is Nothing 永远失败，因此需要额外判断
|
||||
If (Input Is Nothing OrElse (NewInput IsNot Nothing AndAlso Input.Equals(NewInput))) AndAlso InputDelegate IsNot Nothing Then
|
||||
RunInUiWait(Sub() Input = InputDelegate())
|
||||
End If
|
||||
Return Input
|
||||
End Function
|
||||
'代码执行
|
||||
Public Function ShouldStart(ByRef Input As Object, Optional IsForceRestart As Boolean = False, Optional IgnoreReloadTimeout As Boolean = False) As Boolean
|
||||
'获取输入
|
||||
Try
|
||||
Input = StartGetInput(Input)
|
||||
Catch ex As Exception
|
||||
Log(ex, "加载输入获取失败（" & Name & "）", LogLevel.Hint)
|
||||
[Error] = ex
|
||||
SyncLock LockState
|
||||
State = LoadState.Failed
|
||||
End SyncLock
|
||||
End Try
|
||||
'检验输入以确定情况
|
||||
If (Not IsForceRestart) AndAlso '不要求强行重启
|
||||
((Input IsNot Nothing AndAlso Input.Equals(Me.Input)) OrElse (Input Is Nothing AndAlso Me.Input Is Nothing)) AndAlso '输入相同
|
||||
(State = LoadState.Loading OrElse State = LoadState.Finished) AndAlso '正在加载或已加载成功
|
||||
(IgnoreReloadTimeout OrElse ReloadTimeout = -1 OrElse LastFinishedTime = 0 OrElse GetTimeTick() - LastFinishedTime < ReloadTimeout) Then '没有超时
|
||||
'如果输入相同且未出错则不重试
|
||||
Return False
|
||||
Else
|
||||
'需要开始
|
||||
Return True
|
||||
End If
|
||||
End Function
|
||||
Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
|
||||
'确认是否开始加载
|
||||
If ShouldStart(Input, IsForceRestart) Then
|
||||
'输入不同或失败，开始加载
|
||||
If State = LoadState.Loading Then TriggerThreadAbort()
|
||||
Me.Input = Input
|
||||
SyncLock LockState
|
||||
State = LoadState.Loading
|
||||
End SyncLock
|
||||
Else
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
LastRunningThread = New Thread(
|
||||
Sub()
|
||||
Try
|
||||
IsForceRestarting = IsForceRestart
|
||||
If ModeDebug Then Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已启动")
|
||||
LoadDelegate(Me)
|
||||
If IsAborted Then
|
||||
Log("[Loader] 加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已中断但线程正常运行至结束，输出被弃用（最新线程：" & If(LastRunningThread Is Nothing, -1, LastRunningThread.ManagedThreadId) & "）", LogLevel.Developer)
|
||||
Else
|
||||
RaisePreviewFinish()
|
||||
State = LoadState.Finished
|
||||
LastFinishedTime = GetTimeTick() '未中断，本次输出有效
|
||||
End If
|
||||
Catch ex As ThreadInterruptedException
|
||||
If ModeDebug Then Log(ex, "加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 已触发线程中断")
|
||||
'如果线程是因为判断到 IsAborted 而提前中止，则代表已有新线程被重启，此时不应当改为 Aborted
|
||||
'如果线程是在没有 IsAborted 时手动引发了 ThreadInterruptedException，则代表没有重启线程，这通常代表用户手动取消，应当改为 Aborted
|
||||
If Not IsAborted Then State = LoadState.Aborted
|
||||
Catch ex As Exception
|
||||
If IsAborted Then Exit Sub
|
||||
Log(ex, "加载线程 " & Name & " (" & Thread.CurrentThread.ManagedThreadId & ") 发生运行时错误", LogLevel.Developer)
|
||||
[Error] = ex
|
||||
State = LoadState.Failed
|
||||
End Try
|
||||
End Sub) With {.Name = Name, .Priority = ThreadPriority}
|
||||
LastRunningThread.Start() '不能使用 RunInNewThread，否则在函数返回前线程就会运行完，导致误判 IsAborted
|
||||
End Sub
|
||||
Public Overrides Sub Abort()
|
||||
If State <> LoadState.Loading Then Exit Sub
|
||||
SyncLock LockState
|
||||
State = LoadState.Aborted
|
||||
End SyncLock
|
||||
TriggerThreadAbort()
|
||||
End Sub
|
||||
Private Sub TriggerThreadAbort()
|
||||
If LastRunningThread Is Nothing Then Exit Sub
|
||||
If ModeDebug Then Log("[Loader] 加载线程 " & Name & " (" & LastRunningThread.ManagedThreadId & ") 已中断")
|
||||
If LastRunningThread.IsAlive Then LastRunningThread.Interrupt()
|
||||
LastRunningThread = Nothing
|
||||
End Sub
|
||||
|
||||
Public Sub New()
|
||||
'仅仅是为了避免一些智障报错（继承类必须重写 New 的情况）
|
||||
End Sub
|
||||
Public Sub New(Name As String, LoadDelegate As Action(Of LoaderTask(Of InputType, OutputType)), Optional InputDelegate As Func(Of InputType) = Nothing, Optional Priority As ThreadPriority = ThreadPriority.Normal)
|
||||
Me.Name = Name
|
||||
Me.LoadDelegate = LoadDelegate
|
||||
Me.InputDelegate = InputDelegate
|
||||
ThreadPriority = Priority
|
||||
End Sub
|
||||
|
||||
End Class
|
||||
''' <summary>
|
||||
''' 支持多个加载器连续运作的复合加载器。
|
||||
''' </summary>
|
||||
Public Class LoaderCombo(Of InputType)
|
||||
Inherits LoaderBase
|
||||
|
||||
Public Overrides Property Progress() As Double
|
||||
Get
|
||||
Select Case State
|
||||
Case LoadState.Waiting
|
||||
Return 0
|
||||
Case LoadState.Loading
|
||||
Dim Total As Double = 0, Finished As Double = 0
|
||||
For Each Loader In Loaders
|
||||
Total += Loader.ProgressWeight
|
||||
Finished += Loader.ProgressWeight * Loader.Progress
|
||||
Next
|
||||
If Total = 0 Then Return 0
|
||||
Return Finished / Total
|
||||
Case Else
|
||||
Return 1
|
||||
End Select
|
||||
End Get
|
||||
Set(value As Double)
|
||||
Throw New Exception("多重加载器不支持设置进度")
|
||||
End Set
|
||||
End Property
|
||||
|
||||
Public Loaders As New List(Of LoaderBase)
|
||||
Public Input As InputType
|
||||
Public Sub New(Name As String, Loaders As IEnumerable(Of LoaderBase))
|
||||
Me.Loaders.Clear()
|
||||
For Each Loader As LoaderBase In Loaders
|
||||
If Loader IsNot Nothing Then
|
||||
Me.Loaders.Add(Loader)
|
||||
AddHandler Loader.OnStateChangedThread, AddressOf SubTaskStateChanged
|
||||
Loader.HasOnStateChangedThread = True
|
||||
End If
|
||||
Next
|
||||
InitParent(Nothing)
|
||||
Me.Name = Name
|
||||
End Sub
|
||||
Public Overrides Sub InitParent(Parent As LoaderBase)
|
||||
Me.Parent = Parent
|
||||
For Each Loader In Loaders
|
||||
Loader.InitParent(Me)
|
||||
Next
|
||||
End Sub
|
||||
Public Overrides Sub Start(Optional Input As Object = Nothing, Optional IsForceRestart As Boolean = False)
|
||||
IsForceRestarting = IsForceRestart
|
||||
'改变状态
|
||||
SyncLock LockState
|
||||
If State = LoadState.Loading Then
|
||||
Exit Sub
|
||||
Else
|
||||
State = LoadState.Loading
|
||||
End If
|
||||
End SyncLock
|
||||
'启动加载
|
||||
Me.Input = Input
|
||||
If IsForceRestart Then
|
||||
For Each Loader In Loaders
|
||||
Loader.State = LoadState.Waiting
|
||||
Next
|
||||
End If
|
||||
Update()
|
||||
End Sub
|
||||
Public Overrides Sub Abort()
|
||||
'改变状态
|
||||
SyncLock LockState
|
||||
If State = LoadState.Loading OrElse State = LoadState.Waiting Then
|
||||
State = LoadState.Aborted
|
||||
Else
|
||||
Exit Sub
|
||||
End If
|
||||
End SyncLock
|
||||
RunInThread(Sub()
|
||||
'中断加载器
|
||||
For Each Loader In Loaders
|
||||
Loader.Abort()
|
||||
Next
|
||||
'从列表删除
|
||||
SyncLock LoaderTaskbarLock
|
||||
If LoaderTaskbar.Contains(Me) Then LoaderTaskbar.Remove(Me)
|
||||
End SyncLock
|
||||
End Sub)
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 子任务状态变更。
|
||||
''' </summary>
|
||||
Private Sub SubTaskStateChanged(Loader As LoaderBase, NewState As LoadState, OldState As LoadState)
|
||||
Select Case NewState
|
||||
Case LoadState.Loading
|
||||
'开始，啥都不干
|
||||
Case LoadState.Waiting
|
||||
'子加载器可能由于外部输入改变而暂时变为 Waiting，之后会立即重新启动
|
||||
'所以啥都不干就行
|
||||
Case LoadState.Finished
|
||||
'正常结束，触发刷新
|
||||
Update()
|
||||
Case LoadState.Aborted
|
||||
'被中断，这个任务也中断
|
||||
Abort()
|
||||
Case Else
|
||||
'完蛋，出错了
|
||||
SyncLock LockState
|
||||
If State >= LoadState.Finished Then Exit Sub
|
||||
[Error] = New Exception(Loader.Name & "失败", Loader.Error)
|
||||
State = Loader.State
|
||||
End SyncLock
|
||||
For Each Loader In Loaders
|
||||
Loader.Abort()
|
||||
Next
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
Exit Sub
|
||||
End Select
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 触发一次更新，以启动新加载器或完成。
|
||||
''' </summary>
|
||||
Private Sub Update()
|
||||
If State = LoadState.Finished OrElse State = LoadState.Failed OrElse State = LoadState.Aborted Then Exit Sub
|
||||
Dim IsFinished As Boolean = True
|
||||
Dim Ignore As Boolean = False
|
||||
Dim Input As Object = Me.Input
|
||||
For Each Loader In Loaders
|
||||
Select Case Loader.State
|
||||
Case LoadState.Finished
|
||||
'检查是否需要重启
|
||||
If Loader.GetType.Name.StartsWith("LoaderTask") Then '类型名后面带有泛型，必须用 StartsWith
|
||||
If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
|
||||
If ModeDebug Then Log("[Loader] 由于输入条件变更，重启已完成的加载器 " & Loader.Name)
|
||||
GoTo Restart
|
||||
End If
|
||||
'更新下一个加载器的输入
|
||||
Input = CType(Loader, Object).Output
|
||||
End If
|
||||
Case LoadState.Loading
|
||||
'检查是否需要重启
|
||||
If Loader.GetType.Name.StartsWith("LoaderTask") Then
|
||||
If CType(Loader, Object).ShouldStart(If(Input IsNot Nothing AndAlso Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IgnoreReloadTimeout:=True) Then
|
||||
If ModeDebug Then Log("[Loader] 由于输入条件变更，重启进行中的加载器 " & Loader.Name, LogLevel.Developer)
|
||||
GoTo Restart
|
||||
End If
|
||||
End If
|
||||
'已经有正在加载中的了，不需要再启动了
|
||||
IsFinished = False
|
||||
Ignore = True
|
||||
Case Else
|
||||
Restart:
|
||||
'未启动，则启动加载器
|
||||
IsFinished = False
|
||||
If Ignore Then Continue For
|
||||
If Input IsNot Nothing Then
|
||||
'若输入类型与下一个加载器相同才继续
|
||||
Dim LoaderType As String = Loader.GetType.Name
|
||||
If LoaderType.StartsWith("LoaderTask") OrElse LoaderType.StartsWith("LoaderCombo") Then
|
||||
Loader.Start(If(Loader.GetType.GenericTypeArguments.First Is Input.GetType, Input, Nothing), IsForceRestarting)
|
||||
ElseIf LoaderType.StartsWith("LoaderDownload") Then
|
||||
Loader.Start(If(TypeOf Input Is List(Of NetFile), Input, Nothing), IsForceRestarting)
|
||||
Else
|
||||
Throw New Exception("未知的加载器类型（" & LoaderType & "）")
|
||||
End If
|
||||
Else
|
||||
Loader.Start(IsForceRestart:=IsForceRestarting)
|
||||
End If
|
||||
'如果不让继续启动，那就不启动呗
|
||||
If Loader.Block Then Ignore = True
|
||||
End Select
|
||||
Next
|
||||
If IsFinished Then
|
||||
'顺利完成，贼棒
|
||||
RaisePreviewFinish()
|
||||
State = LoadState.Finished
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
End If
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 获得最底层的，应被显示给用户的加载器列表，并追加于 List。
|
||||
''' </summary>
|
||||
Public Shared Sub GetLoaderList(Loader As Object, ByRef List As List(Of LoaderBase), Optional RequireShow As Boolean = True)
|
||||
For Each SubLoader In Loader.Loaders
|
||||
If SubLoader.Show OrElse Not RequireShow Then List.Add(SubLoader)
|
||||
If SubLoader.GetType.Name.StartsWith("LoaderCombo") Then GetLoaderList(SubLoader, List)
|
||||
Next
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 获得最底层的，应被显示给用户的加载器列表，并追加于 List。
|
||||
''' </summary>
|
||||
Public Sub GetLoaderList(ByRef List As List(Of LoaderBase), Optional RequireShow As Boolean = True)
|
||||
GetLoaderList(Me, List, RequireShow)
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 获得最底层的，应被显示给用户的加载器列表。
|
||||
''' </summary>
|
||||
Public Function GetLoaderList(Optional RequireShow As Boolean = True) As List(Of LoaderBase)
|
||||
Dim List As New List(Of LoaderBase)
|
||||
GetLoaderList(List, RequireShow)
|
||||
Return List
|
||||
End Function
|
||||
|
||||
End Class
|
||||
|
||||
'任务栏进度条
|
||||
Public LoaderTaskbarLock As New Object
|
||||
Public LoaderTaskbar As New List(Of LoaderBase)
|
||||
Public LoaderTaskbarProgress As Double = 0 '平滑后的进度
|
||||
Private LoaderTaskbarProgressLast As Shell.TaskbarItemProgressState = Shell.TaskbarItemProgressState.None
|
||||
|
||||
Public Sub LoaderTaskbarAdd(Loader As LoaderBase)
|
||||
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRemove(Loader)
|
||||
SyncLock LoaderTaskbarLock
|
||||
LoaderTaskbar.Add(Loader)
|
||||
End SyncLock
|
||||
End Sub
|
||||
Public Sub LoaderTaskbarProgressRefresh()
|
||||
Try
|
||||
Dim NewState As Shell.TaskbarItemProgressState
|
||||
Dim NewProgress As Double = LoaderTaskbarProgressGet()
|
||||
'检查任务是否完成，若完成则移除
|
||||
SyncLock LoaderTaskbarLock
|
||||
'外显任务是否已经全部完成
|
||||
Dim IsAllDownloadTaskCompleted As Boolean = True
|
||||
For Each Loader In LoaderTaskbar
|
||||
If Loader.Show AndAlso Loader.State = LoadState.Loading Then IsAllDownloadTaskCompleted = False
|
||||
Next
|
||||
'若单个任务已中止或全部任务已完成，则刷新并移除
|
||||
Dim RemovedTask As New List(Of LoaderBase)
|
||||
For i = 0 To LoaderTaskbar.Count - 1
|
||||
If (IsAllDownloadTaskCompleted OrElse LoaderTaskbar(i).State = LoadState.Aborted) AndAlso LoaderTaskbar(i).Show Then
|
||||
If FrmSpeedLeft IsNot Nothing Then FrmSpeedLeft.TaskRefresh(LoaderTaskbar(i))
|
||||
RemovedTask.Add(LoaderTaskbar(i))
|
||||
End If
|
||||
Next
|
||||
For Each Task In RemovedTask
|
||||
LoaderTaskbar.Remove(Task)
|
||||
Next
|
||||
End SyncLock
|
||||
'更新平滑后的进度
|
||||
If NewProgress <= 0 OrElse NewProgress >= 1 OrElse LoaderTaskbarProgress > NewProgress Then
|
||||
LoaderTaskbarProgress = NewProgress
|
||||
Else
|
||||
LoaderTaskbarProgress = LoaderTaskbarProgress * 0.9 + NewProgress * 0.1
|
||||
End If
|
||||
'更新任务栏信息
|
||||
If LoaderTaskbar.Count = 0 OrElse LoaderTaskbarProgress = 1 Then
|
||||
NewState = Shell.TaskbarItemProgressState.None
|
||||
ElseIf LoaderTaskbarProgress < 0.015 Then
|
||||
NewState = Shell.TaskbarItemProgressState.Indeterminate
|
||||
Else
|
||||
NewState = Shell.TaskbarItemProgressState.Normal
|
||||
FrmMain.TaskbarItemInfo.ProgressValue = LoaderTaskbarProgress
|
||||
End If
|
||||
If LoaderTaskbarProgressLast <> NewState Then
|
||||
LoaderTaskbarProgressLast = NewState
|
||||
FrmMain.TaskbarItemInfo.ProgressState = NewState
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "刷新任务栏进度显示失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub
|
||||
Public Function LoaderTaskbarProgressGet() As Double
|
||||
Try
|
||||
Dim Total As Double = 0, Count As Integer = 0
|
||||
SyncLock LoaderTaskbarLock
|
||||
For i = 0 To LoaderTaskbar.Count - 1
|
||||
Total += LoaderTaskbar(i).Progress
|
||||
Count += 1 '避免多线程影响导致计数出错
|
||||
Next
|
||||
End SyncLock
|
||||
If Count = 0 Then Return 1
|
||||
Return MathRange(Total / Count, 0, 1)
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取任务栏进度出错", LogLevel.Feedback)
|
||||
Return 0.5
|
||||
End Try
|
||||
End Function
|
||||
|
||||
'文件夹刷新类委托
|
||||
Private LoaderFolderDictionary As New Dictionary(Of LoaderBase, LoaderFolderDictionaryEntry)
|
||||
Private Structure LoaderFolderDictionaryEntry
|
||||
Public LastCheckTime As Date?
|
||||
Public FolderPath As String
|
||||
Public Overrides Function Equals(obj As Object) As Boolean
|
||||
If TypeOf obj IsNot LoaderFolderDictionaryEntry Then Return False
|
||||
Dim entry = DirectCast(obj, LoaderFolderDictionaryEntry)
|
||||
Return EqualityComparer(Of Date?).Default.Equals(LastCheckTime, entry.LastCheckTime) AndAlso
|
||||
FolderPath = entry.FolderPath
|
||||
End Function
|
||||
End Structure
|
||||
Public Enum LoaderFolderRunType
|
||||
RunOnUpdated
|
||||
ForceRun
|
||||
UpdateOnly
|
||||
End Enum
|
||||
''' <summary>
|
||||
''' 执行以文件夹检测作为输入的加载器。加载器需以文件夹路径为输入值。
|
||||
''' 返回是否执行了加载器。
|
||||
''' </summary>
|
||||
''' <param name="ExtraPath">用于检查文件夹修改的额外路径。该路径不会传入加载器。</param>
|
||||
Public Function LoaderFolderRun(Loader As LoaderBase, FolderPath As String, Type As LoaderFolderRunType, Optional MaxDepth As Integer = 0, Optional ExtraPath As String = "", Optional WaitForExit As Boolean = False) As Boolean
|
||||
Dim FolderInfo As DirectoryInfo
|
||||
Dim Value As New LoaderFolderDictionaryEntry With {.FolderPath = FolderPath & ExtraPath, .LastCheckTime = Nothing}
|
||||
Try
|
||||
'获取数据
|
||||
FolderInfo = New DirectoryInfo(FolderPath & ExtraPath)
|
||||
Value.LastCheckTime = If(FolderInfo.Exists, GetActualLastWriteTimeUtc(FolderInfo, MaxDepth), DirectCast(Nothing, Date?))
|
||||
'如果已经检查过，则跳过
|
||||
If Type = LoaderFolderRunType.RunOnUpdated AndAlso LoaderFolderDictionary.ContainsKey(Loader) Then
|
||||
If FolderInfo.Exists Then
|
||||
If LoaderFolderDictionary(Loader).LastCheckTime IsNot Nothing AndAlso
|
||||
Value.Equals(LoaderFolderDictionary(Loader)) Then Return False
|
||||
Else
|
||||
If LoaderFolderDictionary(Loader).LastCheckTime Is Nothing Then Return False
|
||||
End If
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "文件夹加载器启动检测出错")
|
||||
End Try
|
||||
'写入检查数据
|
||||
DictionaryAdd(LoaderFolderDictionary, Loader, Value)
|
||||
'开始检查
|
||||
If Type = LoaderFolderRunType.UpdateOnly Then Return False
|
||||
If WaitForExit Then
|
||||
Loader.WaitForExit(FolderPath, IsForceRestart:=True)
|
||||
Else
|
||||
Loader.Start(FolderPath, IsForceRestart:=True)
|
||||
End If
|
||||
Return True
|
||||
End Function
|
||||
Private Function GetActualLastWriteTimeUtc(FolderInfo As DirectoryInfo, MaxDepth As Integer) As Date
|
||||
Dim Time As Date = FolderInfo.LastWriteTimeUtc
|
||||
If MaxDepth > 0 Then
|
||||
For Each Folder In FolderInfo.EnumerateDirectories
|
||||
Dim FolderTime As Date = GetActualLastWriteTimeUtc(Folder, MaxDepth - 1)
|
||||
If FolderTime > Time Then Time = FolderTime
|
||||
Next
|
||||
End If
|
||||
Return Time
|
||||
End Function
|
||||
|
||||
End Module
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,315 @@
|
||||
'提供不同的输入验证方法，名称以 Validate 开头
|
||||
|
||||
''' <summary>
|
||||
''' 输入验证规则基类。要查看所有的输入验证规则，可在输入 Validate 后查看自动补全。
|
||||
''' </summary>
|
||||
Public MustInherit Class Validate
|
||||
''' <summary>
|
||||
''' 验证某字符串是否符合验证要求。若符合，返回空字符串；若不符合，返回错误原因。
|
||||
''' </summary>
|
||||
Public MustOverride Function Validate(Str As String) As String
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 若为空则直接通过检查。
|
||||
''' </summary>
|
||||
Public Class ValidateNullable
|
||||
Inherits Validate
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If IsNothing(Str) OrElse String.IsNullOrEmpty(Str) Then Return Nothing
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 不能为 Nothing 或空字符串（不包括全空格检查）。
|
||||
''' </summary>
|
||||
Public Class ValidateNullOrEmpty
|
||||
Inherits Validate
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If IsNothing(Str) OrElse String.IsNullOrEmpty(Str) Then Return "输入内容不能为空！"
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 不能为 Nothing 或空字符串（包括全空格检查）。
|
||||
''' </summary>
|
||||
Public Class ValidateNullOrWhiteSpace
|
||||
Inherits Validate
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If IsNothing(Str) OrElse String.IsNullOrWhiteSpace(Str) Then Return "输入内容不能为空！"
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 必须满足正则表达式。
|
||||
''' </summary>
|
||||
Public Class ValidateRegex
|
||||
Inherits Validate
|
||||
Public Property Regex As String
|
||||
Public Property ErrorDescription As String = ""
|
||||
Public Sub New()
|
||||
End Sub '用于 XAML 初始化
|
||||
Public Sub New(Regex As String, Optional ErrorDescription As String = "")
|
||||
Me.Regex = Regex
|
||||
Me.ErrorDescription = ErrorDescription
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Not RegexCheck(Str, Regex) Then Return ErrorDescription
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 必须是一个完整网址。
|
||||
''' </summary>
|
||||
Public Class ValidateHttp
|
||||
Inherits Validate
|
||||
Public Sub New()
|
||||
End Sub '用于 XAML 初始化
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Str.EndsWith("/") Then Str = Str.Substring(0, Str.Length - 1)
|
||||
If Not RegexCheck(Str, "^(http[s]?)\://") Then Return "输入的网址无效！"
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 必须为整数。
|
||||
''' </summary>
|
||||
Public Class ValidateInteger
|
||||
Inherits Validate
|
||||
Public Property Min As Integer
|
||||
Public Property Max As Integer = Integer.MaxValue
|
||||
Public Sub New()
|
||||
End Sub '用于 XAML 初始化
|
||||
Public Sub New(Min As Integer, Max As Integer)
|
||||
Me.Min = Min
|
||||
Me.Max = Max
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Str.Length > 9 Then Return "请输入一个大小合理的数字！"
|
||||
Dim Valed As Integer = Val(Str)
|
||||
If Valed.ToString <> Str Then Return "请输入一个整数！"
|
||||
If Val(Str) > Max Then Return "不可超过 " & Max & "！"
|
||||
If Val(Str) < Min Then Return "不可低于 " & Min & "！"
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 长度限制。
|
||||
''' </summary>
|
||||
Public Class ValidateLength
|
||||
Inherits Validate
|
||||
Public Property Min As Integer = 0
|
||||
Public Property Max As Integer = Integer.MaxValue
|
||||
Public Sub New()
|
||||
End Sub '用于 XAML 初始化
|
||||
Public Sub New(Min As Integer, Optional Max As Integer = Integer.MaxValue)
|
||||
Me.Min = Min
|
||||
Me.Max = Max
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Len(Str) <> Max AndAlso Max = Min Then Return "长度必须为 " & Max & " 个字符！"
|
||||
If Len(Str) > Max Then Return "长度最长为 " & Max & " 个字符！"
|
||||
If Len(Str) < Min Then Return "长度至少需 " & Min & " 个字符！"
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 不能包含某些特定字符串。忽略大小写。
|
||||
''' </summary>
|
||||
Public Class ValidateExcept
|
||||
Inherits Validate
|
||||
Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String)
|
||||
Public Property ErrorMessage As String
|
||||
Public Sub New()
|
||||
ErrorMessage = "输入内容不能包含 %！"
|
||||
End Sub '用于 XAML 初始化
|
||||
Public Sub New(Excepts As ObjectModel.Collection(Of String), Optional ErrorMessage As String = "输入内容不能包含 %！")
|
||||
Me.Excepts = Excepts
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
End Sub
|
||||
Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能包含 %！")
|
||||
Me.Excepts = New ObjectModel.Collection(Of String)
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
For Each Data As String In Excepts
|
||||
Me.Excepts.Add(Data)
|
||||
Next
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
For Each Ch As String In Excepts
|
||||
If Str.IndexOf(Ch, StringComparison.OrdinalIgnoreCase) >= 0 Then
|
||||
If IsNothing(ErrorMessage) Then ErrorMessage = ""
|
||||
Return ErrorMessage.Replace("%", Ch)
|
||||
End If
|
||||
Next
|
||||
Return ""
|
||||
End Function
|
||||
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 不能与某些特定字符串相同。
|
||||
''' </summary>
|
||||
Public Class ValidateExceptSame
|
||||
Inherits Validate
|
||||
Public Property Excepts As ObjectModel.Collection(Of String) = New ObjectModel.Collection(Of String)
|
||||
Public Property ErrorMessage As String
|
||||
Public Property IgnoreCase As Boolean = False
|
||||
Public Sub New(Excepts As ObjectModel.Collection(Of String), Optional ErrorMessage As String = "输入内容不能为 %！", Optional IgnoreCase As Boolean = False)
|
||||
Me.Excepts = Excepts
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
Me.IgnoreCase = IgnoreCase
|
||||
End Sub
|
||||
Public Sub New(Excepts As IEnumerable, Optional ErrorMessage As String = "输入内容不能为 %！", Optional IgnoreCase As Boolean = False)
|
||||
Me.Excepts = New ObjectModel.Collection(Of String)
|
||||
For Each Data As String In Excepts
|
||||
Me.Excepts.Add(Data)
|
||||
Next
|
||||
Me.ErrorMessage = ErrorMessage
|
||||
Me.IgnoreCase = IgnoreCase
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
If Str Is Nothing Then Return ErrorMessage.Replace("%", "null")
|
||||
For Each Ch As String In Excepts
|
||||
If IgnoreCase Then
|
||||
If Str.ToLower = Ch.ToLower Then Return ErrorMessage.Replace("%", Ch)
|
||||
Else
|
||||
If Str.Equals(Ch) Then Return ErrorMessage.Replace("%", Ch) '使用 = 不确定是否会忽略大小写
|
||||
End If
|
||||
Next
|
||||
Return ""
|
||||
End Function
|
||||
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 对文件夹名的粗略的特化检测。
|
||||
''' </summary>
|
||||
Public Class ValidateFolderName
|
||||
Inherits Validate
|
||||
Public Property Path As String
|
||||
Public Property UseMinecraftCharCheck As Boolean = True
|
||||
Public Property IgnoreCase As Boolean = True
|
||||
Private ReadOnly PathIgnore As IEnumerable(Of DirectoryInfo)
|
||||
Public Sub New(Path As String, Optional UseMinecraftCharCheck As Boolean = True, Optional IgnoreCase As Boolean = True)
|
||||
Me.Path = Path
|
||||
Me.IgnoreCase = IgnoreCase
|
||||
Me.UseMinecraftCharCheck = UseMinecraftCharCheck
|
||||
On Error Resume Next
|
||||
PathIgnore = New DirectoryInfo(Path).EnumerateDirectories
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
Try
|
||||
'检查是否为空
|
||||
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
'检查空格
|
||||
If Str.StartsWith(" ") Then Return "文件夹名不能以空格开头！"
|
||||
If Str.EndsWith(" ") Then Return "文件夹名不能以空格结尾！"
|
||||
'检查长度
|
||||
LengthCheck = New ValidateLength(1, 100).Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
'检查尾部小数点
|
||||
If Str.EndsWith(".") Then Return "文件夹名不能以小数点结尾！"
|
||||
'检查特殊字符
|
||||
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "文件夹名不可包含 % 字符！").Validate(Str)
|
||||
If Not CharactCheck = "" Then Return CharactCheck
|
||||
'检查特殊字符串
|
||||
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %！").Validate(Str)
|
||||
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
|
||||
'检查文件夹重名
|
||||
Dim Arr As New List(Of String)
|
||||
If PathIgnore IsNot Nothing Then
|
||||
For Each Folder As DirectoryInfo In PathIgnore
|
||||
Arr.Add(Folder.Name)
|
||||
Next
|
||||
End If
|
||||
Dim SameNameCheck = New ValidateExceptSame(Arr, "不可与现有文件夹重名！", IgnoreCase).Validate(Str)
|
||||
If Not SameNameCheck = "" Then Return SameNameCheck
|
||||
Return ""
|
||||
Catch ex As Exception
|
||||
Log(ex, "检查文件夹名出错")
|
||||
Return "错误：" & ex.Message
|
||||
End Try
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 要求输入一个可用的文件夹路径。
|
||||
''' </summary>
|
||||
Public Class ValidateFolderPath
|
||||
Inherits Validate
|
||||
Public Property UseMinecraftCharCheck As Boolean = True
|
||||
Public Sub New()
|
||||
End Sub
|
||||
Public Sub New(UseMinecraftCharCheck As Boolean)
|
||||
Me.UseMinecraftCharCheck = UseMinecraftCharCheck
|
||||
End Sub
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
'去除尾部斜线，统一为 \
|
||||
Str = Str.Replace("/", "\")
|
||||
If Not Str.TrimEnd("\").EndsWith(":") Then Str = Str.TrimEnd("\")
|
||||
'检查是否为空
|
||||
Dim LengthCheck As String = New ValidateNullOrWhiteSpace().Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
'检查长度
|
||||
LengthCheck = New ValidateLength(1, 254).Validate(Str)
|
||||
If Not LengthCheck = "" Then Return LengthCheck
|
||||
'检查开头
|
||||
If Str.StartsWith("\\Mac\") Then GoTo Fin
|
||||
For Each Drive As DriveInfo In My.Computer.FileSystem.Drives
|
||||
If Str.ToUpper = Drive.Name Then Return ""
|
||||
If Str.ToUpper.StartsWith(Drive.Name) Then GoTo Fin
|
||||
Next
|
||||
Return "文件夹路径头存在错误！"
|
||||
Fin:
|
||||
'对首层以外的路径检查
|
||||
For i = If(Str.StartsWith("\\Mac\"), 2, 1) To Str.Split("\").Count - 1
|
||||
Dim SubStr As String = Str.Split("\")(i)
|
||||
'检查是否为空
|
||||
Dim SubLengthCheck As String = New ValidateNullOrWhiteSpace().Validate(SubStr)
|
||||
If Not SubLengthCheck = "" Then Return "文件夹路径存在错误！"
|
||||
'检查特殊字符
|
||||
Dim CharactCheck As String = New ValidateExcept(IO.Path.GetInvalidFileNameChars() & If(UseMinecraftCharCheck, "!;", ""), "路径中存在无效字符！").Validate(SubStr)
|
||||
If Not CharactCheck = "" Then Return CharactCheck
|
||||
'检查头部空格
|
||||
If SubStr.StartsWith(" ") Then Return "文件夹名不能以空格开头！"
|
||||
If SubStr.EndsWith(" ") Then Return "文件夹名不能以空格结尾！"
|
||||
'检查尾部小数点
|
||||
If SubStr.EndsWith(".") Then Return "文件夹名不能以小数点结尾！"
|
||||
'检查特殊字符串
|
||||
Dim InvalidStrCheck As String = New ValidateExceptSame({"CON", "PRN", "AUX", "CLOCK$", "NUL", "COM0", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT0", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"}, "文件夹名不可为 %！").Validate(SubStr)
|
||||
If Not InvalidStrCheck = "" Then Return InvalidStrCheck
|
||||
Next
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
|
||||
''' <summary>
|
||||
''' 敏感词过滤。
|
||||
''' </summary>
|
||||
Public Class ValidateFilter
|
||||
Inherits Validate
|
||||
Private Shared Excepts As String() = SecretDecrypt(SecretSensitiveWordsRaw).Split("|")
|
||||
Public Sub New()
|
||||
End Sub '用于 XAML 初始化
|
||||
Public Overrides Function Validate(Str As String) As String
|
||||
'提取无间隔符的字符串
|
||||
Dim RealStr As String = ""
|
||||
For Each St In If(Str, "").ToLower
|
||||
If String.IsNullOrWhiteSpace(St.ToString) OrElse ("!@#$%^&*()_+-={}[]|\;':"",./<>? ~ ·！￥…（）—，。、《》？‘；：【】｛｝" & vbLQ & vbRQ).ToCharArray.Contains(St) Then Continue For
|
||||
RealStr += St
|
||||
Next
|
||||
'检查
|
||||
For Each Except In Excepts
|
||||
If RealStr.Contains(Except) Then Return "存在敏感内容！"
|
||||
Next
|
||||
Return ""
|
||||
End Function
|
||||
End Class
|
||||
@@ -0,0 +1,158 @@
|
||||
'一个万能的自动图片类型转换工具类
|
||||
|
||||
Public Class MyBitmap
|
||||
|
||||
''' <summary>
|
||||
''' 位图缓存。
|
||||
''' </summary>
|
||||
Public Shared BitmapCache As New Dictionary(Of String, MyBitmap)
|
||||
|
||||
''' <summary>
|
||||
''' 存储的图片
|
||||
''' </summary>
|
||||
Public Pic As System.Drawing.Bitmap
|
||||
|
||||
'自动类型转换
|
||||
'支持的类：Image，ImageSource，Bitmap，ImageBrush，BitmapSource
|
||||
Public Shared Widening Operator CType(Image As System.Drawing.Image) As MyBitmap
|
||||
Return New MyBitmap(Image)
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As MyBitmap) As System.Drawing.Image
|
||||
Return Image.Pic
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As ImageSource) As MyBitmap
|
||||
Return New MyBitmap(Image)
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As MyBitmap) As ImageSource
|
||||
Dim Bitmap = Image.Pic
|
||||
Dim rect = New System.Drawing.Rectangle(0, 0, Bitmap.Width, Bitmap.Height)
|
||||
Dim bitmapData = Bitmap.LockBits(rect, System.Drawing.Imaging.ImageLockMode.ReadWrite, System.Drawing.Imaging.PixelFormat.Format32bppArgb)
|
||||
Try
|
||||
Dim size = rect.Width * rect.Height * 4
|
||||
Return BitmapSource.Create(Bitmap.Width, Bitmap.Height, DPI, DPI, PixelFormats.Bgra32, Nothing, bitmapData.Scan0, size, bitmapData.Stride)
|
||||
Finally
|
||||
Bitmap.UnlockBits(bitmapData)
|
||||
End Try
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As System.Drawing.Bitmap) As MyBitmap
|
||||
Return New MyBitmap(Image)
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As MyBitmap) As System.Drawing.Bitmap
|
||||
Return Image.Pic
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As ImageBrush) As MyBitmap
|
||||
Return New MyBitmap(Image)
|
||||
End Operator
|
||||
Public Shared Widening Operator CType(Image As MyBitmap) As ImageBrush
|
||||
Return New ImageBrush(New MyBitmap(Image.Pic))
|
||||
End Operator
|
||||
|
||||
'构造函数
|
||||
Public Sub New()
|
||||
End Sub
|
||||
Public Sub New(FilePathOrResourceName As String)
|
||||
Try
|
||||
If FilePathOrResourceName.StartsWith(PathImage) Then
|
||||
'使用缓存
|
||||
If BitmapCache.ContainsKey(FilePathOrResourceName) Then
|
||||
Pic = BitmapCache(FilePathOrResourceName).Pic
|
||||
Else
|
||||
Pic = New MyBitmap(CType((New ImageSourceConverter).ConvertFromString(FilePathOrResourceName), ImageSource))
|
||||
BitmapCache.Add(FilePathOrResourceName, Pic)
|
||||
End If
|
||||
Else
|
||||
'使用这种自己接管 FileStream 的方法加载才能解除文件占用
|
||||
Using InputStream As New FileStream(FilePathOrResourceName, FileMode.Open)
|
||||
Pic = New System.Drawing.Bitmap(InputStream)
|
||||
InputStream.Dispose()
|
||||
End Using
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Pic = My.Application.TryFindResource(FilePathOrResourceName)
|
||||
If Pic Is Nothing Then
|
||||
Pic = New System.Drawing.Bitmap(1, 1)
|
||||
Log(ex, "加载位图失败（" & FilePathOrResourceName & "）")
|
||||
Throw
|
||||
Else
|
||||
Log(ex, "指定类型有误的位图加载（" & FilePathOrResourceName & "）", LogLevel.Developer)
|
||||
Exit Try
|
||||
End If
|
||||
End Try
|
||||
End Sub
|
||||
Public Sub New(Image As ImageSource)
|
||||
Using MS = New MemoryStream()
|
||||
Dim Encoder = New PngBitmapEncoder()
|
||||
Encoder.Frames.Add(BitmapFrame.Create(Image))
|
||||
Encoder.Save(MS)
|
||||
Pic = New System.Drawing.Bitmap(MS)
|
||||
End Using
|
||||
End Sub
|
||||
Public Sub New(Image As System.Drawing.Image)
|
||||
Pic = Image
|
||||
End Sub
|
||||
Public Sub New(Image As System.Drawing.Bitmap)
|
||||
Pic = Image
|
||||
End Sub
|
||||
Public Sub New(Image As ImageBrush)
|
||||
Using MS = New MemoryStream()
|
||||
Dim Encoder = New BmpBitmapEncoder()
|
||||
Encoder.Frames.Add(BitmapFrame.Create(Image.ImageSource))
|
||||
Encoder.Save(MS)
|
||||
Pic = New System.Drawing.Bitmap(MS)
|
||||
End Using
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 获取旋转的图片，这个方法不会导致原对象改变且会返回一个新的对象。图片长宽必须相等。
|
||||
''' </summary>
|
||||
''' <param name="angle">旋转角度（单位为角度）。</param>
|
||||
Public Function Rotation(angle As Double) As System.Drawing.Bitmap
|
||||
With Me
|
||||
Dim img As System.Drawing.Image = Me.Pic
|
||||
Dim bitSize As Single = img.Width
|
||||
Dim bmp As New System.Drawing.Bitmap(CInt(bitSize), CInt(bitSize))
|
||||
Using g As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(bmp)
|
||||
g.TranslateTransform(bitSize / 2, bitSize / 2)
|
||||
g.RotateTransform(angle)
|
||||
g.TranslateTransform(-bitSize / 2, -bitSize / 2)
|
||||
g.DrawImage(img, New System.Drawing.Rectangle(0, 0, img.Width, img.Width))
|
||||
End Using
|
||||
Return bmp
|
||||
End With
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 获取裁切的图片，这个方法不会导致原对象改变且会返回一个新的对象。
|
||||
''' </summary>
|
||||
Public Function Clip(rect As System.Drawing.Rectangle) As System.Drawing.Bitmap
|
||||
With Me
|
||||
Dim img As System.Drawing.Image = Pic
|
||||
Dim bmp As New System.Drawing.Bitmap(rect.Width, rect.Height)
|
||||
Using g As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(bmp)
|
||||
g.DrawImageUnscaled(img, rect)
|
||||
End Using
|
||||
Return bmp
|
||||
End With
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 获取左右翻转的图片，这个方法不会导致原对象改变。
|
||||
''' </summary>
|
||||
Public Function LeftRightFilp() As System.Drawing.Bitmap
|
||||
Dim bmp As New System.Drawing.Bitmap(Pic)
|
||||
bmp.RotateFlip(System.Drawing.RotateFlipType.RotateNoneFlipX)
|
||||
Return bmp
|
||||
End Function
|
||||
|
||||
''' <summary>
|
||||
''' 将图像保存到文件。
|
||||
''' </summary>
|
||||
Public Sub Save(FilePath As String)
|
||||
Dim encoder As BitmapEncoder = New PngBitmapEncoder()
|
||||
encoder.Frames.Add(BitmapFrame.Create(Me))
|
||||
Using fileStream = New System.IO.FileStream(FilePath, FileMode.Create)
|
||||
encoder.Save(fileStream)
|
||||
End Using
|
||||
End Sub
|
||||
|
||||
End Class
|
||||
@@ -0,0 +1,887 @@
|
||||
Public Class CrashAnalyzer
|
||||
Private Shared IsAnalyzeCacheCleared As Boolean = False
|
||||
Private Shared IsAnalyzeCacheClearedLock As New Object
|
||||
|
||||
'构造函数
|
||||
Private TempFolder As String
|
||||
Public Sub New(UUID As Integer)
|
||||
'清理缓存
|
||||
SyncLock IsAnalyzeCacheClearedLock
|
||||
If Not IsAnalyzeCacheCleared Then
|
||||
Try
|
||||
DeleteDirectory(PathTemp & "CrashAnalyzer")
|
||||
Catch ex As Exception
|
||||
Log(ex, "清理崩溃分析缓存失败")
|
||||
End Try
|
||||
IsAnalyzeCacheCleared = True
|
||||
End If
|
||||
End SyncLock
|
||||
'构建文件结构
|
||||
TempFolder = PathTemp & "CrashAnalyzer\" & UUID & RandomInteger(0, 99999999) & "\"
|
||||
DeleteDirectory(TempFolder)
|
||||
Directory.CreateDirectory(TempFolder & "Temp\")
|
||||
Directory.CreateDirectory(TempFolder & "Report\")
|
||||
Log("[Crash] 崩溃分析暂存文件夹：" & TempFolder)
|
||||
End Sub
|
||||
|
||||
'1：准备用于分析的 Log 文件
|
||||
Private AnalyzeRawFiles As New List(Of KeyValuePair(Of String, String())) '暂存的日志文件：文件完整路径 -> 文件内容
|
||||
''' <summary>
|
||||
''' 将可用于分析的日志存储到 AnalyzeRawFiles。
|
||||
''' </summary>
|
||||
''' <param name="LatestLog">从 PCL2 捕获到的最后 200 行程序输出。</param>
|
||||
Public Sub Collect(VersionPathIndie As String, Optional LatestLog As IList(Of String) = Nothing)
|
||||
Log("[Crash] 步骤 1：收集日志文件")
|
||||
|
||||
'简单收集可能的日志文件路径
|
||||
Dim PossibleLogs As New List(Of String)
|
||||
Try
|
||||
Dim DirInfo As New DirectoryInfo(VersionPathIndie & "crash-reports\")
|
||||
If DirInfo.Exists Then
|
||||
For Each File In DirInfo.EnumerateFiles
|
||||
PossibleLogs.Add(File.FullName)
|
||||
Next
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "收集 Minecraft 崩溃日志文件夹下的日志失败")
|
||||
End Try
|
||||
Try
|
||||
For Each File In New DirectoryInfo(VersionPathIndie).Parent.Parent.EnumerateFiles
|
||||
If If(File.Extension, "") <> ".log" Then Continue For
|
||||
PossibleLogs.Add(File.FullName)
|
||||
Next
|
||||
Catch ex As Exception
|
||||
Log(ex, "收集 Minecraft 主文件夹下的日志失败")
|
||||
End Try
|
||||
Try
|
||||
For Each File In New DirectoryInfo(VersionPathIndie).EnumerateFiles
|
||||
If If(File.Extension, "") <> ".log" Then Continue For
|
||||
PossibleLogs.Add(File.FullName)
|
||||
Next
|
||||
Catch ex As Exception
|
||||
Log(ex, "收集 Minecraft 隔离文件夹下的日志失败")
|
||||
End Try
|
||||
PossibleLogs.Add(VersionPathIndie & "logs\latest.log") 'Minecraft 日志
|
||||
PossibleLogs.Add(VersionPathIndie & "logs\debug.log") 'Minecraft Debug 日志
|
||||
PossibleLogs = ArrayNoDouble(PossibleLogs)
|
||||
|
||||
'确定最新的日志文件
|
||||
Dim RightLogs As New List(Of String)
|
||||
For Each LogFile In PossibleLogs
|
||||
Try
|
||||
Dim Info As New FileInfo(LogFile)
|
||||
If Not Info.Exists Then Continue For
|
||||
Dim Time = Math.Abs((Info.LastWriteTime - Date.Now).TotalMinutes)
|
||||
If Time < 3 AndAlso Info.Length > 0 Then
|
||||
RightLogs.Add(LogFile)
|
||||
Log("[Crash] 可能可用的日志文件：" & LogFile & "（" & Math.Round(Time, 1) & " 分钟）")
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "确认崩溃日志时间失败（" & LogFile & "）")
|
||||
End Try
|
||||
Next
|
||||
If RightLogs.Count = 0 Then Log("[Crash] 未发现可能可用的日志文件")
|
||||
|
||||
'将可能可用的日志文件导出
|
||||
For Each FilePath In RightLogs
|
||||
Try
|
||||
If FilePath.Contains("crash-") Then
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, ReadFile(FilePath).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Split(vbCr)))
|
||||
Else
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(FilePath, File.ReadAllLines(FilePath, Encoding.UTF8)))
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "读取可能的崩溃日志文件失败（" & FilePath & "）")
|
||||
End Try
|
||||
Next
|
||||
If LatestLog IsNot Nothing AndAlso LatestLog.Count > 0 Then
|
||||
Dim RawOutput As String = Join(LatestLog, vbCrLf)
|
||||
Log("[Crash] 以下为游戏输出的最后一段内容：" & vbCrLf & RawOutput)
|
||||
WriteFile(TempFolder & "RawOutput.log", RawOutput)
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TempFolder & "RawOutput.log", LatestLog.ToArray))
|
||||
LatestLog.Clear()
|
||||
End If
|
||||
|
||||
Log("[Crash] 步骤 1：收集日志文件完成，收集到 " & AnalyzeRawFiles.Count & " 个文件")
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 从文件路径直接导入日志文件或崩溃报告压缩包。
|
||||
''' </summary>
|
||||
Public Sub Import(FilePath As String)
|
||||
Log("[Crash] 步骤 1：自主导入日志文件")
|
||||
|
||||
'解压压缩包
|
||||
Try
|
||||
Dim Info As New FileInfo(FilePath)
|
||||
If Not Info.Exists OrElse Info.Length = 0 Then Exit Try
|
||||
If Not FilePath.ToLower.EndsWith(".jar") AndAlso ExtractFile(FilePath, TempFolder & "Temp\") Then
|
||||
'解压成功
|
||||
Log("[Crash] 已解压导入的日志文件：" & FilePath)
|
||||
Else
|
||||
'解压失败
|
||||
File.Copy(FilePath, TempFolder & "Temp\" & GetFileNameFromPath(FilePath))
|
||||
Log("[Crash] 已复制导入的日志文件：" & FilePath)
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "解压导入文件中的压缩包失败")
|
||||
End Try
|
||||
|
||||
'导入其中的日志文件
|
||||
For Each TargetFile As FileInfo In New DirectoryInfo(TempFolder & "Temp\").EnumerateFiles
|
||||
Try
|
||||
If Not TargetFile.Exists OrElse TargetFile.Length = 0 Then Continue For
|
||||
Dim Ext As String = TargetFile.Extension.ToLower
|
||||
If Ext = ".log" OrElse Ext = ".txt" Then
|
||||
If TargetFile.Name.StartsWith("crash-") Then
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, ReadFile(TargetFile.FullName).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Split(vbCr)))
|
||||
Else
|
||||
AnalyzeRawFiles.Add(New KeyValuePair(Of String, String())(TargetFile.FullName, File.ReadAllLines(TargetFile.FullName, Encoding.UTF8)))
|
||||
End If
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "导入单个日志文件失败")
|
||||
End Try
|
||||
Next
|
||||
|
||||
Log("[Crash] 步骤 1：自主导入日志文件，收集到 " & AnalyzeRawFiles.Count & " 个文件")
|
||||
End Sub
|
||||
|
||||
'2：确认实际用于分析的 Log 文本
|
||||
Private Enum AnalyzeFileType
|
||||
HsErr
|
||||
MinecraftLog
|
||||
ExtraLog
|
||||
CrashReport
|
||||
End Enum
|
||||
''' <summary>
|
||||
''' 从 AnalyzeRawFiles 中提取实际有用的文本片段存储到 AnalyzeFiles，并整理可用于生成报告的文件。
|
||||
''' 返回找到的用于分析的项目数。
|
||||
''' </summary>
|
||||
Public Function Prepare() As Integer
|
||||
Log("[Crash] 步骤 2：准备日志文本")
|
||||
|
||||
'对日志文件进行分类
|
||||
Dim TotalFiles As New List(Of KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String())))
|
||||
For Each LogFile In AnalyzeRawFiles
|
||||
Dim FileName As String = GetFileNameFromPath(LogFile.Key)
|
||||
Dim TargetType As AnalyzeFileType
|
||||
If FileName.StartsWith("hs_err") Then
|
||||
TargetType = AnalyzeFileType.HsErr
|
||||
ElseIf FileName.StartsWith("crash-") Then
|
||||
TargetType = AnalyzeFileType.CrashReport
|
||||
ElseIf FileName = "latest.log" OrElse FileName = "latest log.txt" OrElse
|
||||
FileName = "debug.log" OrElse FileName = "debug log.txt" OrElse FileName = "游戏崩溃前的输出.txt" OrElse
|
||||
FileName = "rawoutput.log" OrElse FileName = "启动器日志.txt" OrElse FileName = "PCL2 启动器日志.txt" OrElse FileName = "log1.txt" Then
|
||||
TargetType = AnalyzeFileType.MinecraftLog
|
||||
ElseIf FileName.EndsWith(".log") OrElse FileName.EndsWith(".txt") Then
|
||||
TargetType = AnalyzeFileType.ExtraLog
|
||||
Else
|
||||
Log("[Crash] " & FileName & " 分类为 Ignore")
|
||||
Continue For
|
||||
End If
|
||||
If LogFile.Value.Count = 0 Then
|
||||
Log("[Crash] " & FileName & " 由于内容为空跳过")
|
||||
Else
|
||||
TotalFiles.Add(New KeyValuePair(Of AnalyzeFileType, KeyValuePair(Of String, String()))(TargetType, LogFile))
|
||||
Log("[Crash] " & FileName & " 分类为 " & GetStringFromEnum(TargetType))
|
||||
End If
|
||||
Next
|
||||
|
||||
'将分类后的文件分别写入
|
||||
For Each SelectType In {AnalyzeFileType.MinecraftLog, AnalyzeFileType.HsErr, AnalyzeFileType.ExtraLog, AnalyzeFileType.CrashReport}
|
||||
'获取该种类的所有文件 {文件路径 -> 文件内容行}
|
||||
Dim SelectedFiles As New List(Of KeyValuePair(Of String, String()))
|
||||
For Each File In TotalFiles
|
||||
If SelectType = File.Key Then SelectedFiles.Add(File.Value)
|
||||
Next
|
||||
If SelectedFiles.Count = 0 Then Continue For
|
||||
Try
|
||||
'根据文件类别判断
|
||||
Select Case SelectType
|
||||
Case AnalyzeFileType.HsErr, AnalyzeFileType.CrashReport
|
||||
'获取文件的修改日期
|
||||
Dim DatedFiles As New SortedList(Of Date, KeyValuePair(Of String, String()))()
|
||||
For Each File In SelectedFiles
|
||||
Try
|
||||
DatedFiles.Add(New FileInfo(File.Key).LastWriteTime, File)
|
||||
Catch ex As Exception
|
||||
Log(ex, "获取日志文件修改时间失败")
|
||||
DatedFiles.Add(New Date(1900, 1, 1), File)
|
||||
End Try
|
||||
Next
|
||||
'输出最新的文件
|
||||
Dim NewestFile As KeyValuePair(Of String, String()) = DatedFiles.Last.Value
|
||||
OutputFiles.Add(NewestFile.Key)
|
||||
If SelectType = AnalyzeFileType.HsErr Then
|
||||
LogHs = GetHeadTailLines(NewestFile.Value, 200, 100)
|
||||
Log("[Crash] 输出报告：" & NewestFile.Key & "，作为虚拟机错误信息")
|
||||
Log("[Crash] 导入分析：" & NewestFile.Key & "，作为虚拟机错误信息")
|
||||
Else
|
||||
LogCrash = GetHeadTailLines(NewestFile.Value, 300, 700)
|
||||
Log("[Crash] 输出报告：" & NewestFile.Key & "，作为 Minecraft 崩溃报告")
|
||||
Log("[Crash] 导入分析：" & NewestFile.Key & "，作为 Minecraft 崩溃报告")
|
||||
End If
|
||||
Case AnalyzeFileType.MinecraftLog
|
||||
LogMc = ""
|
||||
'创建文件名词典
|
||||
Dim FileNameDict As New Dictionary(Of String, KeyValuePair(Of String, String()))
|
||||
For Each SelectedFile In SelectedFiles
|
||||
DictionaryAdd(FileNameDict, GetFileNameFromPath(SelectedFile.Key).ToLower, SelectedFile)
|
||||
OutputFiles.Add(SelectedFile.Key)
|
||||
Log("[Crash] 输出报告：" & SelectedFile.Key & "，作为 Minecraft 或启动器日志")
|
||||
Next
|
||||
'选择一份最佳的来自启动器的游戏日志
|
||||
For Each FileName As String In {"rawoutput.log", "启动器日志.txt", "log1.txt", "游戏崩溃前的输出.txt", "PCL2 启动器日志.txt"}
|
||||
If FileNameDict.ContainsKey(FileName) Then
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
'截取 “以下为游戏输出的最后一段内容” 后的内容
|
||||
Dim HasLauncherMark As Boolean = False
|
||||
For Each Line In CurrentLog.Value
|
||||
If HasLauncherMark Then
|
||||
LogMc += Line & vbLf
|
||||
ElseIf Line.Contains("以下为游戏输出的最后一段内容") Then
|
||||
HasLauncherMark = True
|
||||
Log("[Crash] 找到 PCL2 输出的游戏实时日志头")
|
||||
End If
|
||||
Next
|
||||
'导入后 500 行
|
||||
If Not HasLauncherMark Then LogMc += GetHeadTailLines(CurrentLog.Value, 0, 500)
|
||||
LogMc = LogMc.TrimEnd(vbCrLf.ToCharArray) & vbLf & "[" '路径包含中文且存在编码问题导致找不到或无法加载主类的末端检测
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为启动器日志")
|
||||
Exit For
|
||||
End If
|
||||
Next
|
||||
'选择一份最佳的 Minecraft Log
|
||||
For Each FileName As String In {"latest.log", "latest log.txt", "debug.log", "debug log.txt"}
|
||||
If FileNameDict.ContainsKey(FileName) Then
|
||||
Dim CurrentLog = FileNameDict(FileName)
|
||||
LogMc += GetHeadTailLines(CurrentLog.Value, 250, 500) & vbLf & "["
|
||||
Log("[Crash] 导入分析：" & CurrentLog.Key & "，作为 Minecraft 日志")
|
||||
Exit For
|
||||
End If
|
||||
Next
|
||||
'检查错误
|
||||
If LogMc = "" Then
|
||||
LogMc = Nothing
|
||||
Throw New Exception("无法找到匹配的 Minecraft Log")
|
||||
End If
|
||||
Case AnalyzeFileType.ExtraLog
|
||||
'全部丢过去
|
||||
For Each SelectedFile In SelectedFiles
|
||||
OutputFiles.Add(SelectedFile.Key)
|
||||
Log("[Crash] 输出报告：" & SelectedFile.Key & "，作为额外日志")
|
||||
Next
|
||||
End Select
|
||||
Catch ex As Exception
|
||||
Log(ex, "分类处理日志文件时出错")
|
||||
End Try
|
||||
Next
|
||||
|
||||
'获取种类数
|
||||
Dim ResultCount As Integer = If(LogMc Is Nothing, 0, 1) + If(LogHs Is Nothing, 0, 1) + If(LogCrash Is Nothing, 0, 1)
|
||||
If ResultCount = 0 Then
|
||||
Log("[Crash] 步骤 2：准备日志文本完成，没有任何可供分析的日志")
|
||||
Else
|
||||
Log(("[Crash] 步骤 2：准备日志文本完成，找到" & If(LogMc Is Nothing, "", "游戏日志、") & If(LogHs Is Nothing, "", "虚拟机日志、") & If(LogCrash Is Nothing, "", "崩溃日志、")).TrimEnd("、") & "用作分析")
|
||||
End If
|
||||
Return ResultCount
|
||||
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 输出字符串的前后某些行，并统一行尾为 vbLf (\r)、删除空行。
|
||||
''' </summary>
|
||||
Private Function GetHeadTailLines(Raw As String(), HeadLines As Integer, TailLines As Integer) As String
|
||||
If Raw.Length <= HeadLines + TailLines Then Return Join(Raw, vbLf)
|
||||
Dim Result As New StringBuilder
|
||||
For i = 0 To Raw.Count - 1
|
||||
If i < HeadLines OrElse Raw.Count - i < TailLines Then
|
||||
If Raw(i) = "" Then Continue For
|
||||
Result.Append(Raw(i) & vbLf)
|
||||
End If
|
||||
Next
|
||||
Return Result.ToString
|
||||
End Function
|
||||
|
||||
'3：根据文本分析崩溃原因
|
||||
Private LogMc As String = Nothing, LogHs As String = Nothing, LogCrash As String = Nothing
|
||||
Private LogAll As String
|
||||
'可能导致崩溃的原因与附加信息
|
||||
Private CrashReasons As New Dictionary(Of CrashReason, List(Of String))
|
||||
''' <summary>
|
||||
''' 导致崩溃的原因枚举。
|
||||
''' </summary>
|
||||
Private Enum CrashReason
|
||||
Mod文件被解压
|
||||
内存不足
|
||||
使用JDK
|
||||
显卡不支持OpenGL
|
||||
使用OpenJ9
|
||||
Java版本过高
|
||||
显卡驱动不支持导致无法设置像素格式
|
||||
路径包含中文且存在编码问题导致找不到或无法加载主类
|
||||
Intel驱动不兼容导致EXCEPTION_ACCESS_VIOLATION 'https://bugs.mojang.com/browse/MC-32606
|
||||
AMD驱动不兼容导致EXCEPTION_ACCESS_VIOLATION 'https://bugs.mojang.com/browse/MC-31618
|
||||
Nvidia驱动不兼容导致EXCEPTION_ACCESS_VIOLATION
|
||||
玩家手动触发调试崩溃
|
||||
光影或资源包导致OpenGL1282错误
|
||||
文件或内容校验失败
|
||||
确定Mod导致游戏崩溃
|
||||
Mod配置文件导致游戏崩溃
|
||||
ModMixin失败
|
||||
Mod加载器报错
|
||||
Mod初始化失败
|
||||
崩溃日志堆栈分析发现关键字
|
||||
崩溃日志堆栈分析发现Mod名称
|
||||
MC日志堆栈分析发现关键字
|
||||
OptiFine导致无法加载世界 'https://www.minecraftforum.net/forums/support/java-edition-support/3051132-exception-ticking-world
|
||||
特定方块导致崩溃
|
||||
特定实体导致崩溃
|
||||
材质过大或显卡配置不足
|
||||
没有可用的分析文件
|
||||
使用32位Java导致JVM无法分配足够多的内存
|
||||
Mod重复安装
|
||||
Fabric报错
|
||||
Fabric报错并给出解决方案
|
||||
Forge报错
|
||||
低版本Forge与高版本Java不兼容
|
||||
版本Json中存在多个Forge
|
||||
Mod过多导致超出ID限制
|
||||
End Enum
|
||||
''' <summary>
|
||||
''' 根据 AnalyzeLogs 与可能的版本信息分析崩溃原因。
|
||||
''' </summary>
|
||||
Public Sub Analyze(Optional Version As McVersion = Nothing)
|
||||
Log("[Crash] 步骤 3：分析崩溃原因")
|
||||
LogAll = (If(LogMc, "") & If(LogHs, "") & If(LogCrash, "")).ToLower
|
||||
|
||||
'1. 精准日志匹配 1
|
||||
AnalyzeCrit1()
|
||||
If CrashReasons.Count > 0 Then GoTo Done
|
||||
|
||||
'2. 堆栈分析
|
||||
If LogAll.Contains("forge") OrElse LogAll.Contains("fabric") OrElse LogAll.Contains("liteloader") Then
|
||||
'来源崩溃日志的分析
|
||||
If LogCrash IsNot Nothing Then
|
||||
Log("[Crash] 开始进行崩溃日志堆栈分析")
|
||||
Dim Keywords = AnalyzeStackKeyword(LogCrash.Replace("A detailed walkthrough of the error", "¨").Split("¨").First)
|
||||
If Keywords.Count > 0 Then
|
||||
Dim Names = AnalyzeModName(Keywords)
|
||||
If Names Is Nothing Then
|
||||
AppendReason(CrashReason.崩溃日志堆栈分析发现关键字, Keywords)
|
||||
Else
|
||||
AppendReason(CrashReason.崩溃日志堆栈分析发现Mod名称, Names)
|
||||
End If
|
||||
GoTo Done
|
||||
End If
|
||||
End If
|
||||
'来自 Minecraft 日志的分析
|
||||
If LogMc IsNot Nothing Then
|
||||
Dim Fatals = RegexSearch(LogMc, "/FATAL] [\w\W]+?(?=[\n]+\[)")
|
||||
Log("[Crash] 开始进行 Minecraft 日志堆栈分析，发现 " & Fatals.Count & " 个报错项")
|
||||
If Fatals.Count > 0 Then
|
||||
Dim Keywords As New List(Of String)
|
||||
For Each Fatal In Fatals
|
||||
Keywords.AddRange(AnalyzeStackKeyword(Fatal))
|
||||
Next
|
||||
If Keywords.Count > 0 Then
|
||||
AppendReason(CrashReason.MC日志堆栈分析发现关键字, ArrayNoDouble(Keywords))
|
||||
GoTo Done
|
||||
End If
|
||||
End If
|
||||
End If
|
||||
Else
|
||||
Log("[Crash] 可能并未安装 Mod，不进行堆栈分析")
|
||||
End If
|
||||
|
||||
'3. 精准日志匹配 2
|
||||
AnalyzeCrit2()
|
||||
|
||||
'输出到日志
|
||||
Done:
|
||||
If CrashReasons.Count = 0 Then
|
||||
Log("[Crash] 步骤 3：分析崩溃原因完成，未找到可能的原因")
|
||||
Else
|
||||
Log("[Crash] 步骤 3：分析崩溃原因完成，找到 " & CrashReasons.Count & " 条可能的原因")
|
||||
For Each Reason In CrashReasons
|
||||
Log("[Crash] - " & GetStringFromEnum(Reason.Key) & If(Reason.Value.Count > 0, "（" & Join(Reason.Value, "；") & "）", ""))
|
||||
Next
|
||||
End If
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 增加一个可能的崩溃原因。
|
||||
''' </summary>
|
||||
Private Sub AppendReason(Reason As CrashReason, Optional Additional As ICollection(Of String) = Nothing)
|
||||
If CrashReasons.ContainsKey(Reason) Then
|
||||
If Additional IsNot Nothing Then
|
||||
CrashReasons(Reason).AddRange(Additional)
|
||||
CrashReasons(Reason) = ArrayNoDouble(CrashReasons(Reason))
|
||||
End If
|
||||
Else
|
||||
CrashReasons.Add(Reason, New List(Of String)(If(Additional, {})))
|
||||
End If
|
||||
Log("[Crash] 可能的崩溃原因：" & GetStringFromEnum(Reason) & If(Additional IsNot Nothing AndAlso Additional.Count > 0, "（" & Join(Additional, "；") & "）", ""))
|
||||
End Sub
|
||||
Private Sub AppendReason(Reason As CrashReason, Additional As String)
|
||||
AppendReason(Reason, If(String.IsNullOrEmpty(Additional), Nothing, New List(Of String) From {Additional}))
|
||||
End Sub
|
||||
|
||||
'具体的分析代码
|
||||
''' <summary>
|
||||
''' 进行精准日志匹配。匹配优先级高于堆栈分析的崩溃。
|
||||
''' </summary>
|
||||
Private Sub AnalyzeCrit1()
|
||||
|
||||
'空白分析
|
||||
If LogMc Is Nothing AndAlso LogHs Is Nothing AndAlso LogCrash Is Nothing Then
|
||||
AppendReason(CrashReason.没有可用的分析文件)
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
'崩溃报告分析，高优先级
|
||||
If LogCrash IsNot Nothing Then
|
||||
If LogCrash.Contains("Unable to make protected final java.lang.Class java.lang.ClassLoader.defineClass") Then AppendReason(CrashReason.Java版本过高)
|
||||
End If
|
||||
|
||||
'游戏日志分析
|
||||
If LogMc IsNot Nothing Then
|
||||
If LogMc.Contains("Found multiple arguments for option fml.forgeVersion, but you asked for only one") Then AppendReason(CrashReason.版本Json中存在多个Forge)
|
||||
If LogMc.Contains("The driver does not appear to support OpenGL") Then AppendReason(CrashReason.显卡不支持OpenGL)
|
||||
If LogMc.Contains("java.lang.ClassCastException: java.base/jdk") Then AppendReason(CrashReason.使用JDK)
|
||||
If LogMc.Contains("java.lang.ClassCastException: class jdk.") Then AppendReason(CrashReason.使用JDK)
|
||||
If LogMc.Contains("Open J9 is not supported") OrElse LogMc.Contains("OpenJ9 is incompatible") OrElse LogMc.Contains(".J9VMInternals.") Then AppendReason(CrashReason.使用OpenJ9)
|
||||
If LogMc.Contains("because module java.base does not export") Then AppendReason(CrashReason.Java版本过高)
|
||||
If LogMc.Contains("java.lang.ClassNotFoundException: java.lang.invoke.LambdaMetafactory") Then AppendReason(CrashReason.Java版本过高)
|
||||
If LogMc.Contains("The directories below appear to be extracted jar files. Fix this before you continue.") Then AppendReason(CrashReason.Mod文件被解压)
|
||||
If LogMc.Contains("Extracted mod jars found, loading will NOT continue") Then AppendReason(CrashReason.Mod文件被解压)
|
||||
If LogMc.Contains("Couldn't set pixel format") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式)
|
||||
If LogMc.Contains("java.lang.OutOfMemoryError") Then AppendReason(CrashReason.内存不足)
|
||||
If LogMc.Contains("java.lang.NoSuchMethodError: sun.security.util.ManifestEntryVerifier") Then AppendReason(CrashReason.低版本Forge与高版本Java不兼容)
|
||||
If LogMc.Contains("1282: Invalid operation") Then AppendReason(CrashReason.光影或资源包导致OpenGL1282错误)
|
||||
If LogMc.Contains("signer information does not match signer information of other classes in the same package") Then AppendReason(CrashReason.文件或内容校验失败, If(RegexSeek(LogMc, "(?<=class "")[^']+(?=""'s signer information)"), "").TrimEnd(vbCrLf))
|
||||
If LogMc.Contains("An exception was thrown, the game will display an error screen and halt.") Then AppendReason(CrashReason.Forge报错, If(RegexSeek(LogMc, "(?<=the game will display an error screen and halt[\s\S]+?Exception: )[\s\S]+?(?=\n\tat)"), "").TrimEnd(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("Maybe try a lower resolution resourcepack?") Then AppendReason(CrashReason.材质过大或显卡配置不足)
|
||||
If LogMc.Contains("java.lang.NoSuchMethodError: net.minecraft.world.server.ChunkManager$ProxyTicketManager.shouldForceTicks(J)Z") AndAlso LogMc.Contains("OptiFine") Then AppendReason(CrashReason.OptiFine导致无法加载世界)
|
||||
If LogMc.Contains("Could not reserve enough space") Then
|
||||
If LogMc.Contains("for 1048576KB object heap") Then
|
||||
AppendReason(CrashReason.使用32位Java导致JVM无法分配足够多的内存)
|
||||
Else
|
||||
AppendReason(CrashReason.内存不足)
|
||||
End If
|
||||
End If
|
||||
'Mod 重复安装
|
||||
If LogMc.Contains("DuplicateModsFoundException") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(LogMc, "(?<=\n\t[\w]+ : [A-Z]{1}:[^\n]+(/|\\))[^/\\\n]+?.jar", RegularExpressions.RegexOptions.IgnoreCase))
|
||||
If LogMc.Contains("Found a duplicate mod") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "Found a duplicate mod[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
|
||||
If LogMc.Contains("ModResolutionException: Duplicate") Then AppendReason(CrashReason.Mod重复安装, RegexSearch(If(RegexSeek(LogMc, "ModResolutionException: Duplicate[^\n]+"), ""), "[^\\/]+.jar", RegularExpressions.RegexOptions.IgnoreCase))
|
||||
'找不到或无法加载主类
|
||||
If (RegexCheck(LogMc, "^[^\n.]+.\w+.[^\n]+\n\[$") OrElse RegexCheck(LogMc, "^\[[^\]]+\] [^\n.]+.\w+.[^\n]+\n\[")) AndAlso
|
||||
Not (LogMc.Contains("at net.") OrElse LogMc.Contains("/INFO]")) AndAlso
|
||||
LogHs Is Nothing AndAlso LogCrash Is Nothing Then
|
||||
AppendReason(CrashReason.路径包含中文且存在编码问题导致找不到或无法加载主类)
|
||||
End If
|
||||
'Mod 导致的崩溃
|
||||
If LogMc.Contains("Mixin prepare failed ") OrElse LogMc.Contains("mixin.injection.throwables.InjectionError") OrElse LogMc.Contains(".mixins.json] FAILED during )") Then
|
||||
Dim ModId As String = RegexSeek(LogMc, "(?<=in )[^./ ]+(?=.mixins.json.+failed injection check)")
|
||||
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= failed .+ in )[^./ ]+(?=.mixins.json)")
|
||||
If ModId Is Nothing Then ModId = RegexSeek(LogMc, "(?<= in config \[)[^./ ]+(?=.mixins.json\] FAILED during )")
|
||||
AppendReason(CrashReason.ModMixin失败, TryAnalyzeModName(If(ModId, "").TrimEnd((vbCrLf & " ").ToCharArray)))
|
||||
End If
|
||||
If LogMc.Contains("Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogMc, "[^\n]+?(?)"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
|
||||
If LogMc.Contains("Failed to create mod instance.") Then AppendReason(CrashReason.Mod初始化失败, TryAnalyzeModName(If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModID: )[^,]+"), If(RegexSeek(LogMc, "(?<=Failed to create mod instance. ModId )[^\n]+(?= for )"), "")).TrimEnd(vbCrLf)))
|
||||
End If
|
||||
|
||||
'虚拟机日志分析
|
||||
If LogHs IsNot Nothing Then
|
||||
If LogHs.Contains("The system is out of physical RAM or swap space") Then AppendReason(CrashReason.内存不足)
|
||||
If LogHs.Contains("Out of Memory Error") Then AppendReason(CrashReason.内存不足)
|
||||
If LogHs.Contains("EXCEPTION_ACCESS_VIOLATION") Then
|
||||
If LogHs.Contains("# C [ig") Then AppendReason(CrashReason.Intel驱动不兼容导致EXCEPTION_ACCESS_VIOLATION)
|
||||
If LogHs.Contains("# C [atio") Then AppendReason(CrashReason.AMD驱动不兼容导致EXCEPTION_ACCESS_VIOLATION)
|
||||
If LogHs.Contains("# C [nvoglv") Then AppendReason(CrashReason.Nvidia驱动不兼容导致EXCEPTION_ACCESS_VIOLATION)
|
||||
End If
|
||||
End If
|
||||
|
||||
'崩溃报告分析
|
||||
If LogCrash IsNot Nothing Then
|
||||
If LogCrash.Contains("maximum id range exceeded") Then AppendReason(CrashReason.Mod过多导致超出ID限制)
|
||||
If LogCrash.Contains("Entity being rendered") AndAlso LogCrash.Contains(vbTab & "Entity's Exact location: ") Then AppendReason(CrashReason.特定实体导致崩溃, If(RegexSeek(LogCrash, "(?<=\tEntity Type: )[^\n]+(?= \()"), "") & " (" & If(RegexSeek(LogCrash, "(?<=\tEntity's Exact location: )[^\n]+"), "").TrimEnd(vbCrLf.ToCharArray) & ")")
|
||||
If LogCrash.Contains("java.lang.OutOfMemoryError") Then AppendReason(CrashReason.内存不足)
|
||||
If LogCrash.Contains("Pixel format not accelerated") Then AppendReason(CrashReason.显卡驱动不支持导致无法设置像素格式)
|
||||
If LogCrash.Contains("Manually triggered debug crash") Then AppendReason(CrashReason.玩家手动触发调试崩溃)
|
||||
'Mod 导致的崩溃
|
||||
If LogCrash.Contains("-- MOD ") Then
|
||||
Dim LogLeft = LogCrash.Split("-- MOD").Last
|
||||
If LogLeft.Contains("Failure message: MISSING") Then
|
||||
AppendReason(CrashReason.确定Mod导致游戏崩溃, If(RegexSeek(LogCrash, "(?<=Mod File: ).+"), "").TrimEnd((vbCrLf & " ").ToCharArray))
|
||||
Else
|
||||
AppendReason(CrashReason.Mod加载器报错, If(RegexSeek(LogCrash, "(?<=Failure message: )[\w\W]+?(?=\tMod)"), "").Replace(vbTab, " ").TrimEnd((vbCrLf & " ").ToCharArray))
|
||||
End If
|
||||
End If
|
||||
If LogCrash.Contains("Multiple entries with same key: ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Multiple entries with same key: )[^=]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
|
||||
If LogCrash.Contains("LoaderExceptionModCrash: Caught exception from ") Then AppendReason(CrashReason.确定Mod导致游戏崩溃, TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=LoaderExceptionModCrash: Caught exception from )[^\n]+"), "").TrimEnd((vbCrLf & " ").ToCharArray)))
|
||||
If LogCrash.Contains("Failed loading config file ") Then AppendReason(CrashReason.Mod配置文件导致游戏崩溃, {TryAnalyzeModName(If(RegexSeek(LogCrash, "(?<=Failed loading config file .+ for modid )[^\n]+"), "").TrimEnd(vbCrLf)).First, If(RegexSeek(LogCrash, "(?<=Failed loading config file ).+(?= of type)"), "").TrimEnd(vbCrLf)})
|
||||
End If
|
||||
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 进行精准日志匹配。匹配优先级低于堆栈分析的崩溃。
|
||||
''' </summary>
|
||||
Private Sub AnalyzeCrit2()
|
||||
|
||||
'游戏日志分析
|
||||
If LogMc IsNot Nothing Then
|
||||
If LogMc.Contains("]: Warnings were found!") Then AppendReason(CrashReason.Fabric报错, If(RegexSeek(LogMc, "(?<=\]: Warnings were found! ?[\n]+)[\w\W]+?(?=[\n]+\[)"), "").Trim(vbCrLf.ToCharArray))
|
||||
End If
|
||||
|
||||
'崩溃报告分析
|
||||
If LogCrash IsNot Nothing Then
|
||||
If LogCrash.Contains(vbTab & "Block location: World: ") Then AppendReason(CrashReason.特定方块导致崩溃, If(RegexSeek(LogCrash, "(?<=\tBlock: Block\{)[^\}]+"), "") & " " & If(RegexSeek(LogCrash, "(?<=\tBlock location: World: )\([^\)]+\)"), ""))
|
||||
If LogCrash.Contains(vbTab & "Entity's Exact location: ") Then AppendReason(CrashReason.特定实体导致崩溃, If(RegexSeek(LogCrash, "(?<=\tEntity Type: )[^\n]+(?= \()"), "") & " (" & If(RegexSeek(LogCrash, "(?<=\tEntity's Exact location: )[^\n]+"), "").TrimEnd(vbCrLf.ToCharArray) & ")")
|
||||
End If
|
||||
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 从堆栈中提取 Mod ID 关键字。若失败则返回空列表。
|
||||
''' </summary>
|
||||
Private Function AnalyzeStackKeyword(ErrorStack As String) As List(Of String)
|
||||
|
||||
'进行正则匹配
|
||||
Dim StackSearchResults As List(Of String) = RegexSearch(If(ErrorStack, "") & vbCrLf, "(?<=\n[^{]+)[a-zA-Z]+\w+\.[a-zA-Z]+[\w\.]+(?=\.[\w\.$]+\.)")
|
||||
|
||||
'检查堆栈开头
|
||||
Dim PossibleStacks As New List(Of String)
|
||||
For Each Stack As String In StackSearchResults
|
||||
'If Not Stack.Contains(".") Then Continue For
|
||||
For Each IgnoreStack In {
|
||||
"java", "sun", "javax", "jdk",
|
||||
"org.lwjgl", "com.sun", "net.minecraftforge", "com.mojang", "net.minecraft", "cpw.mods", "com.google", "org.apache", "org.spongepowered", "net.fabricmc", "com.mumfrey",
|
||||
"com.electronwill.nightconfig",
|
||||
"MojangTricksIntelDriversForPerformance_javaw"}
|
||||
If Stack.StartsWith(IgnoreStack) Then GoTo NextStack
|
||||
Next
|
||||
PossibleStacks.Add(Stack.Trim) '.Split("$").First)
|
||||
NextStack:
|
||||
Next
|
||||
PossibleStacks = ArrayNoDouble(PossibleStacks)
|
||||
Log("[Crash] 找到 " & PossibleStacks.Count & " 条可能的堆栈信息")
|
||||
If PossibleStacks.Count = 0 Then Return New List(Of String)
|
||||
For Each Stack As String In PossibleStacks
|
||||
Log("[Crash] - " & Stack)
|
||||
Next
|
||||
|
||||
'检查堆栈关键词
|
||||
Dim PossibleWords As New List(Of String)
|
||||
For Each Stack As String In PossibleStacks
|
||||
Dim Splited = Stack.Split(".")
|
||||
For i = 0 To Math.Min(3, Splited.Count - 1) '最多取前 4 节
|
||||
Dim Word As String = Splited(i)
|
||||
If Word.Length <= 2 OrElse Word.StartsWith("func_") Then Continue For
|
||||
If {"com", "org", "net", "asm", "fml", "mod", "jar", "sun", "lib", "map", "gui", "dev", "nio", "api",
|
||||
"core", "init", "mods", "main", "file", "game", "load", "read", "done", "util", "tile", "item", "base",
|
||||
"forge", "setup", "block", "model", "mixin", "event",
|
||||
"common", "server", "config", "loader", "launch", "entity", "assist", "client", "modapi", "mojang", "shader", "events", "github",
|
||||
"preinit", "preload", "machine", "reflect", "channel", "general", "handler",
|
||||
"optifine", "minecraft", "transformers", "universal", "internal", "multipart", "minecraftforge", "override"
|
||||
}.Contains(Word.ToLower) Then Continue For
|
||||
PossibleWords.Add(Word.Trim)
|
||||
Next
|
||||
Next
|
||||
PossibleWords = ArrayNoDouble(PossibleWords)
|
||||
Log("[Crash] 从堆栈信息中找到 " & PossibleWords.Count & " 个可能的 Mod ID 关键词")
|
||||
If PossibleWords.Count > 0 Then Log("[Crash] - " & Join(PossibleWords, ", "))
|
||||
If PossibleWords.Count > 10 Then
|
||||
Log("[Crash] 关键词过多，考虑匹配出错，不纳入考虑")
|
||||
Return New List(Of String)
|
||||
Else
|
||||
Return PossibleWords
|
||||
End If
|
||||
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 根据 Mod 关键词与详细信息（崩溃报告第二部分）与，获取实际的 Mod 名称。
|
||||
''' 若失败则返回 Nothing。
|
||||
''' </summary>
|
||||
Private Function AnalyzeModName(Keywords As List(Of String)) As List(Of String)
|
||||
Dim ModFileNames As New List(Of String)
|
||||
|
||||
'预处理关键词（分割括号）
|
||||
Dim RealKeywords As New List(Of String)
|
||||
For Each Keyword In Keywords
|
||||
For Each SubKeyword In Keyword.Split("(")
|
||||
RealKeywords.Add(SubKeyword.Trim(" )".ToCharArray))
|
||||
Next
|
||||
Next
|
||||
Keywords = RealKeywords
|
||||
|
||||
'获取崩溃报告对应部分
|
||||
If LogCrash Is Nothing Then Return Nothing
|
||||
If Not LogCrash.Contains("A detailed walkthrough of the error") Then Return Nothing
|
||||
Dim Details As String = LogCrash.Replace("A detailed walkthrough of the error", "¨")
|
||||
Dim IsFabricDetail As Boolean = Details.Contains("Fabric Mods") '是否为 Fabric 信息格式
|
||||
If IsFabricDetail Then
|
||||
Details = Details.Replace("Fabric Mods", "¨")
|
||||
Log("[Crash] 检测到 Fabric Mod 信息格式")
|
||||
End If
|
||||
Details = Details.Split("¨").Last
|
||||
|
||||
'[Forge] 获取所有包含 .jar 的行
|
||||
'[Fabric] 获取所有包含 Mod 信息的行
|
||||
Dim ModNameLines As New List(Of String)
|
||||
For Each Line In Details.Split(vbLf)
|
||||
If Line.ToLower.Contains(".jar") OrElse
|
||||
(IsFabricDetail AndAlso Line.StartsWith(vbTab & vbTab) AndAlso Not RegexCheck(Line, "\t\tfabric[\w-]*: Fabric")) Then ModNameLines.Add(Line)
|
||||
Next
|
||||
Log("[Crash] 找到 " & ModNameLines.Count & " 个可能的 Mod 项目行")
|
||||
|
||||
'获取 Mod ID 与关键词的匹配行
|
||||
Dim HintLines As New List(Of String)
|
||||
For Each KeyWord As String In Keywords
|
||||
For Each ModString As String In ModNameLines
|
||||
Dim RealModString As String = ModString.ToLower.Replace("_", "")
|
||||
If Not RealModString.Contains(KeyWord.ToLower.Replace("_", "")) Then Continue For
|
||||
If RealModString.Contains("minecraft.jar") OrElse RealModString.Contains(" forge-") Then Continue For
|
||||
HintLines.Add(ModString.Trim(vbCrLf.ToCharArray))
|
||||
Exit For
|
||||
Next
|
||||
Next
|
||||
HintLines = ArrayNoDouble(HintLines)
|
||||
Log("[Crash] 找到 " & HintLines.Count & " 个可能的崩溃 Mod 匹配行")
|
||||
For Each ModName As String In HintLines
|
||||
Log("[Crash] - " & ModName)
|
||||
Next
|
||||
|
||||
'从 Mod 匹配行中提取 .jar 文件的名称
|
||||
For Each Line As String In HintLines
|
||||
Dim Name As String
|
||||
If IsFabricDetail Then
|
||||
Name = RegexSeek(Line, "(?<=: )[^\n]+(?= [^\n]+)")
|
||||
Else
|
||||
Name = RegexSeek(Line, "(?<=\()[^\t]+.jar(?=\))|(?<=(\t\t)|(\| ))[^\t\|]+.jar", RegularExpressions.RegexOptions.IgnoreCase)
|
||||
End If
|
||||
If Name IsNot Nothing Then ModFileNames.Add(Name)
|
||||
Next
|
||||
ModFileNames = ArrayNoDouble(ModFileNames)
|
||||
Log("[Crash] 找到 " & ModFileNames.Count & " 个可能的崩溃 Mod 文件名")
|
||||
For Each ModFileName As String In ModFileNames
|
||||
Log("[Crash] - " & ModFileName)
|
||||
Next
|
||||
|
||||
Return If(ModFileNames.Count = 0, Nothing, ModFileNames)
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 尝试获取 Mod 名称，若失败则返回原关键字。
|
||||
''' </summary>
|
||||
Private Function TryAnalyzeModName(Keywords As String) As List(Of String)
|
||||
Dim RawList As New List(Of String) From {Keywords}
|
||||
If String.IsNullOrEmpty(Keywords) Then Return RawList
|
||||
Return If(AnalyzeModName(RawList), RawList)
|
||||
End Function
|
||||
|
||||
'4：根据原因输出信息
|
||||
Private OutputFiles As New List(Of String)
|
||||
''' <summary>
|
||||
''' 弹出崩溃弹窗，并指导导出崩溃报告。
|
||||
''' </summary>
|
||||
Public Sub Output(IsHandAnalyze As Boolean, Optional ExtraFiles As List(Of String) = Nothing)
|
||||
'弹窗提示
|
||||
FrmMain.ShowWindowToTop()
|
||||
Select Case MyMsgBox(GetAnalyzeResult(IsHandAnalyze), If(IsHandAnalyze, "错误报告分析结果", "Minecraft 出现错误"), "确定", If(IsHandAnalyze, "", "导出错误报告"))
|
||||
Case 2
|
||||
Dim FileAddress As String = Nothing
|
||||
Try
|
||||
'获取文件路径
|
||||
RunInUiWait(Sub() FileAddress = SelectAs("选择保存位置", "错误报告-" & Date.Now.ToString("G").Replace("/", "-").Replace(":", ".").Replace(" ", "_") & ".zip", "Minecraft 错误报告(*.zip)|*.zip"))
|
||||
If String.IsNullOrEmpty(FileAddress) Then Exit Sub
|
||||
Directory.CreateDirectory(GetPathFromFullPath(FileAddress))
|
||||
If File.Exists(FileAddress) Then File.Delete(FileAddress)
|
||||
'输出诊断信息
|
||||
FeedbackInfo()
|
||||
LogFlush()
|
||||
'复制文件
|
||||
If ExtraFiles IsNot Nothing Then OutputFiles.AddRange(ExtraFiles)
|
||||
For Each OutputFile In OutputFiles
|
||||
Try
|
||||
Dim FileName As String = GetFileNameFromPath(OutputFile)
|
||||
Select Case FileName
|
||||
Case "LatestLaunch.bat"
|
||||
FileName = "启动脚本.bat"
|
||||
Case "Log1.txt"
|
||||
FileName = "PCL2 启动器日志.txt"
|
||||
Case "RawOutput.log"
|
||||
FileName = "游戏崩溃前的输出.txt"
|
||||
End Select
|
||||
File.Copy(OutputFile, TempFolder & "Report\" & FileName, True)
|
||||
Catch ex As Exception
|
||||
Log(ex, "复制错误报告文件失败（" & OutputFile & "）")
|
||||
End Try
|
||||
Next
|
||||
'导出报告
|
||||
Compression.ZipFile.CreateFromDirectory(TempFolder & "Report\", FileAddress)
|
||||
DeleteDirectory(TempFolder & "Report\")
|
||||
Hint("错误报告已导出！", HintType.Finish)
|
||||
Catch ex As Exception
|
||||
Log(ex, "导出错误报告失败", LogLevel.Feedback)
|
||||
Exit Sub
|
||||
End Try
|
||||
Try
|
||||
Process.Start("explorer", "/select," & FileAddress)
|
||||
Catch ex As Exception
|
||||
Log(ex, "打开错误报告的存放文件夹失败")
|
||||
End Try
|
||||
End Select
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 获取崩溃分析的结果描述。
|
||||
''' </summary>
|
||||
Private Function GetAnalyzeResult(IsHandAnalyze As Boolean) As String
|
||||
|
||||
'非一个结果的处理
|
||||
Dim ResultString As String
|
||||
If CrashReasons.Count = 0 Then
|
||||
If IsHandAnalyze Then
|
||||
Return "很抱歉，PCL2 无法确定错误原因。"
|
||||
Else
|
||||
Return "很抱歉，你的游戏出现了一些问题……" & vbCrLf &
|
||||
"如果要寻求帮助，请向他人发送错误报告文件，而不是发送这个窗口的截图。" & vbCrLf &
|
||||
"你也可以查看错误报告，其中可能会有出错的原因。"
|
||||
End If
|
||||
ElseIf CrashReasons.Count >= 2 Then
|
||||
Hint("错误分析时发现数个可能的原因，窗口中仅显示了第一条，你可以在启动器日志中检查更多可能的原因！", HintType.Finish)
|
||||
End If
|
||||
|
||||
'根据不同原因判断
|
||||
Dim Additional As List(Of String) = CrashReasons.First.Value
|
||||
Select Case CrashReasons.First.Key
|
||||
Case CrashReason.Mod文件被解压
|
||||
ResultString = "由于 Mod 文件被解压了，导致游戏无法继续运行。\n直接把整个 Mod 文件放进 Mod 文件夹中即可，若解压就会导致游戏出错。\n\n请删除 Mod 文件夹中已被解压的 Mod，然后再启动游戏。"
|
||||
Case CrashReason.内存不足
|
||||
ResultString = "Minecraft 内存不足，导致其无法继续运行。\n这很可能是由于你为游戏分配的内存不足，或是游戏的配置要求过高。\n\n你可以在启动设置中增加为游戏分配的内存，删除配置要求较高的材质、Mod、光影。\n如果这依然不奏效，请在开始游戏前尽量关闭其他软件，或者……换台电脑？\h"
|
||||
Case CrashReason.使用OpenJ9
|
||||
ResultString = "游戏因为使用 Open J9 而崩溃了。\n请在启动设置的 Java 选择一项中改用非 OpenJ9 的 Java 8，然后再启动游戏。\n如果你没有安装 JRE 8，你可以从网络中下载、安装一个。"
|
||||
Case CrashReason.使用JDK
|
||||
ResultString = "游戏似乎因为使用 JDK，或 Java 版本过高而崩溃了。\n请在启动设置的 Java 选择一项中改用 JRE 8（Java 8），然后再启动游戏。\n如果你没有安装 JRE 8，你可以从网络中下载、安装一个。"
|
||||
Case CrashReason.Java版本过高
|
||||
ResultString = "游戏似乎因为你所使用的 Java 版本过高而崩溃了。\n请在启动设置的 Java 选择一项中改用 JRE 8（Java 8），然后再启动游戏。\n如果你没有安装 JRE 8，你可以从网络中下载、安装一个。"
|
||||
Case CrashReason.使用32位Java导致JVM无法分配足够多的内存
|
||||
If Environment.Is64BitOperatingSystem Then
|
||||
ResultString = "你似乎正在使用 32 位 Java，这会导致 Minecraft 无法使用 1GB 以上的内存，进而造成崩溃。\n\n请在启动设置的 Java 选择一项中改用 64 位的 Java 再启动游戏，然后再启动游戏。\n如果你没有安装 64 位的 Java，你可以从网络中下载、安装一个。"
|
||||
Else
|
||||
ResultString = "你正在使用 32 位的操作系统，这会导致 Minecraft 无法使用 1GB 以上的内存，进而造成崩溃。\n\n你或许只能重装 64 位的操作系统来解决此问题。\n如果你的电脑内存在 2GB 以内，那或许只能换台电脑了……\h"
|
||||
End If
|
||||
Case CrashReason.崩溃日志堆栈分析发现关键字, CrashReason.MC日志堆栈分析发现关键字
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "你的游戏遇到了一些问题，这可能是某些 Mod 所引起的，PCL2 找到了一个可疑的关键词：" & Additional.First & "。\n\n如果你知道它对应的 Mod，那么有可能就是它引起的错误，你也可以查看错误报告获取详情。\h"
|
||||
Else
|
||||
ResultString = "你的游戏遇到了一些问题，这可能是某些 Mod 所引起的，PCL2 找到了以下可疑的关键词：\n - " & Join(Additional, ", ") & "\n\n如果你知道这些关键词对应的 Mod，那么有可能就是它引起的错误，你也可以查看错误报告获取详情。\h"
|
||||
End If
|
||||
Case CrashReason.崩溃日志堆栈分析发现Mod名称
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "名为 " & Additional.First & " 的 Mod 可能导致了游戏出错。\n\e\h"
|
||||
Else
|
||||
ResultString = "可能是以下 Mod 导致了游戏出错：\n - " & Join(Additional, "\n - ") & "\n\e\h"
|
||||
End If
|
||||
Case CrashReason.确定Mod导致游戏崩溃
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "名称或 ID 为 " & Additional.First & " 的 Mod 导致了游戏出错。\n\e\h"
|
||||
Else
|
||||
ResultString = "以下 Mod 导致了游戏出错：\n - " & Join(Additional, "\n - ") & "\n\e\h"
|
||||
End If
|
||||
Case CrashReason.ModMixin失败
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "名称或 ID 为 " & Additional.First & " 的 Mod 注入失败，导致游戏出错。\n这一般代表着该 Mod 存在 Bug，或与当前环境不兼容。\n\e\h"
|
||||
Else
|
||||
ResultString = "以下 Mod 导致了游戏出错：\n - " & Join(Additional, "\n - ") & "\n这一般代表着这些 Mod 存在 Bug，或与当前环境不兼容。\n\e\h"
|
||||
End If
|
||||
Case CrashReason.Mod配置文件导致游戏崩溃
|
||||
If Additional(1) Is Nothing Then
|
||||
ResultString = "名称或 ID 为 " & Additional.First & " 的 Mod 导致了游戏出错。\n\e\h"
|
||||
Else
|
||||
ResultString = "名称或 ID 为 " & Additional.First & " 的 Mod 导致了游戏出错：\n其配置文件 " & Additional(1) & " 存在异常，无法读取。"
|
||||
End If
|
||||
Case CrashReason.Mod初始化失败
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "名为 " & Additional.First & " 的 Mod 初始化失败，导致游戏无法继续加载。\n\e\h"
|
||||
Else
|
||||
ResultString = "以下 Mod 初始化失败，导致游戏无法继续加载：\n - " & Join(Additional, "\n - ") & "\n\e\h"
|
||||
End If
|
||||
Case CrashReason.特定方块导致崩溃
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "游戏似乎因为方块 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并观察游戏的运行情况：\n - 若正常运行，则是该方块导致出错，你或许需要使用一些方式删除此方块。\n - 若仍然出错，问题就可能来自其他原因……\h"
|
||||
Else
|
||||
ResultString = "游戏似乎因为世界中的某些方块出现了问题。\n\n你可以创建一个新世界，并观察游戏的运行情况：\n - 若正常运行，则是某些方块导致出错，你或许需要删除该世界。\n - 若仍然出错，问题就可能来自其他原因……\h"
|
||||
End If
|
||||
Case CrashReason.Mod重复安装
|
||||
If Additional.Count >= 2 Then
|
||||
ResultString = "你重复安装了多个相同的 Mod：\n - " & Join(Additional, "\n - ") & "\n\n每个 Mod 只能出现一次，请删除重复的 Mod，然后再启动游戏。"
|
||||
Else
|
||||
ResultString = "你可能重复安装了多个相同的 Mod，导致游戏无法继续加载。\n\n每个 Mod 只能出现一次，请删除重复的 Mod，然后再启动游戏。\e\h"
|
||||
End If
|
||||
Case CrashReason.特定实体导致崩溃
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "游戏似乎因为实体 " & Additional.First & " 出现了问题。\n\n你可以创建一个新世界，并生成一个该实体，然后观察游戏的运行情况：\n - 若正常运行，则是该实体导致出错，你或许需要使用一些方式删除此实体。\n - 若仍然出错，问题就可能来自其他原因……\h"
|
||||
Else
|
||||
ResultString = "游戏似乎因为世界中的某些实体出现了问题。\n\n你可以创建一个新世界，并生成各种实体，观察游戏的运行情况：\n - 若正常运行，则是某些实体导致出错，你或许需要删除该世界。\n - 若仍然出错，问题就可能来自其他原因……\h"
|
||||
End If
|
||||
Case CrashReason.低版本Forge与高版本Java不兼容
|
||||
ResultString = "由于低版本 Forge 与当前 Java 不兼容，导致了游戏崩溃。\n\n请尝试以下解决方案：\n - 更新 Forge 到 36.2.26 或更高版本\n - 换用版本低于 8.0.320 的 Java"
|
||||
Case CrashReason.版本Json中存在多个Forge
|
||||
ResultString = "可能由于使用其他启动器修改了 Forge 版本，当前版本的文件存在异常，导致了游戏崩溃。\n请尝试重新全新安装 Forge，而非使用其他启动器修改 Forge 版本。"
|
||||
Case CrashReason.玩家手动触发调试崩溃
|
||||
ResultString = "* 事实上，你的游戏没有任何问题，这是你自己触发的崩溃。\n* 你难道没有更重要的事要做吗？"
|
||||
Case CrashReason.路径包含中文且存在编码问题导致找不到或无法加载主类
|
||||
ResultString = "由于游戏路径含有中文字符，且 Java 或系统编码存在错误，导致游戏无法运行。\n\n解决这一问题的最简单方法是检查游戏的完整路径，并删除各个文件夹名中的中文字符。\n这包括了游戏的版本名、它所处的 .minecraft 文件夹及其之前的文件夹名。\h"
|
||||
Case CrashReason.OptiFine导致无法加载世界 'https://www.minecraftforum.net/forums/support/java-edition-support/3051132-exception-ticking-world
|
||||
ResultString = "你所使用的 OptiFine 可能导致了你的游戏出现问题。\n\n该问题只在特定 OptiFine 版本中出现，你可以尝试更换 OptiFine 的版本。\h"
|
||||
Case CrashReason.显卡驱动不支持导致无法设置像素格式, CrashReason.Intel驱动不兼容导致EXCEPTION_ACCESS_VIOLATION, CrashReason.AMD驱动不兼容导致EXCEPTION_ACCESS_VIOLATION, CrashReason.Nvidia驱动不兼容导致EXCEPTION_ACCESS_VIOLATION, CrashReason.显卡不支持OpenGL
|
||||
If LogAll.Contains("hd graphics ") Then
|
||||
ResultString = "你的显卡驱动存在问题，或未使用独立显卡，导致游戏无法正常运行。\n\n如果你的电脑存在独立显卡，请使用独立显卡而非 Intel 核显启动 PCL2 与 Minecraft。\n如果问题依然存在，请尝试升级你的显卡驱动到最新版本，或回退到出厂版本。\n如果还是不行，还可以尝试使用 8.0.51 或更低版本的 Java。\h"
|
||||
Else
|
||||
ResultString = "你的显卡驱动存在问题，导致游戏无法正常运行。\n\n请尝试升级你的显卡驱动到最新版本，或回退到出厂版本，然后再启动游戏。\n如果还是不行，可以尝试使用 8.0.51 或更低版本的 Java。\n如果问题依然存在，那么你可能需要换个更好的显卡……\h"
|
||||
End If
|
||||
Case CrashReason.材质过大或显卡配置不足
|
||||
ResultString = "你所使用的材质分辨率过高，或显卡配置不足，导致游戏无法继续运行。\n\n如果你正在使用高清材质，请将它移除。\n如果你没有使用材质，那么你可能需要更新显卡驱动，或者换个更好的显卡……\h"
|
||||
Case CrashReason.光影或资源包导致OpenGL1282错误
|
||||
ResultString = "你所使用的光影或材质导致游戏出现了一些问题……\n\n请尝试删除你所添加的这些额外资源。\h"
|
||||
Case CrashReason.Mod过多导致超出ID限制
|
||||
ResultString = "你所安装的 Mod 过多，超出了游戏的 ID 限制，导致了游戏崩溃。\n请尝试安装 JEID 等修复 Mod，或删除部分大型 Mod。"
|
||||
Case CrashReason.文件或内容校验失败
|
||||
ResultString = "部分文件或内容校验失败，导致游戏出现了问题。\n\n请尝试删除游戏（包括 Mod）并重新下载，或尝试在重新下载时使用 VPN。\h"
|
||||
Case CrashReason.Fabric报错
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "Fabric 提供了以下错误信息：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。"
|
||||
Else
|
||||
ResultString = "Fabric 可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息，可以查看错误报告了解错误具体是如何发生的。\h"
|
||||
End If
|
||||
Case CrashReason.Mod加载器报错
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "Mod 加载器提供了以下错误信息：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。"
|
||||
Else
|
||||
ResultString = "Mod 加载器可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息，可以查看错误报告了解错误具体是如何发生的。\h"
|
||||
End If
|
||||
Case CrashReason.Fabric报错并给出解决方案
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "Fabric 提供了以下解决方案：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。"
|
||||
Else
|
||||
ResultString = "Fabric 可能已经提供了解决方案，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息，可以查看错误报告了解错误具体是如何发生的。\h"
|
||||
End If
|
||||
Case CrashReason.Forge报错
|
||||
If Additional.Count = 1 Then
|
||||
ResultString = "Forge 提供了以下错误信息：\n" & Additional.First & "\n\n请根据上述信息进行对应处理，如果看不懂英文可以使用翻译软件。"
|
||||
Else
|
||||
ResultString = "Forge 可能已经提供了错误信息，请根据错误报告中的日志信息进行对应处理，如果看不懂英文可以使用翻译软件。\n如果没有看到报错信息，可以查看错误报告了解错误具体是如何发生的。\h"
|
||||
End If
|
||||
Case CrashReason.没有可用的分析文件
|
||||
ResultString = "你的游戏出现了一些问题，但 PCL2 未能找到相关记录文件，因此无法进行分析。\h"
|
||||
Case Else
|
||||
ResultString = "PCL2 获取到了没有详细信息的错误原因（" & CrashReasons.First.Key & "），请向 PCL2 作者提交反馈以获取详情。\h"
|
||||
End Select
|
||||
|
||||
ResultString = ResultString.
|
||||
Replace("\n", vbCrLf).
|
||||
Replace("\h", If(IsHandAnalyze, "", vbCrLf & "如果要寻求帮助，请向他人发送错误报告文件，而不是发送这个窗口的截图。")).
|
||||
Replace("\e", If(IsHandAnalyze, "", vbCrLf & "你可以查看错误报告了解错误具体是如何发生的。")).
|
||||
Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf)
|
||||
Return ResultString.Trim(vbCrLf.ToCharArray)
|
||||
End Function
|
||||
|
||||
End Class
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,619 @@
|
||||
Public Module ModModpack
|
||||
|
||||
'触发整合包安装的外部接口
|
||||
''' <summary>
|
||||
''' 弹窗要求选择一个整合包文件并进行安装。
|
||||
''' </summary>
|
||||
Public Sub ModpackInstall()
|
||||
Dim File As String = SelectFile("压缩包文件(*.rar;*.zip)|*.rar;*.zip", "选择整合包压缩文件") '选择整合包文件
|
||||
If String.IsNullOrEmpty(File) Then Exit Sub
|
||||
RunInThread(Sub() ModpackInstall(File))
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 安装一个给定的整合包文件，返回是否安装成功。必须在工作线程执行。
|
||||
''' </summary>
|
||||
Public Function ModpackInstall(File As String, Optional VersionName As String = Nothing, Optional ShowHint As Boolean = True) As Boolean
|
||||
Log("[ModPack] 整合包安装请求：" & If(File, "null"))
|
||||
Dim Archive As Compression.ZipArchive = Nothing
|
||||
Dim ArchiveBaseFolder As String = ""
|
||||
Try
|
||||
'获取整合包种类与关键 Json
|
||||
Dim PackType As Integer = -1
|
||||
Try
|
||||
Archive = New Compression.ZipArchive(New FileStream(File, FileMode.Open))
|
||||
'从根目录判断整合包类型
|
||||
If Archive.GetEntry("mcbbs.packmeta") IsNot Nothing Then PackType = 3 : Exit Try 'MCBBS 整合包（优先于 manifest.json 判断）
|
||||
If Archive.GetEntry("manifest.json") IsNot Nothing Then
|
||||
Dim Json As JObject = GetJson(ReadFile(Archive.GetEntry("manifest.json").Open, Encoding.UTF8))
|
||||
If Json("addons") Is Nothing Then
|
||||
PackType = 0 : Exit Try 'CurseForge 整合包
|
||||
Else
|
||||
PackType = 3 : Exit Try 'MCBBS 整合包
|
||||
End If
|
||||
End If
|
||||
If Archive.GetEntry("modpack.json") IsNot Nothing Then PackType = 1 : Exit Try 'HMCL 整合包
|
||||
If Archive.GetEntry("mmc-pack.json") IsNot Nothing Then PackType = 2 : Exit Try 'MMC 整合包
|
||||
'从一级目录判断整合包类型
|
||||
For Each Entry In Archive.Entries
|
||||
Dim FullNames As String() = Entry.FullName.Split("/")
|
||||
ArchiveBaseFolder = FullNames(0) & "/"
|
||||
If Entry.FullName.EndsWith("/versions/") AndAlso FullNames.Count = 3 Then PackType = 9 : Exit Try '压缩包
|
||||
'确定为一级目录下
|
||||
If FullNames.Count <> 2 Then Continue For
|
||||
'判断是否为关键文件
|
||||
If FullNames(1) = "mcbbs.packmeta" Then PackType = 3 : Exit Try 'MCBBS 整合包（优先于 manifest.json 判断）
|
||||
If FullNames(1) = "manifest.json" Then
|
||||
Dim Json As JObject = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
|
||||
If Json("addons") Is Nothing Then
|
||||
PackType = 0 : Exit Try 'CurseForge 整合包
|
||||
Else
|
||||
PackType = 3 : ArchiveBaseFolder = "overrides/" : Exit Try 'MCBBS 整合包
|
||||
End If
|
||||
End If
|
||||
If FullNames(1) = "modpack.json" Then PackType = 1 : Exit Try 'HMCL 整合包
|
||||
If FullNames(1) = "mmc-pack.json" Then PackType = 2 : Exit Try 'MMC 整合包
|
||||
Next
|
||||
Catch ex As Exception
|
||||
If File.ToLower.EndsWith(".rar") Then
|
||||
Log(ex, "PCL2 无法处理 rar 格式的压缩包，请在解压后重新压缩为 zip 格式再试", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
|
||||
Return False
|
||||
Else
|
||||
Log(ex, "打开整合包文件失败，文件可能损坏或为不支持的压缩包格式", If(ShowHint, LogLevel.Hint, LogLevel.Normal))
|
||||
Return False
|
||||
End If
|
||||
End Try
|
||||
'执行对应的安装方法
|
||||
Select Case PackType
|
||||
Case 0
|
||||
Log("[ModPack] 整合包种类：CurseForge")
|
||||
InstallPackCurseForge(File, Archive, ArchiveBaseFolder, VersionName)
|
||||
Case 1
|
||||
Log("[ModPack] 整合包种类：HMCL")
|
||||
InstallPackHMCL(File, Archive, ArchiveBaseFolder)
|
||||
Case 2
|
||||
Log("[ModPack] 整合包种类：MMC")
|
||||
InstallPackMMC(File, Archive, ArchiveBaseFolder)
|
||||
Case 3
|
||||
Log("[ModPack] 整合包种类：MCBBS")
|
||||
InstallPackMCBBS(File, Archive, ArchiveBaseFolder)
|
||||
Case 9
|
||||
Log("[ModPack] 整合包种类：压缩包")
|
||||
Archive.Dispose()
|
||||
Archive = Nothing
|
||||
InstallPackCompress(File, ArchiveBaseFolder)
|
||||
Case Else
|
||||
If ShowHint Then
|
||||
Hint("未能识别该整合包的种类，无法安装！", HintType.Critical)
|
||||
Else
|
||||
Log("[ModPack] 未能识别该整合包的种类，无法安装！")
|
||||
End If
|
||||
Return False
|
||||
End Select
|
||||
Return True
|
||||
Catch ex As Exception
|
||||
Log(ex, "准备安装整合包失败", LogLevel.Feedback)
|
||||
Return False
|
||||
Finally
|
||||
If Archive IsNot Nothing Then Archive.Dispose()
|
||||
End Try
|
||||
End Function
|
||||
|
||||
'整合包缓存清理
|
||||
Private IsInstallCacheCleared As Boolean = False
|
||||
Private IsInstallCacheClearing As Boolean = False
|
||||
Private Sub UnpackFiles(InstallTemp As String, FileAddress As String)
|
||||
'清理缓存文件夹
|
||||
If Not IsInstallCacheCleared Then
|
||||
IsInstallCacheCleared = True
|
||||
IsInstallCacheClearing = True
|
||||
Try
|
||||
Log("[ModPack] 开始清理整合包安装缓存")
|
||||
DeleteDirectory(PathTemp & "PackInstall\")
|
||||
Log("[ModPack] 已清理整合包安装缓存")
|
||||
Catch ex As Exception
|
||||
Log(ex, "清理整合包安装缓存失败")
|
||||
Finally
|
||||
IsInstallCacheClearing = False
|
||||
End Try
|
||||
ElseIf IsInstallCacheClearing Then
|
||||
'等待另一个整合包安装的清理步骤完成
|
||||
Do While IsInstallCacheClearing
|
||||
Thread.Sleep(1)
|
||||
Loop
|
||||
End If
|
||||
'解压文件
|
||||
Dim RetryCount As Integer = 1
|
||||
Dim Encode = Encoding.Default
|
||||
Try
|
||||
Retry:
|
||||
'完全不知道为啥会出现文件正在被另一进程使用的问题，总之多试试
|
||||
Directory.CreateDirectory(InstallTemp)
|
||||
DeleteDirectory(InstallTemp)
|
||||
Compression.ZipFile.ExtractToDirectory(FileAddress, InstallTemp, Encode)
|
||||
Catch ex As Exception
|
||||
Log(ex, "第 " & RetryCount & " 次解压尝试失败")
|
||||
If TypeOf ex Is ArgumentException Then
|
||||
Encode = Encoding.UTF8
|
||||
Log("[ModPack] 已切换压缩包解压编码为 UTF8")
|
||||
End If
|
||||
If RetryCount < 5 Then
|
||||
Thread.Sleep(RetryCount * 2000)
|
||||
RetryCount += 1
|
||||
GoTo Retry
|
||||
Else
|
||||
Throw
|
||||
End If
|
||||
End Try
|
||||
End Sub
|
||||
|
||||
#Region "不同类型整合包的安装方法"
|
||||
|
||||
'CurseForge
|
||||
''' <summary>
|
||||
''' 获取安装 CurseForge 整合包的加载器，若失败或跳过则返回 Nothing。
|
||||
''' 加载器以安装目标版本文件夹为输入。
|
||||
''' </summary>
|
||||
Private Function InstallPackCurseForgeLoader(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, VersionName As String) As LoaderCombo(Of String)
|
||||
'读取 Json 文件
|
||||
Dim Json As JObject
|
||||
Try
|
||||
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "manifest.json").Open))
|
||||
If Json("minecraft") Is Nothing OrElse Json("minecraft")("version") Is Nothing Then Throw New Exception("整合包未提供 Minecraft 版本信息")
|
||||
Catch ex As Exception
|
||||
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
|
||||
Return Nothing
|
||||
End Try
|
||||
'获取 Mod API 版本信息
|
||||
Dim ForgeVersion As String = Nothing
|
||||
Dim FabricVersion As String = Nothing
|
||||
For Each Entry In If(Json("minecraft")("modLoaders"), {})
|
||||
Dim Id As String = If(Entry("id"), "").ToString.ToLower
|
||||
If Id.StartsWith("forge-") Then
|
||||
'Forge 指定
|
||||
If Id.Contains("recommended") Then
|
||||
Log("[ModPack] 该整合包版本过老，已不支持进行安装！", LogLevel.Hint)
|
||||
Return Nothing
|
||||
End If
|
||||
Try
|
||||
Log("[ModPack] 整合包 Forge 版本：" & Id)
|
||||
ForgeVersion = Id.Split("-")(1)
|
||||
Exit For
|
||||
Catch ex As Exception
|
||||
Log(ex, "读取整合包 Forge 版本失败：" & Id)
|
||||
End Try
|
||||
ElseIf Id.StartsWith("fabric-") Then
|
||||
'Fabric 指定
|
||||
Try
|
||||
Log("[ModPack] 整合包 Fabric 版本：" & Id)
|
||||
FabricVersion = Id.Split("-")(1)
|
||||
Exit For
|
||||
Catch ex As Exception
|
||||
Log(ex, "读取整合包 Fabric 版本失败：" & Id)
|
||||
End Try
|
||||
End If
|
||||
Next
|
||||
'解压与配置文件
|
||||
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
Dim OverrideHome As String = If(Json("overrides"), "")
|
||||
If OverrideHome <> "" Then
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
UnpackFiles(InstallTemp, FileAddress)
|
||||
Task.Progress = 0.5
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & OverrideHome) Then
|
||||
My.Computer.FileSystem.CopyDirectory(InstallTemp & ArchiveBaseFolder & OverrideHome, PathMcFolder & "versions\" & VersionName)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 override 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.9
|
||||
'开启版本隔离
|
||||
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
End Sub) With {
|
||||
.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
End If
|
||||
'获取 Mod 列表
|
||||
Dim ModFileList As New List(Of Integer)
|
||||
For Each ModEntry In If(Json("files"), {})
|
||||
If ModEntry("projectID") Is Nothing OrElse ModEntry("fileID") Is Nothing Then
|
||||
Hint("某项 Mod 缺少必要信息，已跳过：" & ModEntry.ToString)
|
||||
Continue For
|
||||
End If
|
||||
If ModEntry("required") IsNot Nothing AndAlso Not ModEntry("required").ToObject(Of Boolean) Then Continue For
|
||||
ModFileList.Add(ModEntry("fileID"))
|
||||
Next
|
||||
If ModFileList.Count > 0 Then
|
||||
'获取 Mod 下载信息
|
||||
InstallLoaders.Add(New LoaderTask(Of Integer, JArray)(
|
||||
"获取 Mod 下载信息",
|
||||
Sub(Task As LoaderTask(Of Integer, JArray))
|
||||
Task.Output = GetJson(NetRequestRetry("https://api.curseforge.com/v1/mods/files", "POST", "{""fileIds"": [" & Join(ModFileList, ",") & "]}", "application/json"))("data")
|
||||
'如果文件已被删除，则 API 会跳过那一项
|
||||
If ModFileList.Count > Task.Output.Count Then Throw New Exception("整合包所需要的部分 Mod 版本已被 Mod 作者删除，因此无法完成整合包安装，请联系整合包作者更新整合包中的 Mod 版本")
|
||||
End Sub) With {.ProgressWeight = ModFileList.Count / 10}) '每 10 Mod 需要 1s
|
||||
'构造 NetFile
|
||||
InstallLoaders.Add(New LoaderTask(Of JArray, List(Of NetFile))("构造 Mod 下载信息",
|
||||
Sub(Task As LoaderTask(Of JArray, List(Of NetFile)))
|
||||
Dim FileList As New Dictionary(Of Integer, NetFile)
|
||||
For Each ModJson In Task.Input
|
||||
'跳过重复的 Mod（疑似 CurseForge Bug）
|
||||
If FileList.ContainsKey(ModJson("id").ToObject(Of Integer)) Then Continue For
|
||||
'实际的添加
|
||||
FileList.Add(ModJson("id"), New DlCfFile(ModJson, False).GetDownloadFile(PathMcFolder & "versions\" & VersionName & "\mods\", False))
|
||||
Task.Progress += 1 / (1 + ModFileList.Count)
|
||||
Next
|
||||
Task.Output = FileList.Values.ToList
|
||||
End Sub) With {.ProgressWeight = ModFileList.Count / 200, .Show = False}) '每 200 Mod 需要 1s
|
||||
'下载 Mod 文件
|
||||
InstallLoaders.Add(New LoaderDownload("下载 Mod", New List(Of NetFile)) With {.ProgressWeight = ModFileList.Count * 1.5}) '每个 Mod 需要 1.5s
|
||||
End If
|
||||
'构造加载器
|
||||
Dim Request As New McInstallRequest With {
|
||||
.TargetVersionName = VersionName,
|
||||
.MinecraftName = Json("minecraft")("version").ToString,
|
||||
.ForgeVersion = ForgeVersion,
|
||||
.FabricVersion = FabricVersion
|
||||
}
|
||||
Dim InstallExpectTime As Double = 0
|
||||
For Each InstallLoader In InstallLoaders
|
||||
InstallExpectTime += InstallLoader.ProgressWeight
|
||||
Next
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
If MergeLoaders Is Nothing Then Return Nothing
|
||||
Dim MergeExpectTime As Double = 0
|
||||
For Each MergeLoader In MergeLoaders
|
||||
MergeExpectTime += MergeLoader.ProgressWeight
|
||||
Next
|
||||
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .Block = False, .ProgressWeight = InstallExpectTime})
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .ProgressWeight = MergeExpectTime})
|
||||
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "CurseForge 整合包安装：" & VersionName & " "
|
||||
SyncLock LoaderTaskbarLock
|
||||
For i = 0 To LoaderTaskbar.Count - 1
|
||||
If LoaderTaskbar(i).Name = LoaderName Then
|
||||
Hint("该整合包正在安装中！", HintType.Critical)
|
||||
Return Nothing
|
||||
End If
|
||||
Next
|
||||
End SyncLock
|
||||
|
||||
'启动
|
||||
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
|
||||
Return Loader
|
||||
End Function
|
||||
Private Sub InstallPackCurseForge(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String, Optional VersionName As String = Nothing)
|
||||
|
||||
'获取版本名
|
||||
Dim ShowRibble As Boolean = VersionName Is Nothing
|
||||
If VersionName Is Nothing Then
|
||||
Dim Json As JObject
|
||||
Try
|
||||
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "manifest.json").Open))
|
||||
If Json("minecraft") Is Nothing OrElse Json("minecraft")("version") Is Nothing Then Throw New Exception("整合包未提供 Minecraft 版本信息")
|
||||
Catch ex As Exception
|
||||
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
|
||||
Exit Sub
|
||||
End Try
|
||||
Dim PackName As String = If(Json("name"), "")
|
||||
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
|
||||
If Validate.Validate(PackName) <> "" Then PackName = ""
|
||||
VersionName = MyMsgBoxInput(PackName, New ObjectModel.Collection(Of Validate) From {Validate},
|
||||
Title:="输入版本名", Button2:="取消")
|
||||
If String.IsNullOrEmpty(VersionName) Then Exit Sub
|
||||
End If
|
||||
|
||||
'启动加载器
|
||||
Dim Loader = InstallPackCurseForgeLoader(FileAddress, Archive, ArchiveBaseFolder, VersionName)
|
||||
If Loader Is Nothing Then Exit Sub
|
||||
Loader.Start(PathMcFolder & "versions\" & VersionName & "\")
|
||||
LoaderTaskbarAdd(Loader)
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
If ShowRibble Then FrmMain.BtnExtraDownload.Ribble()
|
||||
|
||||
End Sub
|
||||
|
||||
'HMCL
|
||||
Private Sub InstallPackHMCL(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
|
||||
'读取 Json 文件
|
||||
Dim Json As JObject
|
||||
Try
|
||||
Json = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "modpack.json").Open, Encoding.UTF8))
|
||||
Catch ex As Exception
|
||||
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
|
||||
Exit Sub
|
||||
End Try
|
||||
'获取版本名
|
||||
Dim PackName As String = If(Json("name"), "")
|
||||
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
|
||||
If Validate.Validate(PackName) <> "" Then PackName = ""
|
||||
Dim VersionName As String = MyMsgBoxInput(PackName, New ObjectModel.Collection(Of Validate) From {Validate},
|
||||
Title:="输入版本名", Button2:="取消")
|
||||
If VersionName Is Nothing Then Exit Sub
|
||||
'解压与配置文件
|
||||
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
UnpackFiles(InstallTemp, FileAddress)
|
||||
Task.Progress = 0.5
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "minecraft") Then
|
||||
My.Computer.FileSystem.CopyDirectory(InstallTemp & ArchiveBaseFolder & "minecraft", PathMcFolder & "versions\" & VersionName)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 minecraft override 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.9
|
||||
'开启版本隔离
|
||||
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
'构造加载器
|
||||
If Json("gameVersion") Is Nothing Then Throw New Exception("整合包未提供游戏版本信息")
|
||||
Dim Request As New McInstallRequest With {
|
||||
.TargetVersionName = VersionName,
|
||||
.MinecraftName = Json("gameVersion").ToString
|
||||
}
|
||||
Dim InstallExpectTime As Double = 0
|
||||
For Each InstallLoader In InstallLoaders
|
||||
InstallExpectTime += InstallLoader.ProgressWeight
|
||||
Next
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
If MergeLoaders Is Nothing Then Exit Sub
|
||||
Dim MergeExpectTime As Double = 0
|
||||
For Each MergeLoader In MergeLoaders
|
||||
MergeExpectTime += MergeLoader.ProgressWeight
|
||||
Next
|
||||
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, String)("重命名版本 Json（副加载器）",
|
||||
Sub()
|
||||
Dim RealFileName As String = PathMcFolder & "versions\" & VersionName & "\" & VersionName & ".json"
|
||||
Dim OldFileName As String = PathMcFolder & "versions\" & VersionName & "\pack.json"
|
||||
If File.Exists(OldFileName) Then
|
||||
'修改 id
|
||||
Dim FileJson = GetJson(ReadFile(OldFileName))
|
||||
FileJson("id") = VersionName
|
||||
'替换文件
|
||||
File.Delete(OldFileName)
|
||||
WriteFile(RealFileName, FileJson.ToString)
|
||||
Log("[ModPack] 已重命名版本 Json：" & RealFileName)
|
||||
End If
|
||||
End Sub) With {.ProgressWeight = 0.1, .Show = False})
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase) From {
|
||||
New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeExpectTime},
|
||||
New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallExpectTime},
|
||||
New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8}
|
||||
}
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "HMCL 整合包安装：" & VersionName & " "
|
||||
SyncLock LoaderTaskbarLock
|
||||
For i = 0 To LoaderTaskbar.Count - 1
|
||||
If LoaderTaskbar(i).Name = LoaderName Then
|
||||
Hint("该整合包正在安装中！", HintType.Critical)
|
||||
Exit Sub
|
||||
End If
|
||||
Next
|
||||
End SyncLock
|
||||
|
||||
'启动
|
||||
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
|
||||
'If Archive IsNot Nothing Then Archive.Dispose() '解除占用，以免在加载器中触发 “正由另一进程使用，因此该进程无法访问此文件”
|
||||
Loader.Start(PathMcFolder & "versions\" & VersionName & "\")
|
||||
LoaderTaskbarAdd(Loader)
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
FrmMain.BtnExtraDownload.Ribble()
|
||||
End Sub
|
||||
|
||||
'MMC
|
||||
Private Sub InstallPackMMC(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
|
||||
'读取 Json 文件
|
||||
Dim PackJson As JObject, PackInstance As String
|
||||
Try
|
||||
PackJson = GetJson(ReadFile(Archive.GetEntry(ArchiveBaseFolder & "mmc-pack.json").Open, Encoding.UTF8))
|
||||
PackInstance = ReadFile(Archive.GetEntry(ArchiveBaseFolder & "instance.cfg").Open, Encoding.UTF8)
|
||||
Catch ex As Exception
|
||||
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
|
||||
Exit Sub
|
||||
End Try
|
||||
'获取版本名
|
||||
Dim PackName As String = If(RegexSeek(PackInstance, "(?<=\nname\=)[^\n]+"), "")
|
||||
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
|
||||
If Validate.Validate(PackName) <> "" Then PackName = ""
|
||||
Dim VersionName As String = MyMsgBoxInput(PackName, New ObjectModel.Collection(Of Validate) From {Validate},
|
||||
Title:="输入版本名", Button2:="取消")
|
||||
If VersionName Is Nothing Then Exit Sub
|
||||
'解压与配置文件
|
||||
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
UnpackFiles(InstallTemp, FileAddress)
|
||||
Task.Progress = 0.5
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & ".minecraft") Then
|
||||
My.Computer.FileSystem.CopyDirectory(InstallTemp & ArchiveBaseFolder & ".minecraft", PathMcFolder & "versions\" & VersionName)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 override .minecraft 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.9
|
||||
'开启版本隔离
|
||||
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
'构造版本安装请求
|
||||
If PackJson("components") Is Nothing Then Throw New Exception("整合包未提供游戏版本信息")
|
||||
Dim Request As New McInstallRequest With {.TargetVersionName = VersionName}
|
||||
For Each Component In PackJson("components")
|
||||
Select Case If(Component("uid"), "").ToString
|
||||
Case "org.lwjgl"
|
||||
Log("[ModPack] 已跳过 LWJGL 项")
|
||||
Case "net.minecraft"
|
||||
Request.MinecraftName = Component("version")
|
||||
Case "net.minecraftforge"
|
||||
Request.ForgeVersion = Component("version")
|
||||
End Select
|
||||
Next
|
||||
'构造加载器
|
||||
Dim InstallExpectTime As Double = 0
|
||||
For Each InstallLoader In InstallLoaders
|
||||
InstallExpectTime += InstallLoader.ProgressWeight
|
||||
Next
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
If MergeLoaders Is Nothing Then Exit Sub
|
||||
Dim MergeExpectTime As Double = 0
|
||||
For Each MergeLoader In MergeLoaders
|
||||
MergeExpectTime += MergeLoader.ProgressWeight
|
||||
Next
|
||||
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeExpectTime})
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallExpectTime})
|
||||
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "MMC 整合包安装：" & VersionName & " "
|
||||
SyncLock LoaderTaskbarLock
|
||||
For i = 0 To LoaderTaskbar.Count - 1
|
||||
If LoaderTaskbar(i).Name = LoaderName Then
|
||||
Hint("该整合包正在安装中！", HintType.Critical)
|
||||
Exit Sub
|
||||
End If
|
||||
Next
|
||||
End SyncLock
|
||||
|
||||
'启动
|
||||
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
|
||||
Loader.Start(PathMcFolder & "versions\" & VersionName & "\")
|
||||
LoaderTaskbarAdd(Loader)
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
FrmMain.BtnExtraDownload.Ribble()
|
||||
End Sub
|
||||
|
||||
'MCBBS
|
||||
Private Sub InstallPackMCBBS(FileAddress As String, Archive As Compression.ZipArchive, ArchiveBaseFolder As String)
|
||||
'读取 Json 文件
|
||||
Dim Json As JObject
|
||||
Try
|
||||
Dim Entry = If(Archive.GetEntry(ArchiveBaseFolder & "mcbbs.packmeta"), Archive.GetEntry(ArchiveBaseFolder & "manifest.json"))
|
||||
Json = GetJson(ReadFile(Entry.Open, Encoding.UTF8))
|
||||
Catch ex As Exception
|
||||
Log(ex, "整合包安装信息存在问题", LogLevel.Hint)
|
||||
Exit Sub
|
||||
End Try
|
||||
'获取版本名
|
||||
Dim PackName As String = If(Json("name"), "")
|
||||
Dim Validate As New ValidateFolderName(PathMcFolder & "versions")
|
||||
If Validate.Validate(PackName) <> "" Then PackName = ""
|
||||
Dim VersionName As String = MyMsgBoxInput(PackName, New ObjectModel.Collection(Of Validate) From {Validate},
|
||||
Title:="输入版本名", Button2:="取消")
|
||||
If VersionName Is Nothing Then Exit Sub
|
||||
'解压与配置文件
|
||||
Dim InstallTemp As String = PathTemp & "PackInstall\" & RandomInteger(0, 100000) & "\"
|
||||
Dim InstallLoaders As New List(Of LoaderBase)
|
||||
InstallLoaders.Add(New LoaderTask(Of String, Integer)("解压整合包文件",
|
||||
Sub(Task As LoaderTask(Of String, Integer))
|
||||
UnpackFiles(InstallTemp, FileAddress)
|
||||
Task.Progress = 0.5
|
||||
'复制结果
|
||||
If Directory.Exists(InstallTemp & ArchiveBaseFolder & "overrides") Then
|
||||
My.Computer.FileSystem.CopyDirectory(InstallTemp & ArchiveBaseFolder & "overrides", PathMcFolder & "versions\" & VersionName)
|
||||
Else
|
||||
Log("[ModPack] 整合包中未找到 overrides 目录，已跳过")
|
||||
End If
|
||||
Task.Progress = 0.9
|
||||
'开启版本隔离
|
||||
WriteIni(PathMcFolder & "versions\" & VersionName & "\PCL\Setup.ini", "VersionArgumentIndie", 1)
|
||||
End Sub) With {.ProgressWeight = New FileInfo(FileAddress).Length / 1024 / 1024 / 6, .Block = False}) '每 6M 需要 1s
|
||||
'构造加载器
|
||||
If Json("addons") Is Nothing Then Throw New Exception("整合包未提供游戏版本信息")
|
||||
Dim Addons As New Dictionary(Of String, String)
|
||||
For Each Entry In Json("addons")
|
||||
Addons.Add(Entry("id"), Entry("version"))
|
||||
Next
|
||||
If Not Addons.ContainsKey("game") Then Throw New Exception("整合包未提供游戏版本信息")
|
||||
Dim Request As New McInstallRequest With {
|
||||
.TargetVersionName = VersionName,
|
||||
.MinecraftName = Addons("game"),
|
||||
.OptiFineVersion = If(Addons.ContainsKey("optifine"), Addons("optifine"), Nothing),
|
||||
.ForgeVersion = If(Addons.ContainsKey("forge"), Addons("forge"), Nothing),
|
||||
.FabricVersion = If(Addons.ContainsKey("fabric"), Addons("fabric"), Nothing)
|
||||
}
|
||||
Dim InstallExpectTime As Double = 0
|
||||
For Each InstallLoader In InstallLoaders
|
||||
InstallExpectTime += InstallLoader.ProgressWeight
|
||||
Next
|
||||
Dim MergeLoaders As List(Of LoaderBase) = McInstallLoader(Request, True)
|
||||
If MergeLoaders Is Nothing Then Exit Sub
|
||||
Dim MergeExpectTime As Double = 0
|
||||
For Each MergeLoader In MergeLoaders
|
||||
MergeExpectTime += MergeLoader.ProgressWeight
|
||||
Next
|
||||
'构造 Libraries 加载器（为了使得 Mods 下载结束后再构造，这样才会下载 JumpLoader 文件）
|
||||
Dim LoadersLib As New List(Of LoaderBase)
|
||||
LoadersLib.Add(New LoaderTask(Of String, List(Of NetFile))("分析游戏支持库文件（副加载器）", Sub(Task As LoaderTask(Of String, List(Of NetFile))) Task.Output = McLibFix(New McVersion(VersionName))) With {.ProgressWeight = 1, .Show = False})
|
||||
LoadersLib.Add(New LoaderDownload("下载游戏支持库文件（副加载器）", New List(Of NetFile)) With {.ProgressWeight = 7, .Show = False})
|
||||
'构造总加载器
|
||||
Dim Loaders As New List(Of LoaderBase)
|
||||
Loaders.Add(New LoaderCombo(Of String)("游戏安装", MergeLoaders) With {.Show = False, .Block = False, .ProgressWeight = MergeExpectTime})
|
||||
Loaders.Add(New LoaderCombo(Of String)("整合包安装", InstallLoaders) With {.Show = False, .ProgressWeight = InstallExpectTime})
|
||||
Loaders.Add(New LoaderCombo(Of String)("下载游戏支持库文件", LoadersLib) With {.ProgressWeight = 8})
|
||||
|
||||
'重复任务检查
|
||||
Dim LoaderName As String = "MCBBS 整合包安装：" & VersionName & " "
|
||||
SyncLock LoaderTaskbarLock
|
||||
For i = 0 To LoaderTaskbar.Count - 1
|
||||
If LoaderTaskbar(i).Name = LoaderName Then
|
||||
Hint("该整合包正在安装中！", HintType.Critical)
|
||||
Exit Sub
|
||||
End If
|
||||
Next
|
||||
End SyncLock
|
||||
|
||||
'启动
|
||||
Dim Loader As New LoaderCombo(Of String)(LoaderName, Loaders) With {.OnStateChanged = AddressOf McInstallState}
|
||||
'If Archive IsNot Nothing Then Archive.Dispose() '解除占用，以免在加载器中触发 “正由另一进程使用，因此该进程无法访问此文件”
|
||||
Loader.Start(PathMcFolder & "versions\" & VersionName & "\")
|
||||
LoaderTaskbarAdd(Loader)
|
||||
FrmMain.BtnExtraDownload.ShowRefresh()
|
||||
FrmMain.BtnExtraDownload.Ribble()
|
||||
End Sub
|
||||
|
||||
'普通压缩包
|
||||
Private Sub InstallPackCompress(FileAddress As String, ArchiveBaseFolder As String)
|
||||
MyMsgBox("请在接下来打开的窗口中选择安装目标文件夹，它必须是一个空文件夹。", "安装提示", "继续", ForceWait:=True)
|
||||
'获取解压路径
|
||||
Dim TargetFolder As String = SelectFolder("选择安装目标（必须是一个空文件夹）")
|
||||
If String.IsNullOrEmpty(TargetFolder) Then Exit Sub
|
||||
If TargetFolder.Contains("!") OrElse TargetFolder.Contains(";") Then Hint("Minecraft 文件夹路径中不能含有感叹号或分号！", HintType.Critical) : Exit Sub
|
||||
If Directory.GetFileSystemEntries(TargetFolder).Length > 0 Then Hint("请选择一个空文件夹作为安装目标！", HintType.Critical) : Exit Sub
|
||||
'要求显示名称
|
||||
Dim NewName As String = MyMsgBoxInput(GetFolderNameFromPath(TargetFolder), New ObjectModel.Collection(Of Validate) From {
|
||||
New ValidateNullOrWhiteSpace, New ValidateLength(1, 30), New ValidateExcept({">", "|"})
|
||||
},, "输入它在列表中的显示名称",, "取消")
|
||||
If String.IsNullOrWhiteSpace(NewName) Then Exit Sub
|
||||
'解压
|
||||
Hint("正在解压压缩包……")
|
||||
UnpackFiles(TargetFolder, FileAddress)
|
||||
'加入文件夹列表
|
||||
PageSelectLeft.AddFolder(TargetFolder, NewName, False)
|
||||
Hint("已加入游戏文件夹列表：" & NewName, HintType.Finish)
|
||||
End Sub
|
||||
|
||||
#End Region
|
||||
|
||||
End Module
|
||||
@@ -0,0 +1,361 @@
|
||||
Public Module ModWatcher
|
||||
|
||||
'对全体的监视
|
||||
Public McWatcherList As New List(Of Watcher)
|
||||
Private IsWatcherRunning As Boolean = False
|
||||
Public HasRunningMinecraft As Boolean = False
|
||||
Private Sub WatcherStateChanged()
|
||||
Dim IsRunning As Boolean = False
|
||||
Dim IsCrashed As Boolean = False
|
||||
For Each Watcher In McWatcherList
|
||||
If Watcher.State = Watcher.MinecraftState.Loading OrElse Watcher.State = Watcher.MinecraftState.Running Then
|
||||
IsRunning = True
|
||||
Exit For
|
||||
ElseIf Watcher.State = Watcher.MinecraftState.Crashed Then
|
||||
IsCrashed = True
|
||||
End If
|
||||
Next
|
||||
If IsWatcherRunning = IsRunning Then Exit Sub
|
||||
IsWatcherRunning = IsRunning
|
||||
If IsWatcherRunning Then
|
||||
MinecraftStart()
|
||||
Else
|
||||
MinecraftStop(IsCrashed)
|
||||
End If
|
||||
End Sub
|
||||
Private Sub MinecraftStart()
|
||||
McLaunchLog("[全局] 出现运行中的 Minecraft")
|
||||
HasRunningMinecraft = True
|
||||
FrmMain.BtnExtraShutdown.ShowRefresh()
|
||||
End Sub
|
||||
Private Sub MinecraftStop(HasMinecraftCrashed As Boolean)
|
||||
McLaunchLog("[全局] 已无运行中的 Minecraft")
|
||||
HasRunningMinecraft = False
|
||||
FrmMain.BtnExtraShutdown.ShowRefresh()
|
||||
'音乐播放
|
||||
If Setup.Get("UiMusicStop") Then
|
||||
RunInUi(Sub() If MusicResume() Then Log("[Music] 已根据设置，在结束后开始音乐播放"))
|
||||
ElseIf Setup.Get("UiMusicStart") Then
|
||||
RunInUi(Sub() If MusicPause() Then Log("[Music] 已根据设置，在结束后暂停音乐播放"))
|
||||
End If
|
||||
'启动器可见性
|
||||
Select Case Setup.Get("LaunchArgumentVisible")
|
||||
Case 2
|
||||
'直接关闭
|
||||
If HasMinecraftCrashed Then
|
||||
RunInUi(Sub() FrmMain.Hidden = False)
|
||||
Else
|
||||
RunInUi(Sub() FrmMain.EndProgram(False))
|
||||
End If
|
||||
Case 3
|
||||
'恢复
|
||||
RunInUi(Sub() FrmMain.Hidden = False)
|
||||
End Select
|
||||
End Sub
|
||||
|
||||
'对单个进程的监视
|
||||
Public Class Watcher
|
||||
|
||||
'初始化
|
||||
Public GameProcess As Process
|
||||
Public Version As McVersion
|
||||
Private WindowTitle As String = ""
|
||||
Private PID As Integer
|
||||
Public Loader As LoaderTask(Of Process, Integer)
|
||||
Public Sub New(Loader As LoaderTask(Of Process, Integer), Version As McVersion, WindowTitle As String)
|
||||
Me.Loader = Loader
|
||||
Me.Version = Version
|
||||
Me.WindowTitle = WindowTitle
|
||||
Me.PID = Loader.Input.Id
|
||||
WatcherLog("开始 Minecraft 日志监控")
|
||||
If Me.WindowTitle <> "" Then WatcherLog("要求窗口标题：" & WindowTitle)
|
||||
|
||||
'更改列表
|
||||
Dim NewWatcherList As New List(Of Watcher)
|
||||
For Each Watch In McWatcherList
|
||||
If Watch.State = MinecraftState.Crashed OrElse Watch.State = MinecraftState.Ended Then Continue For
|
||||
NewWatcherList.Add(Watch)
|
||||
Next
|
||||
NewWatcherList.Add(Me)
|
||||
McWatcherList = NewWatcherList
|
||||
WatcherStateChanged()
|
||||
|
||||
'初始化进程与日志读取
|
||||
Me.GameProcess = Loader.Input
|
||||
GameProcess.BeginOutputReadLine()
|
||||
GameProcess.BeginErrorReadLine()
|
||||
AddHandler GameProcess.OutputDataReceived, AddressOf LogReceived
|
||||
AddHandler GameProcess.ErrorDataReceived, AddressOf LogReceived
|
||||
|
||||
'初始化时钟
|
||||
RunInNewThread(Sub()
|
||||
Try
|
||||
MinecraftBeforeLaunch = GetAllMinecraftWindowHandle(False).Keys.ToList
|
||||
Do Until State = MinecraftState.Ended OrElse State = MinecraftState.Crashed OrElse Loader.State = LoadState.Aborted
|
||||
TimerWindow()
|
||||
TimerLog()
|
||||
If State = MinecraftState.Loading Then ProgressUpdate()
|
||||
'设置窗口标题
|
||||
For i = 1 To 3
|
||||
If IsWindowFinished AndAlso WindowTitle <> "" AndAlso State = MinecraftState.Running AndAlso Not GameProcess.HasExited Then
|
||||
Dim RealTitle As String = WindowTitle.Replace("{time}", Date.Now.ToShortTimeString)
|
||||
SetWindowText(WindowHandle, RealTitle.ToCharArray)
|
||||
End If
|
||||
Thread.Sleep(64)
|
||||
Next
|
||||
Loop
|
||||
WatcherLog("Minecraft 日志监控已退出")
|
||||
Catch ex As Exception
|
||||
Log(ex, "Minecraft 日志监控主循环出错", LogLevel.Feedback)
|
||||
State = MinecraftState.Ended
|
||||
End Try
|
||||
End Sub, "Minecraft Watcher PID " & PID)
|
||||
End Sub
|
||||
|
||||
'状态
|
||||
Private _State As MinecraftState = MinecraftState.Loading
|
||||
Public Property State As MinecraftState
|
||||
Get
|
||||
Return _State
|
||||
End Get
|
||||
Set(ByVal value As MinecraftState)
|
||||
If _State = value Then Exit Property
|
||||
_State = value
|
||||
WatcherStateChanged()
|
||||
End Set
|
||||
End Property
|
||||
Public Enum MinecraftState
|
||||
Loading
|
||||
Running
|
||||
Crashed
|
||||
Ended
|
||||
End Enum
|
||||
|
||||
'日志
|
||||
Public WaitingLog As New List(Of String)(1000)
|
||||
Private ReadOnly WaitingLogLock As New Object
|
||||
Private Sub LogReceived(sender As Object, e As DataReceivedEventArgs)
|
||||
SyncLock WaitingLogLock
|
||||
WaitingLog.Add(e.Data)
|
||||
End SyncLock
|
||||
End Sub
|
||||
Private Sub TimerLog()
|
||||
Try
|
||||
'输出文本
|
||||
Dim Copyed As New List(Of String)
|
||||
SyncLock WaitingLogLock
|
||||
If WaitingLog.Count = 0 Then Exit Sub
|
||||
Copyed = WaitingLog
|
||||
WaitingLog = New List(Of String)(1000)
|
||||
End SyncLock
|
||||
For Each Str As String In Copyed
|
||||
GameLog(Str)
|
||||
Next
|
||||
'游戏退出检查
|
||||
If GameProcess.HasExited Then
|
||||
WatcherLog("Minecraft 已退出，返回值：" & GameProcess.ExitCode)
|
||||
'If Process.ExitCode = 1 Then
|
||||
' '返回值为 1，考虑是任务管理器结束
|
||||
' WatcherLog("Minecraft 返回值为 1，考虑为任务管理器结束") '并不，崩了照样是 1
|
||||
' State = MinecraftState.Ended
|
||||
'Else
|
||||
If State = MinecraftState.Loading Then
|
||||
'窗口未出现
|
||||
WatcherLog("Minecraft 尚未加载完成，可能已崩溃")
|
||||
Crashed()
|
||||
ElseIf GameProcess.ExitCode <> 0 AndAlso State = MinecraftState.Running AndAlso Version.ReleaseTime.Year >= 2012 Then
|
||||
'返回值不为 0 且未结束
|
||||
WatcherLog("Minecraft 返回值异常，可能已崩溃")
|
||||
Crashed()
|
||||
Else
|
||||
'正常关闭
|
||||
State = MinecraftState.Ended
|
||||
End If
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "输出 Minecraft 日志失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub
|
||||
Public LatestLog As New Queue(Of String)
|
||||
Private Sub GameLog(Text As String)
|
||||
'预处理
|
||||
If Text Is Nothing Then Exit Sub
|
||||
Text = Text.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf)
|
||||
'加入预存储
|
||||
LatestLog.Enqueue(Text)
|
||||
If LatestLog.Count >= 501 Then LatestLog.Dequeue()
|
||||
'进度处理
|
||||
If LogProgress < 1 Then
|
||||
WatcherLog("日志 1/5：已出现日志输出")
|
||||
LogProgress = 1
|
||||
End If '可能第一句就是后面需要判断的 Log（重现：启动 1.15.2 原版）
|
||||
If LogProgress < 2 AndAlso Text.Contains("Setting user:") Then
|
||||
WatcherLog("日志 2/5：游戏用户已设置") '仅确保支持 Minecraft 1.7+
|
||||
LogProgress = 2
|
||||
ElseIf LogProgress < 3 AndAlso Text.ToLower.Contains("lwjgl version") Then
|
||||
WatcherLog("日志 3/5：LWJGL 版本已确认")
|
||||
LogProgress = 3
|
||||
ElseIf LogProgress < 4 AndAlso (Text.Contains("OpenAL initialized") OrElse Text.Contains("Starting up SoundSystem")) Then
|
||||
WatcherLog("日志 4/5：OpenAL 已加载") '仅确保支持 Minecraft 1.7+
|
||||
LogProgress = 4
|
||||
ElseIf LogProgress < 5 AndAlso ((Text.Contains("Created") AndAlso Text.Contains("textures") AndAlso Text.Contains("-atlas")) OrElse Text.Contains("Found animation info")) Then
|
||||
WatcherLog("日志 5/5：材质已加载") '仅确保支持 Minecraft 1.7+
|
||||
LogProgress = 5
|
||||
End If
|
||||
'输出日志
|
||||
'Log(Text)
|
||||
'关闭与崩溃检测
|
||||
If Not Text.Contains("[CHAT]") Then
|
||||
If Text.Contains("Someone is closing me!") Then
|
||||
WatcherLog("识别为关闭的 Log：" & Text)
|
||||
State = MinecraftState.Ended
|
||||
ElseIf Text.Contains("Crash report saved to") OrElse Text.Contains("This crash report has been saved to:") Then
|
||||
' Text.Contains("Minecraft ran into a problem! Report saved to:") Then
|
||||
'Minecraft 崩溃，忽略 VanillaFix
|
||||
WatcherLog("识别为崩溃的 Log：" & Text)
|
||||
Crashed()
|
||||
ElseIf Text.Contains("Could not save crash report to") Then
|
||||
'Minecraft 崩溃，无法保存崩溃日志
|
||||
WatcherLog("识别为崩溃的 Log：" & Text)
|
||||
Crashed()
|
||||
ElseIf Text.Contains("/ERROR]: Unable to launch") OrElse Text.Contains("An exception was thrown, the game will display an error screen and halt.") Then
|
||||
'Forge 崩溃
|
||||
WatcherLog("识别为崩溃的 Log：" & Text)
|
||||
Crashed()
|
||||
'ElseIf Text.Contains("Shutdown failure!") Then
|
||||
' 'Minecraft 强行崩溃，由于点 X 强行关闭也会触发这句话，所以不可用
|
||||
' Crashed(Nothing)
|
||||
End If
|
||||
End If
|
||||
End Sub
|
||||
Private Sub WatcherLog(Text As String)
|
||||
McLaunchLog("[" & PID & "] " & Text)
|
||||
End Sub
|
||||
|
||||
'进度更新
|
||||
Private LogProgress As Integer = 0
|
||||
Private Sub ProgressUpdate()
|
||||
Dim CurrentProgress As Double
|
||||
If IsWindowAppeared OrElse LogProgress = 5 Then
|
||||
CurrentProgress = 0.95
|
||||
WatcherLog("Minecraft 加载已完成")
|
||||
State = MinecraftState.Running
|
||||
Else
|
||||
CurrentProgress = Math.Min(LogProgress, 3) / 3 * 0.9
|
||||
End If
|
||||
Loader.Progress = CurrentProgress
|
||||
End Sub
|
||||
|
||||
'窗口检查
|
||||
Private IsWindowAppeared As Boolean = False
|
||||
Private IsWindowFinished As Boolean = False
|
||||
Private WindowHandle As IntPtr
|
||||
Private MinecraftBeforeLaunch As List(Of IntPtr)
|
||||
Private Sub TimerWindow()
|
||||
Try
|
||||
If GameProcess.HasExited Then Exit Sub
|
||||
If Not IsWindowFinished Then
|
||||
'获取全部窗口，检查是否有新增的
|
||||
Dim MinecraftWindows = GetAllMinecraftWindowHandle(True)
|
||||
For Each Window In MinecraftBeforeLaunch
|
||||
If MinecraftWindows.ContainsKey(Window) Then MinecraftWindows.Remove(Window)
|
||||
Next
|
||||
If MinecraftWindows.Count = 0 Then Exit Sub
|
||||
'已找到窗口
|
||||
If MinecraftWindows.Values(0) Then
|
||||
'已找到 Minecraft 窗口
|
||||
WindowHandle = MinecraftWindows.Keys(0)
|
||||
WatcherLog("Minecraft 窗口已加载：" & WindowHandle.ToInt64)
|
||||
IsWindowFinished = True
|
||||
'最大化
|
||||
Thread.Sleep(3000) '1.7.10 LiteLoader 不延迟会显示错误
|
||||
If Setup.Get("LaunchArgumentWindowType") = 4 Then ShowWindow(WindowHandle, 3)
|
||||
ElseIf Not IsWindowAppeared Then
|
||||
'已找到 FML 窗口
|
||||
WatcherLog("FML 窗口已加载：" & MinecraftWindows.Keys(0).ToInt64)
|
||||
End If
|
||||
IsWindowAppeared = True
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "检查 Minecraft 窗口失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 获取所有 Minecraft 窗口句柄。
|
||||
''' Value: 是否为 Minecraft 窗口，而不是 FML 窗口。
|
||||
''' </summary>
|
||||
''' <param name="CanUseFml">是否包含 FML 窗口</param>
|
||||
Private Function GetAllMinecraftWindowHandle(CanUseFml As Boolean) As Dictionary(Of IntPtr, Boolean)
|
||||
Dim AllList As New Dictionary(Of IntPtr, Boolean)
|
||||
EnumWindows(Sub(hwnd As IntPtr, lParam As Integer)
|
||||
'检查类名
|
||||
Dim str As New StringBuilder(512)
|
||||
GetClassName(hwnd, str, str.Capacity)
|
||||
Dim ClassName As String = str.ToString
|
||||
If Not (ClassName = "GLFW30" OrElse ClassName = "LWJGL" OrElse ClassName = "SunAwtFrame") Then Exit Sub
|
||||
'检查窗口标题名
|
||||
str = New StringBuilder(512)
|
||||
GetWindowText(hwnd, str, str.Capacity)
|
||||
Dim WindowText As String = str.ToString
|
||||
If CanUseFml AndAlso WindowText.StartsWith("FML") Then
|
||||
AllList.Add(hwnd, False)
|
||||
ElseIf Not (WindowText.StartsWith("GLFW") OrElse WindowText = "PopupMessageWindow") Then
|
||||
'有的 Mod 可以修改窗口标题，不能检测是否为 Minecraft 打头
|
||||
'部分版本会搞个 GLFW message window 出来所以得反选
|
||||
AllList.Add(hwnd, True)
|
||||
End If
|
||||
'If WindowText.StartsWith("Minecraft") Then
|
||||
' AllList.Add(hwnd, True)
|
||||
'ElseIf CanUseFml AndAlso WindowText.StartsWith("FML") Then
|
||||
' AllList.Add(hwnd, False)
|
||||
'End If
|
||||
End Sub, 0)
|
||||
Return AllList
|
||||
End Function
|
||||
Private Delegate Sub EnumWindowsSub(hwnd As IntPtr, lParam As Integer)
|
||||
Private Declare Function EnumWindows Lib "user32" (hWnd As EnumWindowsSub, lParam As Integer) As Boolean
|
||||
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (hWnd As Integer, str As StringBuilder, maxCount As Integer) As Integer
|
||||
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (hWnd As Integer, str As StringBuilder, maxCount As Integer) As Integer
|
||||
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (hWnd As Integer, str As String) As Boolean
|
||||
Private Declare Function ShowWindow Lib "user32" (hWnd As IntPtr, cmdWindow As UInteger) As Boolean
|
||||
|
||||
'崩溃处理
|
||||
Private Sub Crashed()
|
||||
If State = MinecraftState.Crashed OrElse State = MinecraftState.Ended Then Exit Sub
|
||||
State = MinecraftState.Crashed
|
||||
'崩溃分析
|
||||
WatcherLog("Minecraft 已崩溃，将在 2 秒后开始崩溃分析")
|
||||
Hint("检测到 Minecraft 出现错误，错误分析已开始……")
|
||||
RunInNewThread(Sub()
|
||||
Try
|
||||
Thread.Sleep(2000)
|
||||
WatcherLog("崩溃分析开始")
|
||||
Dim Analyzer As New CrashAnalyzer(PID)
|
||||
Analyzer.Collect(Version.PathIndie, LatestLog.ToList)
|
||||
Analyzer.Prepare()
|
||||
Analyzer.Analyze(Version)
|
||||
Analyzer.Output(False, New List(Of String) From
|
||||
{Version.Path & Version.Name & ".json",
|
||||
Path & "PCL\Log1.txt",
|
||||
Path & "PCL\LatestLaunch.bat"})
|
||||
Catch ex As Exception
|
||||
Log(ex, "崩溃分析失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub, "Crash Analyzer")
|
||||
End Sub
|
||||
|
||||
'强制关闭
|
||||
Public Sub Kill()
|
||||
State = MinecraftState.Ended
|
||||
WatcherLog("尝试强制结束 Minecraft 进程")
|
||||
Try
|
||||
If Not GameProcess.HasExited Then GameProcess.Kill()
|
||||
WatcherLog("已强制结束 Minecraft 进程")
|
||||
Catch ex As Exception
|
||||
Log(ex, "强制结束 Minecraft 进程失败", LogLevel.Hint)
|
||||
End Try
|
||||
End Sub
|
||||
|
||||
End Class
|
||||
|
||||
End Module
|
||||
@@ -0,0 +1,173 @@
|
||||
Public Module ModEvent
|
||||
|
||||
Public Sub TryStartEvent(Type As String, Data As String)
|
||||
If String.IsNullOrWhiteSpace(Type) Then Exit Sub
|
||||
Dim RealData As String() = {""}
|
||||
If Data IsNot Nothing Then RealData = Data.Split("|")
|
||||
StartEvent(Type, RealData)
|
||||
End Sub
|
||||
Public Sub StartEvent(Type As String, Data As String())
|
||||
Try
|
||||
Log("[Control] 执行自定义事件：" & Type & ", " & Join(Data, ", "))
|
||||
Select Case Type
|
||||
|
||||
Case "打开网页"
|
||||
Data(0) = Data(0).Replace("\", "/")
|
||||
If Not (Data(0).StartsWith("http://") OrElse Data(0).StartsWith("https://")) Then
|
||||
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "如果想要启动程序，请将 EventType 改为 打开文件。", "事件执行失败")
|
||||
Exit Sub
|
||||
End If
|
||||
Hint("正在打开网页，请稍候……")
|
||||
OpenWebsite(Data(0))
|
||||
|
||||
Case "打开文件", "打开帮助"
|
||||
RunInThread(Sub()
|
||||
Try
|
||||
|
||||
'确认实际路径
|
||||
Dim ActualPaths = GetEventAbsoluteUrls(Data(0), Type)
|
||||
Dim Location = ActualPaths(0), WorkingDir = ActualPaths(1)
|
||||
|
||||
'执行
|
||||
If Type = "打开文件" Then
|
||||
Dim Info As New ProcessStartInfo With {
|
||||
.Arguments = If(Data.Length >= 2, Data(1), ""),
|
||||
.FileName = Location,
|
||||
.WorkingDirectory = WorkingDir
|
||||
}
|
||||
Process.Start(Info)
|
||||
Else '打开帮助
|
||||
PageOtherHelp.EnterHelpPage(Location)
|
||||
End If
|
||||
|
||||
Catch ex As Exception
|
||||
Log(ex, "执行打开类自定义事件失败", LogLevel.Msgbox)
|
||||
End Try
|
||||
End Sub)
|
||||
Case "启动游戏"
|
||||
|
||||
'初始化与前置条件检测
|
||||
If Not (FrmLaunchLeft.BtnLaunch.IsEnabled AndAlso FrmLaunchLeft.BtnLaunch.Visibility = Visibility.Visible AndAlso FrmLaunchLeft.BtnLaunch.IsHitTestVisible) Then
|
||||
Hint("已有游戏正在启动中！", HintType.Critical) : Exit Sub
|
||||
End If
|
||||
If Not Directory.Exists(PathMcFolder & "versions\" & Data(0)) Then
|
||||
Hint("未在当前 Minecraft 文件夹找到版本 " & Data(0) & "！", HintType.Critical) : Exit Sub
|
||||
End If
|
||||
Dim ButtonVersion As New McVersion(Data(0))
|
||||
ButtonVersion.Load()
|
||||
If ButtonVersion.State = McVersionState.Error Then
|
||||
Hint("无法启动 " & Data(0) & "：" & ButtonVersion.Info, HintType.Critical) : Exit Sub
|
||||
End If
|
||||
|
||||
'实际启动
|
||||
McVersionCurrent = ButtonVersion
|
||||
Setup.Set("LaunchVersionSelect", McVersionCurrent.Name)
|
||||
FrmLaunchLeft.PageLaunchLeft_Loaded()
|
||||
FrmLaunchLeft.RefreshButtonsUI()
|
||||
FrmMain.AprilGiveup()
|
||||
FrmLaunchLeft.LaunchButtonClick(If(Data.Length >= 2, Data(1), ""))
|
||||
FrmMain.PageChange(FormMain.PageType.Launch)
|
||||
|
||||
Case "复制文本"
|
||||
ClipboardSet(Join(Data, "|"))
|
||||
|
||||
Case "刷新主页"
|
||||
FrmLaunchRight.ForceRefresh()
|
||||
|
||||
Case "刷新帮助"
|
||||
PageOtherLeft.RefreshHelp()
|
||||
|
||||
Case "弹出窗口"
|
||||
MyMsgBox(Data(1).Replace("\n", vbCrLf), Data(0).Replace("\n", vbCrLf))
|
||||
|
||||
Case "下载文件"
|
||||
Data(0) = Data(0).Replace("\", "/")
|
||||
If Not (Data(0).StartsWith("http://") OrElse Data(0).StartsWith("https://")) Then
|
||||
MyMsgBox("EventData 必须为以 http:// 或 https:// 开头的网址。" & vbCrLf & "PCL2 不支持其他乱七八糟的协议。", "事件执行失败")
|
||||
Exit Sub
|
||||
End If
|
||||
PageOtherTest.StartCustomDownload(Data(0))
|
||||
|
||||
Case Else
|
||||
MyMsgBox("未知的事件类型：" & Type & vbCrLf & "请检查事件类型填写是否正确，或者 PCL2 是否为最新版本。", "事件执行失败")
|
||||
End Select
|
||||
Catch ex As Exception
|
||||
Log(ex, "事件执行失败", LogLevel.Msgbox)
|
||||
End Try
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 返回自定义事件的绝对 Url。实际返回 {绝对 Url, WorkingDir}。
|
||||
''' 失败会抛出异常。
|
||||
''' </summary>
|
||||
Public Function GetEventAbsoluteUrls(RelativeUrl As String, EventType As String) As String()
|
||||
|
||||
'网页确认
|
||||
If RelativeUrl.ToLower.StartsWith("http") Then
|
||||
If RunInUi() Then
|
||||
Throw New Exception("MyListItem 在界面初始化时就需要获取帮助标题等信息，这会导致程序在网络请求时卡死。" & vbCrLf &
|
||||
"因此，请换用 MyListItem 以外的控件（例如 MyButton）作为联网帮助页面的入口！")
|
||||
End If
|
||||
'获取文件名
|
||||
Dim RawFileName As String
|
||||
Try
|
||||
RawFileName = GetFileNameFromPath(RelativeUrl)
|
||||
If Not RawFileName.ToLower.EndsWith(".json") Then Throw New Exception("未指向 .json 后缀的文件")
|
||||
Catch ex As Exception
|
||||
Throw New Exception("联网帮助页面须指向一个帮助 JSON 文件，并在同路径下包含相应 XAML 文件！" & vbCrLf &
|
||||
"例如：" & vbCrLf &
|
||||
" - https://www.baidu.com/test.json（填写这个路径）" & vbCrLf &
|
||||
" - https://www.baidu.com/test.xaml（同时也需要包含这个文件）", ex)
|
||||
End Try
|
||||
'下载文件
|
||||
Dim LocalTemp1 As String = PathTemp & "CustomEvent\" & RawFileName
|
||||
Dim LocalTemp2 As String = PathTemp & "CustomEvent\" & RawFileName.Replace(".json", ".xaml")
|
||||
Log("[Event] 转换网络资源：" & RelativeUrl & " -> " & LocalTemp1)
|
||||
Hint("正在获取资源，请稍候……")
|
||||
Try
|
||||
NetDownload(RelativeUrl, LocalTemp1)
|
||||
NetDownload(RelativeUrl.Replace(".json", ".xaml"), LocalTemp1.Replace(".json", ".xaml"))
|
||||
Catch ex As Exception
|
||||
Throw New Exception("下载指定的文件失败！" & vbCrLf &
|
||||
"注意，联网帮助页面须指向一个帮助 JSON 文件，并在同路径下包含相应 XAML 文件！" & vbCrLf &
|
||||
"例如：" & vbCrLf &
|
||||
" - https://www.baidu.com/test.json（填写这个路径）" & vbCrLf &
|
||||
" - https://www.baidu.com/test.xaml（同时也需要包含这个文件）", ex)
|
||||
End Try
|
||||
RelativeUrl = LocalTemp1
|
||||
End If
|
||||
RelativeUrl = RelativeUrl.Replace("/", "\").ToLower.TrimStart("\")
|
||||
|
||||
'确认实际路径
|
||||
Dim Location As String, WorkingDir As String = Path & "PCL"
|
||||
If RelativeUrl.Contains(":\") Then
|
||||
'绝对路径
|
||||
Location = RelativeUrl
|
||||
Log("[Control] 自定义事件中由绝对路径" & EventType & "：" & Location)
|
||||
ElseIf File.Exists(Path & "PCL\" & RelativeUrl) Then
|
||||
'相对 PCL 文件夹的路径
|
||||
Location = Path & "PCL\" & RelativeUrl
|
||||
Log("[Control] 自定义事件中由相对 PCL 文件夹的路径" & EventType & "：" & Location)
|
||||
ElseIf File.Exists(Path & "PCL\Help\" & RelativeUrl) Then
|
||||
'相对 PCL 本地帮助文件夹的路径
|
||||
Location = Path & "PCL\Help\" & RelativeUrl
|
||||
WorkingDir = Path & "PCL\Help\"
|
||||
Log("[Control] 自定义事件中由相对 PCL 本地帮助文件夹的路径" & EventType & "：" & Location)
|
||||
ElseIf EventType = "打开帮助" AndAlso File.Exists(PathTemp & "Help\" & RelativeUrl) Then
|
||||
'相对 PCL 自带帮助文件夹的路径
|
||||
Location = PathTemp & "Help\" & RelativeUrl
|
||||
WorkingDir = PathTemp & "Help\"
|
||||
Log("[Control] 自定义事件中由相对 PCL 自带帮助文件夹的路径" & EventType & "：" & Location)
|
||||
ElseIf EventType = "打开文件" Then
|
||||
'直接使用原有路径启动程序
|
||||
Location = RelativeUrl
|
||||
Log("[Control] 自定义事件中直接" & EventType & "：" & Location)
|
||||
Else
|
||||
'打开帮助，但是格式不对劲
|
||||
Throw New FileNotFoundException("未找到 EventData 指向的本地 xaml 文件：" & RelativeUrl, RelativeUrl)
|
||||
End If
|
||||
|
||||
Return {Location, WorkingDir}
|
||||
End Function
|
||||
|
||||
End Module
|
||||
@@ -0,0 +1,286 @@
|
||||
Public Module ModMusic
|
||||
|
||||
#Region "播放列表"
|
||||
|
||||
''' <summary>
|
||||
''' 接下来要播放的音乐文件路径。未初始化时为 Nothing。
|
||||
''' </summary>
|
||||
Public MusicToplayList As List(Of String) = Nothing
|
||||
''' <summary>
|
||||
''' 全部音乐文件路径。未初始化时为 Nothing。
|
||||
''' </summary>
|
||||
Public MusicAllList As List(Of String) = Nothing
|
||||
''' <summary>
|
||||
''' 初始化音乐播放列表。
|
||||
''' </summary>
|
||||
''' <param name="ForceReload">强制全部重新载入列表。</param>
|
||||
''' <param name="IgnoreFirst">在重载列表时避免让某项成为第一项。</param>
|
||||
Private Sub MusicListInit(ForceReload As Boolean, Optional IgnoreFirst As String = "")
|
||||
If ForceReload Then MusicAllList = Nothing
|
||||
Try
|
||||
'初始化全部可用音乐列表
|
||||
If MusicAllList Is Nothing Then
|
||||
MusicAllList = New List(Of String)
|
||||
Directory.CreateDirectory(Path & "PCL\Musics\")
|
||||
For Each File In My.Computer.FileSystem.GetFiles(Path & "PCL\Musics\", FileIO.SearchOption.SearchAllSubDirectories, "*.*")
|
||||
'文件夹可能会被加入 .ini 文件夹配置文件、一些乱七八糟的 .jpg 文件啥的
|
||||
Dim Extend As String = File.Split(".").Last.ToLower
|
||||
If Not (Extend = "ini" OrElse Extend = "jpg" OrElse Extend = "txt" OrElse Extend = "cfg" OrElse Extend = "png") Then
|
||||
MusicAllList.Add(File)
|
||||
End If
|
||||
Next
|
||||
End If
|
||||
'打乱顺序播放
|
||||
MusicToplayList = RandomChaos(New List(Of String)(MusicAllList))
|
||||
If Not IgnoreFirst = "" AndAlso Not MusicToplayList.Count = 0 AndAlso MusicToplayList(0) = IgnoreFirst Then
|
||||
'若需要避免成为第一项的为第一项，则将它放在最后
|
||||
MusicToplayList.RemoveAt(0)
|
||||
MusicToplayList.Add(IgnoreFirst)
|
||||
End If
|
||||
Catch ex As Exception
|
||||
Log(ex, "初始化音乐列表失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 获取下一首播放的音乐路径并将其从列表中移除。
|
||||
''' </summary>
|
||||
Private Function DequeueNextMusicAddress() As String
|
||||
'初始化，确保存在音乐
|
||||
If MusicAllList Is Nothing Then MusicListInit(False)
|
||||
If MusicAllList.Count = 0 Then Throw New Exception("在没有音乐时尝试获取音乐路径")
|
||||
'出列下一个音乐，如果出列结束则生成新列表
|
||||
DequeueNextMusicAddress = MusicToplayList(0)
|
||||
MusicToplayList.RemoveAt(0)
|
||||
If MusicToplayList.Count = 0 Then MusicListInit(False, DequeueNextMusicAddress)
|
||||
End Function
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "UI 控制"
|
||||
|
||||
''' <summary>
|
||||
''' 刷新背景音乐按钮 UI 与设置页 UI。
|
||||
''' </summary>
|
||||
Private Sub MusicRefreshUI()
|
||||
RunInUi(Sub()
|
||||
Try
|
||||
|
||||
If MusicAllList.Count = 0 Then
|
||||
'无背景音乐
|
||||
FrmMain.BtnExtraMusic.Show = False
|
||||
Else
|
||||
'有背景音乐
|
||||
FrmMain.BtnExtraMusic.Show = True
|
||||
|
||||
Dim ToolTipText As String = "正在播放：" & GetFileNameWithoutExtentionFromPath(MusicCurrent)
|
||||
If MusicState = MusicStates.Pause Then
|
||||
FrmMain.BtnExtraMusic.Logo = Logo.IconPlay
|
||||
FrmMain.BtnExtraMusic.LogoScale = 0.8
|
||||
If MusicAllList.Count > 1 Then ToolTipText += vbCrLf & "左键播放，右键播放下一曲。"
|
||||
Else
|
||||
FrmMain.BtnExtraMusic.Logo = Logo.IconMusic
|
||||
FrmMain.BtnExtraMusic.LogoScale = 1
|
||||
If MusicAllList.Count > 1 Then ToolTipText += vbCrLf & "左键暂停，右键播放下一曲。"
|
||||
End If
|
||||
FrmMain.BtnExtraMusic.ToolTip = ToolTipText
|
||||
ToolTipService.SetVerticalOffset(FrmMain.BtnExtraMusic, If(ToolTipText.Contains(vbLf), 10, 16))
|
||||
End If
|
||||
If FrmSetupUI IsNot Nothing Then FrmSetupUI.MusicRefreshUI()
|
||||
|
||||
Catch ex As Exception
|
||||
Log(ex, "刷新背景音乐 UI 失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub)
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 让音乐在暂停、播放间切换，并显示提示文本。
|
||||
''' </summary>
|
||||
Public Sub MusicControlPause()
|
||||
If MusicNAudio Is Nothing Then
|
||||
Hint("音乐播放尚未开始！", HintType.Critical)
|
||||
Else
|
||||
Select Case MusicState
|
||||
Case MusicStates.Pause
|
||||
MusicResume()
|
||||
Case MusicStates.Play
|
||||
MusicPause()
|
||||
Case Else
|
||||
Hint("音乐目前为停止状态！", HintType.Critical)
|
||||
End Select
|
||||
End If
|
||||
End Sub
|
||||
|
||||
''' <summary>
|
||||
''' 播放下一曲，并显示提示文本。
|
||||
''' </summary>
|
||||
Public Sub MusicControlNext()
|
||||
If MusicAllList.Count = 1 Then
|
||||
Hint("播放列表中仅有一首歌曲！")
|
||||
Else
|
||||
Dim Address As String = DequeueNextMusicAddress()
|
||||
MusicStartPlay(Address)
|
||||
Hint("正在播放：" & GetFileNameFromPath(Address), HintType.Finish)
|
||||
MusicRefreshUI()
|
||||
End If
|
||||
End Sub
|
||||
|
||||
#End Region
|
||||
|
||||
#Region "主状态控制"
|
||||
|
||||
''' <summary>
|
||||
''' 获取当前的音乐播放状态。
|
||||
''' </summary>
|
||||
Public ReadOnly Property MusicState As MusicStates
|
||||
Get
|
||||
If MusicNAudio Is Nothing Then Return MusicStates.Stop
|
||||
Select Case MusicNAudio.PlaybackState
|
||||
Case 0 'NAudio.Wave.PlaybackState.Stopped
|
||||
Return MusicStates.Stop
|
||||
Case 2 'NAudio.Wave.PlaybackState.Paused
|
||||
Return MusicStates.Pause
|
||||
Case Else
|
||||
Return MusicStates.Play
|
||||
End Select
|
||||
End Get
|
||||
End Property
|
||||
Public Enum MusicStates
|
||||
[Stop]
|
||||
Play
|
||||
Pause
|
||||
End Enum
|
||||
|
||||
'重载与开始
|
||||
|
||||
''' <summary>
|
||||
''' 重载播放列表并尝试开始播放背景音乐。
|
||||
''' </summary>
|
||||
''' <param name="ShowHint">是否显示刷新提示。</param>
|
||||
Public Sub MusicRefreshPlay(ShowHint As Boolean, Optional IsFirstLoad As Boolean = False)
|
||||
Try
|
||||
|
||||
MusicListInit(True)
|
||||
If MusicAllList.Count = 0 Then
|
||||
If MusicNAudio Is Nothing Then
|
||||
If ShowHint Then Hint("未检测到可用的背景音乐！", HintType.Critical)
|
||||
Else
|
||||
MusicNAudio = Nothing
|
||||
If ShowHint Then Hint("背景音乐已清除！", HintType.Finish)
|
||||
End If
|
||||
Else
|
||||
Dim Address As String = DequeueNextMusicAddress()
|
||||
Try
|
||||
MusicStartPlay(Address, IsFirstLoad)
|
||||
If ShowHint Then Hint("背景音乐已刷新：" & GetFileNameFromPath(Address), HintType.Finish, False)
|
||||
Catch
|
||||
End Try
|
||||
End If
|
||||
MusicRefreshUI()
|
||||
|
||||
Catch ex As Exception
|
||||
Log(ex, "刷新背景音乐播放失败", LogLevel.Feedback)
|
||||
End Try
|
||||
End Sub
|
||||
''' <summary>
|
||||
''' 开始播放音乐。
|
||||
''' </summary>
|
||||
Private Sub MusicStartPlay(Address As String, Optional IsFirstLoad As Boolean = False)
|
||||
Log("[Music] 播放开始：" & Address)
|
||||
RunInNewThread(Sub() MusicLoop(Address, IsFirstLoad), "Music", ThreadPriority.BelowNormal)
|
||||
End Sub
|
||||
|
||||
'播放与暂停
|
||||
|
||||
''' <summary>
|
||||
''' 暂停音乐播放，返回是否成功切换了状态。
|
||||
''' </summary>
|
||||
Public Function MusicPause() As Boolean
|
||||
If MusicState = MusicStates.Play Then
|
||||
RunInThread(Sub()
|
||||
MusicNAudio.Pause()
|
||||
MusicRefreshUI()
|
||||
Log("[Music] 已暂停播放")
|
||||
End Sub)
|
||||
Return True
|
||||
Else
|
||||
Return False
|
||||
End If
|
||||
End Function
|
||||
''' <summary>
|
||||
''' 继续音乐播放，返回是否成功切换了状态。
|
||||
''' </summary>
|
||||
Public Function MusicResume() As Boolean
|
||||
If MusicState = MusicStates.Pause Then
|
||||
RunInThread(Sub()
|
||||
MusicNAudio.Play()
|
||||
MusicRefreshUI()
|
||||
Log("[Music] 已恢复播放")
|
||||
End Sub)
|
||||
Return True
|
||||
Else
|
||||
Return False
|
||||
End If
|
||||
End Function
|
||||
|
||||
#End Region
|
||||
|
||||
''' <summary>
|
||||
''' 当前正在播放的 NAudio.Wave.WaveOut。
|
||||
''' </summary>
|
||||
Public MusicNAudio = Nothing
|
||||
''' <summary>
|
||||
''' 当前播放的音乐地址。
|
||||
''' </summary>
|
||||
Private MusicCurrent As String = ""
|
||||
|
||||
''' <summary>
|
||||
''' 在 MusicUuid 不变的前提下，持续播放某地址的音乐，且在播放结束后随机播放下一曲。
|
||||
''' </summary>
|
||||
Private Sub MusicLoop(Address As String, Optional IsFirstLoad As Boolean = False)
|
||||
MusicCurrent = Address
|
||||
Dim CurrentWave As NAudio.Wave.WaveOut = Nothing
|
||||
Dim Reader As NAudio.Wave.WaveStream = Nothing
|
||||
Try
|
||||
'开始播放
|
||||
CurrentWave = New NAudio.Wave.WaveOut()
|
||||
MusicNAudio = CurrentWave
|
||||
Reader = New NAudio.Wave.AudioFileReader(Address)
|
||||
CurrentWave.Init(Reader)
|
||||
CurrentWave.Play()
|
||||
'第一次打开的暂停
|
||||
If IsFirstLoad AndAlso Not Setup.Get("UiMusicAuto") Then CurrentWave.Pause()
|
||||
MusicRefreshUI()
|
||||
'停止条件：播放完毕或变化
|
||||
Dim PreviousVolume = 0
|
||||
While CurrentWave.Equals(MusicNAudio) AndAlso Not CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped
|
||||
If Setup.Get("UiMusicVolume") <> PreviousVolume Then
|
||||
'更新音量
|
||||
PreviousVolume = Setup.Get("UiMusicVolume")
|
||||
CurrentWave.Volume = PreviousVolume / 1000
|
||||
End If
|
||||
Thread.Sleep(50)
|
||||
End While
|
||||
'当前音乐已播放结束，继续下一曲
|
||||
If CurrentWave.PlaybackState = NAudio.Wave.PlaybackState.Stopped AndAlso MusicAllList.Count > 0 Then MusicStartPlay(DequeueNextMusicAddress)
|
||||
Catch ex As Exception
|
||||
If ex.Message.Contains("Got a frame at sample rate") OrElse ex.Message.Contains("does not support changes to") Then
|
||||
Hint("播放音乐失败（" & GetFileNameFromPath(Address) & "）：PCL2 不支持播放音频属性在中途发生变化的音乐", HintType.Critical)
|
||||
ElseIf Not (Address.ToLower.EndsWith(".wav") OrElse Address.ToLower.EndsWith(".mp3") OrElse Address.ToLower.EndsWith(".flac")) Then
|
||||
Hint("播放音乐失败（" & GetFileNameFromPath(Address) & "）：PCL2 可能不支持此音乐格式，请将格式转换为 .wav、.mp3 或 .flac 后再试", HintType.Critical)
|
||||
Else
|
||||
Log(ex, "播放音乐失败（" & GetFileNameFromPath(Address) & "）", LogLevel.Hint)
|
||||
End If
|
||||
Log(ex, "播放音乐失败（" & Address & "）", LogLevel.Developer)
|
||||
If MusicAllList.Count > 1 Then
|
||||
Thread.Sleep(1000)
|
||||
MusicStartPlay(DequeueNextMusicAddress)
|
||||
End If
|
||||
Finally
|
||||
If CurrentWave IsNot Nothing Then CurrentWave.Dispose()
|
||||
If Reader IsNot Nothing Then Reader.Dispose()
|
||||
MusicRefreshUI()
|
||||
End Try
|
||||
End Sub
|
||||
|
||||
End Module
|
||||
@@ -0,0 +1,59 @@
|
||||
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(ByVal 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(ByVal request As WebRequest, ByVal result As IAsyncResult) As WebResponse
|
||||
Dim response As WebResponse = MyBase.GetWebResponse(request, result)
|
||||
ReadCookies(response)
|
||||
Return response
|
||||
End Function
|
||||
|
||||
Protected Overrides Function GetWebResponse(ByVal request As WebRequest) As WebResponse
|
||||
Dim response As WebResponse = MyBase.GetWebResponse(request)
|
||||
ReadCookies(response)
|
||||
Return response
|
||||
End Function
|
||||
|
||||
Private Sub ReadCookies(ByVal 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
|
||||
+299
@@ -0,0 +1,299 @@
|
||||
Public NotInheritable Class SystemDropShadowChrome
|
||||
Inherits Decorator
|
||||
|
||||
'源码来源于：https://referencesource.microsoft.com/#PresentationFramework.Aero/parent/Shared/Microsoft/Windows/Themes/SystemDropShadowChrome.cs,6d9c27d92a8128c1
|
||||
|
||||
Public Shared ReadOnly ColorProperty As DependencyProperty = DependencyProperty.Register("Color", GetType(Color), GetType(SystemDropShadowChrome), New FrameworkPropertyMetadata(Color.FromArgb(&H71, &H0, &H0, &H0), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)))
|
||||
Public Property Color As Color
|
||||
Get
|
||||
Return CType(GetValue(ColorProperty), Color)
|
||||
End Get
|
||||
Set(value As Color)
|
||||
SetValue(ColorProperty, value)
|
||||
End Set
|
||||
End Property
|
||||
|
||||
Public Shared ReadOnly CornerRadiusProperty As DependencyProperty = DependencyProperty.Register("CornerRadius", GetType(CornerRadius), GetType(SystemDropShadowChrome), New FrameworkPropertyMetadata(New CornerRadius(), FrameworkPropertyMetadataOptions.AffectsRender, New PropertyChangedCallback(AddressOf ClearBrushes)), New ValidateValueCallback(AddressOf IsCornerRadiusValid))
|
||||
Public Property CornerRadius As CornerRadius
|
||||
Get
|
||||
Return CType(GetValue(CornerRadiusProperty), CornerRadius)
|
||||
End Get
|
||||
Set(value As CornerRadius)
|
||||
SetValue(CornerRadiusProperty, value)
|
||||
End Set
|
||||
End Property
|
||||
Private Shared Function IsCornerRadiusValid(value As Object) As Boolean
|
||||
Dim cr As CornerRadius = CType(value, CornerRadius)
|
||||
Return Not (cr.TopLeft < 0.0 OrElse cr.TopRight < 0.0 OrElse cr.BottomLeft < 0.0 OrElse cr.BottomRight < 0.0 OrElse Double.IsNaN(cr.TopLeft) OrElse Double.IsNaN(cr.TopRight) OrElse Double.IsNaN(cr.BottomLeft) OrElse Double.IsNaN(cr.BottomRight) OrElse Double.IsInfinity(cr.TopLeft) OrElse Double.IsInfinity(cr.TopRight) OrElse Double.IsInfinity(cr.BottomLeft) OrElse Double.IsInfinity(cr.BottomRight))
|
||||
End Function
|
||||
|
||||
Private Const ShadowDepth As Double = 5
|
||||
|
||||
Protected Overrides Sub OnRender(drawingContext As DrawingContext)
|
||||
Dim cornerRadius As CornerRadius = Me.CornerRadius
|
||||
Dim shadowBounds As New Rect(New Point(ShadowDepth, ShadowDepth), New Size(RenderSize.Width, RenderSize.Height))
|
||||
Dim color As Color = Me.Color
|
||||
|
||||
If shadowBounds.Width > 0 AndAlso shadowBounds.Height > 0 AndAlso color.A > 0 Then
|
||||
Dim centerWidth As Double = shadowBounds.Right - shadowBounds.Left - 2 * ShadowDepth
|
||||
Dim centerHeight As Double = shadowBounds.Bottom - shadowBounds.Top - 2 * ShadowDepth
|
||||
Dim maxRadius As Double = Math.Min(centerWidth * 0.5, centerHeight * 0.5)
|
||||
cornerRadius.TopLeft = Math.Min(cornerRadius.TopLeft, maxRadius)
|
||||
cornerRadius.TopRight = Math.Min(cornerRadius.TopRight, maxRadius)
|
||||
cornerRadius.BottomLeft = Math.Min(cornerRadius.BottomLeft, maxRadius)
|
||||
cornerRadius.BottomRight = Math.Min(cornerRadius.BottomRight, maxRadius)
|
||||
Dim brushes As Brush() = GetBrushes(color, cornerRadius)
|
||||
Dim centerTop As Double = shadowBounds.Top + ShadowDepth
|
||||
Dim centerLeft As Double = shadowBounds.Left + ShadowDepth
|
||||
Dim centerRight As Double = shadowBounds.Right - ShadowDepth
|
||||
Dim centerBottom As Double = shadowBounds.Bottom - ShadowDepth
|
||||
Dim guidelineSetX As Double() = New Double() {centerLeft, centerLeft + cornerRadius.TopLeft, centerRight - cornerRadius.TopRight, centerLeft + cornerRadius.BottomLeft, centerRight - cornerRadius.BottomRight, centerRight}
|
||||
Dim guidelineSetY As Double() = New Double() {centerTop, centerTop + cornerRadius.TopLeft, centerTop + cornerRadius.TopRight, centerBottom - cornerRadius.BottomLeft, centerBottom - cornerRadius.BottomRight, centerBottom}
|
||||
drawingContext.PushGuidelineSet(New GuidelineSet(guidelineSetX, guidelineSetY))
|
||||
cornerRadius.TopLeft += ShadowDepth
|
||||
cornerRadius.TopRight += ShadowDepth
|
||||
cornerRadius.BottomLeft += ShadowDepth
|
||||
cornerRadius.BottomRight += ShadowDepth
|
||||
Dim topLeft As New Rect(shadowBounds.Left, shadowBounds.Top, cornerRadius.TopLeft, cornerRadius.TopLeft)
|
||||
drawingContext.DrawRectangle(brushes(Placement.TopLeft), Nothing, topLeft)
|
||||
Dim topWidth As Double = guidelineSetX(2) - guidelineSetX(1)
|
||||
|
||||
If topWidth > 0 Then
|
||||
Dim top As New Rect(guidelineSetX(1), shadowBounds.Top, topWidth, ShadowDepth)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Top), Nothing, top)
|
||||
End If
|
||||
|
||||
Dim topRight As New Rect(guidelineSetX(2), shadowBounds.Top, cornerRadius.TopRight, cornerRadius.TopRight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.TopRight), Nothing, topRight)
|
||||
Dim leftHeight As Double = guidelineSetY(3) - guidelineSetY(1)
|
||||
|
||||
If leftHeight > 0 Then
|
||||
Dim left As New Rect(shadowBounds.Left, guidelineSetY(1), ShadowDepth, leftHeight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Left), Nothing, left)
|
||||
End If
|
||||
|
||||
Dim rightHeight As Double = guidelineSetY(4) - guidelineSetY(2)
|
||||
|
||||
If rightHeight > 0 Then
|
||||
Dim right As New Rect(guidelineSetX(5), guidelineSetY(2), ShadowDepth, rightHeight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Right), Nothing, right)
|
||||
End If
|
||||
|
||||
Dim bottomLeft As New Rect(shadowBounds.Left, guidelineSetY(3), cornerRadius.BottomLeft, cornerRadius.BottomLeft)
|
||||
drawingContext.DrawRectangle(brushes(Placement.BottomLeft), Nothing, bottomLeft)
|
||||
Dim bottomWidth As Double = guidelineSetX(4) - guidelineSetX(3)
|
||||
|
||||
If bottomWidth > 0 Then
|
||||
Dim bottom As New Rect(guidelineSetX(3), guidelineSetY(5), bottomWidth, ShadowDepth)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Bottom), Nothing, bottom)
|
||||
End If
|
||||
|
||||
Dim bottomRight As New Rect(guidelineSetX(4), guidelineSetY(4), cornerRadius.BottomRight, cornerRadius.BottomRight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.BottomRight), Nothing, bottomRight)
|
||||
|
||||
If cornerRadius.TopLeft = ShadowDepth AndAlso cornerRadius.TopLeft = cornerRadius.TopRight AndAlso cornerRadius.TopLeft = cornerRadius.BottomLeft AndAlso cornerRadius.TopLeft = cornerRadius.BottomRight Then
|
||||
Dim center As New Rect(guidelineSetX(0), guidelineSetY(0), centerWidth, centerHeight)
|
||||
drawingContext.DrawRectangle(brushes(Placement.Center), Nothing, center)
|
||||
Else
|
||||
Dim figure As New PathFigure()
|
||||
|
||||
If cornerRadius.TopLeft > ShadowDepth Then
|
||||
figure.StartPoint = New Point(guidelineSetX(1), guidelineSetY(0))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(1), guidelineSetY(1)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(1)), True))
|
||||
Else
|
||||
figure.StartPoint = New Point(guidelineSetX(0), guidelineSetY(0))
|
||||
End If
|
||||
|
||||
If cornerRadius.BottomLeft > ShadowDepth Then
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(3)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(3)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(3), guidelineSetY(5)), True))
|
||||
Else
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(0), guidelineSetY(5)), True))
|
||||
End If
|
||||
|
||||
If cornerRadius.BottomRight > ShadowDepth Then
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(5)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(4), guidelineSetY(4)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(4)), True))
|
||||
Else
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(5)), True))
|
||||
End If
|
||||
|
||||
If cornerRadius.TopRight > ShadowDepth Then
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(2)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(2)), True))
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(2), guidelineSetY(0)), True))
|
||||
Else
|
||||
figure.Segments.Add(New LineSegment(New Point(guidelineSetX(5), guidelineSetY(0)), True))
|
||||
End If
|
||||
|
||||
figure.IsClosed = True
|
||||
figure.Freeze()
|
||||
Dim geometry As New PathGeometry()
|
||||
geometry.Figures.Add(figure)
|
||||
geometry.Freeze()
|
||||
drawingContext.DrawGeometry(brushes(Placement.Center), Nothing, geometry)
|
||||
End If
|
||||
|
||||
drawingContext.Pop()
|
||||
End If
|
||||
End Sub
|
||||
|
||||
Private Enum Placement
|
||||
TopLeft = 0
|
||||
Top = 1
|
||||
TopRight = 2
|
||||
Left = 3
|
||||
Center = 4
|
||||
Right = 5
|
||||
BottomLeft = 6
|
||||
Bottom = 7
|
||||
BottomRight = 8
|
||||
End Enum
|
||||
Private Shared _commonBrushes As Brush()
|
||||
Private Shared _commonCornerRadius As CornerRadius
|
||||
Private Shared ReadOnly _resourceAccess As New Object()
|
||||
Private _brushes As Brush()
|
||||
|
||||
Private Shared Sub ClearBrushes(o As DependencyObject, e As DependencyPropertyChangedEventArgs)
|
||||
CType(o, SystemDropShadowChrome)._brushes = Nothing
|
||||
End Sub
|
||||
Private Shared Function CreateStops(c As Color, cornerRadius As Double) As GradientStopCollection
|
||||
Dim gradientScale As Double = 1 / (cornerRadius + ShadowDepth)
|
||||
Dim gsc As New GradientStopCollection From {
|
||||
New GradientStop(c, (0.5 + cornerRadius) * gradientScale)
|
||||
}
|
||||
Dim stopColor As Color = c
|
||||
stopColor.A = CByte(0.74336 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (1.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = CByte(0.38053 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (2.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = CByte(0.12389 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (3.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = CByte(0.02654 * c.A)
|
||||
gsc.Add(New GradientStop(stopColor, (4.5 + cornerRadius) * gradientScale))
|
||||
stopColor.A = 0
|
||||
gsc.Add(New GradientStop(stopColor, (5 + cornerRadius) * gradientScale))
|
||||
gsc.Freeze()
|
||||
Return gsc
|
||||
End Function
|
||||
Private Shared Function CreateBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
|
||||
Dim brushes As Brush() = New Brush(8) {}
|
||||
brushes(Placement.Center) = New SolidColorBrush(c)
|
||||
brushes(Placement.Center).Freeze()
|
||||
Dim sideStops As GradientStopCollection = CreateStops(c, 0)
|
||||
Dim top As New LinearGradientBrush(sideStops, New Point(0, 1), New Point(0, 0))
|
||||
top.Freeze()
|
||||
brushes(Placement.Top) = top
|
||||
Dim left As New LinearGradientBrush(sideStops, New Point(1, 0), New Point(0, 0))
|
||||
left.Freeze()
|
||||
brushes(Placement.Left) = left
|
||||
Dim right As New LinearGradientBrush(sideStops, New Point(0, 0), New Point(1, 0))
|
||||
right.Freeze()
|
||||
brushes(Placement.Right) = right
|
||||
Dim bottom As New LinearGradientBrush(sideStops, New Point(0, 0), New Point(0, 1))
|
||||
bottom.Freeze()
|
||||
brushes(Placement.Bottom) = bottom
|
||||
Dim topLeftStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.TopLeft = 0 Then
|
||||
topLeftStops = sideStops
|
||||
Else
|
||||
topLeftStops = CreateStops(c, cornerRadius.TopLeft)
|
||||
End If
|
||||
|
||||
Dim topLeft As New RadialGradientBrush(topLeftStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(1, 1),
|
||||
.GradientOrigin = New Point(1, 1)
|
||||
}
|
||||
topLeft.Freeze()
|
||||
brushes(Placement.TopLeft) = topLeft
|
||||
Dim topRightStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.TopRight = 0 Then
|
||||
topRightStops = sideStops
|
||||
ElseIf cornerRadius.TopRight = cornerRadius.TopLeft Then
|
||||
topRightStops = topLeftStops
|
||||
Else
|
||||
topRightStops = CreateStops(c, cornerRadius.TopRight)
|
||||
End If
|
||||
|
||||
Dim topRight As New RadialGradientBrush(topRightStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(0, 1),
|
||||
.GradientOrigin = New Point(0, 1)
|
||||
}
|
||||
topRight.Freeze()
|
||||
brushes(Placement.TopRight) = topRight
|
||||
Dim bottomLeftStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.BottomLeft = 0 Then
|
||||
bottomLeftStops = sideStops
|
||||
ElseIf cornerRadius.BottomLeft = cornerRadius.TopLeft Then
|
||||
bottomLeftStops = topLeftStops
|
||||
ElseIf cornerRadius.BottomLeft = cornerRadius.TopRight Then
|
||||
bottomLeftStops = topRightStops
|
||||
Else
|
||||
bottomLeftStops = CreateStops(c, cornerRadius.BottomLeft)
|
||||
End If
|
||||
|
||||
Dim bottomLeft As New RadialGradientBrush(bottomLeftStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(1, 0),
|
||||
.GradientOrigin = New Point(1, 0)
|
||||
}
|
||||
bottomLeft.Freeze()
|
||||
brushes(Placement.BottomLeft) = bottomLeft
|
||||
Dim bottomRightStops As GradientStopCollection
|
||||
|
||||
If cornerRadius.BottomRight = 0 Then
|
||||
bottomRightStops = sideStops
|
||||
ElseIf cornerRadius.BottomRight = cornerRadius.TopLeft Then
|
||||
bottomRightStops = topLeftStops
|
||||
ElseIf cornerRadius.BottomRight = cornerRadius.TopRight Then
|
||||
bottomRightStops = topRightStops
|
||||
ElseIf cornerRadius.BottomRight = cornerRadius.BottomLeft Then
|
||||
bottomRightStops = bottomLeftStops
|
||||
Else
|
||||
bottomRightStops = CreateStops(c, cornerRadius.BottomRight)
|
||||
End If
|
||||
|
||||
Dim bottomRight As New RadialGradientBrush(bottomRightStops) With {
|
||||
.RadiusX = 1,
|
||||
.RadiusY = 1,
|
||||
.Center = New Point(0, 0),
|
||||
.GradientOrigin = New Point(0, 0)
|
||||
}
|
||||
bottomRight.Freeze()
|
||||
brushes(Placement.BottomRight) = bottomRight
|
||||
Return brushes
|
||||
End Function
|
||||
Private Function GetBrushes(c As Color, cornerRadius As CornerRadius) As Brush()
|
||||
If _commonBrushes Is Nothing Then
|
||||
|
||||
SyncLock _resourceAccess
|
||||
|
||||
If _commonBrushes Is Nothing Then
|
||||
_commonBrushes = CreateBrushes(c, cornerRadius)
|
||||
_commonCornerRadius = cornerRadius
|
||||
End If
|
||||
End SyncLock
|
||||
End If
|
||||
|
||||
If c = CType(_commonBrushes(Placement.Center), SolidColorBrush).Color AndAlso cornerRadius = _commonCornerRadius Then
|
||||
_brushes = Nothing
|
||||
Return _commonBrushes
|
||||
ElseIf _brushes Is Nothing Then
|
||||
_brushes = CreateBrushes(c, cornerRadius)
|
||||
End If
|
||||
|
||||
Return _brushes
|
||||
End Function
|
||||
|
||||
End Class
|
||||
Reference in New Issue
Block a user