Public Class MyCfItem Public Uuid As Integer = GetUuid() #Region "Logo" 'Public CacheLogo As Boolean = True '是否缓存 Logo：通过下载量确定是否为默认页 Private _Logo As String = "" Public Property Logo As String Get Return _Logo End Get Set(value As String) If _Logo = value OrElse value Is Nothing Then Exit Property _Logo = value Dim FileAddress = PathTemp & "CFLogo\" & GetHash(_Logo) & ".png" Try If _Logo.ToLower.StartsWith("http") Then '网络图片 If File.Exists(FileAddress) Then PathLogo.Source = New MyBitmap(FileAddress) Else PathLogo.Source = New MyBitmap("pack://application:,,,/images/Icons/NoIcon.png") RunInNewThread(Sub() LogoLoader(FileAddress), "CurseForge Logo Loader " & Uuid & "#", ThreadPriority.BelowNormal) End If Else '位图 PathLogo.Source = New MyBitmap(_Logo) End If Catch ex As IOException Log(ex, "加载 CurseForge 工程图标时读取失败（" & FileAddress & "）") Catch ex As ArgumentException '考虑缓存的图片本身可能有误 Log(ex, "可视化 CurseForge 工程图标失败（" & FileAddress & "）") Try File.Delete(FileAddress) Log("[Download] 已清理损坏的 CurseForge 工程图标：" & FileAddress) Catch exx As Exception Log(exx, "清理损坏的 CurseForge 工程图标缓存失败（" & FileAddress & "）", LogLevel.Hint) End Try Catch ex As Exception Log(ex, "加载 CurseForge 工程图标失败（" & value & "）") End Try End Set End Property Private Sub LogoLoader(Address As String) Dim Retry As Boolean = False Dim DownloadEnd As String = GetUuid() RetryStart: Try NetDownload(_Logo, Address & DownloadEnd) RunInUiWait(Sub() Try '在地址更换时取消加载 If Not Address = PathTemp & "CFLogo\" & GetHash(_Logo) & ".png" Then Exit Sub '在完成正常加载后才保存缓存图片 PathLogo.Source = New MyBitmap(Address & DownloadEnd) Catch ex As Exception Log(ex, "读取 CurseForge 工程图标失败（" & Address & "）", LogLevel.Hint) End Try End Sub) If File.Exists(Address) Then File.Delete(Address & DownloadEnd) Else FileIO.FileSystem.MoveFile(Address & DownloadEnd, Address) End If Catch ex As Exception If Not Retry Then Retry = True GoTo RetryStart Else Log(ex, "下载 CurseForge 工程图标失败") End If End Try End Sub #End Region #Region "点击" '触发点击事件 Public Event Click(sender As Object, e As MouseButtonEventArgs) Private Sub Button_MouseUp(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonUp If IsMouseDown Then RaiseEvent Click(sender, e) If e.Handled Then Exit Sub Log("[Control] 按下 CurseForge 工程列表项：" & LabTitle.Text) End If End Sub '鼠标点击判定 Private IsMouseDown As Boolean = False Private Sub Button_MouseDown(sender As Object, e As MouseButtonEventArgs) Handles Me.PreviewMouseLeftButtonDown If IsMouseOver Then IsMouseDown = True End Sub Private Sub Button_MouseLeave(sender As Object, e As Object) Handles Me.MouseLeave, Me.PreviewMouseLeftButtonUp IsMouseDown = False End Sub #End Region #Region "后加载指向背景" Private _RectBack As Border = Nothing Public ReadOnly Property RectBack As Border Get If _RectBack Is Nothing Then Dim Rect As New Border With { .Name = "RectBack", .CornerRadius = New CornerRadius(3), .RenderTransform = New ScaleTransform(0.8, 0.8), .RenderTransformOrigin = New Point(0.5, 0.5), .BorderThickness = New Thickness(GetWPFSize(1)), .SnapsToDevicePixels = True, .IsHitTestVisible = False, .Opacity = 0 } Rect.SetResourceReference(Border.BackgroundProperty, "ColorBrush7") Rect.SetResourceReference(Border.BorderBrushProperty, "ColorBrush6") SetColumnSpan(Rect, 999) SetRowSpan(Rect, 999) Children.Insert(0, Rect) _RectBack = Rect ' End If Return _RectBack End Get End Property #End Region Private StateLast As String Public HasAnimation As Boolean = True Public Sub RefreshColor(sender As Object, e As EventArgs) Handles Me.MouseEnter, Me.MouseLeave, Me.MouseLeftButtonDown, Me.MouseLeftButtonUp If Not HasAnimation Then Exit Sub '判断当前颜色 Dim StateNew As String, Time As Integer If IsMouseOver Then If IsMouseDown Then StateNew = "MouseDown" Time = 120 Else StateNew = "MouseOver" Time = 120 End If Else StateNew = "Idle" Time = 180 End If If StateLast = StateNew Then Exit Sub StateLast = StateNew '触发颜色动画 If IsLoaded AndAlso AniControlEnabled = 0 Then '防止默认属性变更触发动画 '有动画 Dim Ani As New List(Of AniData) If IsMouseOver Then Ani.AddRange({ AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrush9"), Time), AaOpacity(RectBack, 1 - RectBack.Opacity, Time,, New AniEaseOutFluent) }) If IsMouseDown Then Ani.Add(AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent)) Else Ani.Add(AaScaleTransform(RectBack, 1 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time * 1.2,, New AniEaseOutFluent)) End If Else Ani.AddRange({ AaOpacity(RectBack, -RectBack.Opacity, Time), AaColor(RectBack, Border.BackgroundProperty, If(IsMouseDown, "ColorBrush6", "ColorBrush7"), Time), AaScaleTransform(RectBack, 0.996 - CType(RectBack.RenderTransform, ScaleTransform).ScaleX, Time,, New AniEaseOutFluent), AaScaleTransform(RectBack, -0.196, 1,,, True) }) End If AniStart(Ani, "CfItem Color " & Uuid) Else '无动画 AniStop("CfItem Color " & Uuid) If _RectBack IsNot Nothing Then RectBack.Opacity = 0 End If End Sub '指向时扩展描述 Private Sub LabInfo_MouseEnter(sender As Object, e As MouseEventArgs) Handles LabInfo.MouseEnter If IsTextTrimmed(LabInfo) Then ToolTipInfo.Content = LabInfo.Text ToolTipInfo.Width = LabInfo.ActualWidth + 25 LabInfo.ToolTip = ToolTipInfo Else LabInfo.ToolTip = Nothing End If End Sub Private Function IsTextTrimmed(textBlock As TextBlock) As Boolean Dim typeface As New Typeface(textBlock.FontFamily, textBlock.FontStyle, textBlock.FontWeight, textBlock.FontStretch) Dim formattedText As New FormattedText(textBlock.Text, Thread.CurrentThread.CurrentCulture, textBlock.FlowDirection, typeface, textBlock.FontSize, textBlock.Foreground, DPI) Return formattedText.Width > textBlock.ActualWidth End Function End Class