Imports System.Drawing.Imaging Imports System.Reflection Imports System.Security.Cryptography Imports System.Windows.Threading Imports Ionic.Zip Public Module Modules #Region "Review完成 | 声明" ''' ''' 程序的启动路径，以“\”结尾。 ''' ''' Public PATH As String = GetPathFromFullPath(System.Windows.Forms.Application.ExecutablePath) ''' ''' 随机数。 ''' ''' Public Rnd As New Random ''' ''' 正在拖动的滚动条。 ''' ''' Public DragingScroll As VScroll = Nothing ''' ''' 位图缓存。 ''' ''' Public BitmapCache As New Dictionary(Of String, MyBitmap) #End Region #Region "Review完成 | API" ''' ''' 获取指定窗口的句柄。返回查找到的第一个窗口的句柄。 ''' ''' 窗口的类名，使用Spy++可以查看。 ''' 窗口的标题。 ''' 查找到的第一个窗口的句柄。 ''' Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer ''' ''' 彻底释放某个句柄对应项目的资源。 ''' ''' 需要释放资源的句柄。 ''' ''' Public Declare Function DeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As IntPtr) As Boolean ''' ''' 根据句柄设置对应窗口的标题。 ''' ''' 窗口句柄。 ''' 要设置的标题。 ''' ''' Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Integer, ByVal lpString As String) As Integer ''' ''' 获取某个句柄对应的窗口的所属进程ID。 ''' ''' 窗口句柄。 ''' 获取到的ID。需要变量承载。 ''' ''' Public Declare Function GetWindowThreadProcessId Lib "user32" Alias "GetWindowThreadProcessId" (ByVal hwnd As Integer, ByVal lpdwProcessId As Integer) As Integer ''' ''' 设置某个句柄对应的窗口的属性。 ''' ''' 窗口句柄。 ''' 置顶标记。-1 为置顶，-2 为不置顶。 ''' 窗口的 X 坐标。 ''' 窗口的 Y 坐标。 ''' 窗口的宽度。 ''' 窗口的高度。 ''' 利用 Or 连接的参数。 ''' SWP_HIDEWINDOW：隐藏窗口。 ''' SWP_SHOWWINDOW：显示窗口。 ''' SWP_NOMOVE：维持当前位置（忽略 X 和 Y 参数）。 ''' SWP_NOSIZE：维持当前尺寸（忽略 cx 和 cy 参数）。 ''' ''' Public Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Integer, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer ''' ''' 播放 BGM。 ''' ''' 音乐文件的完整路径。 ''' 填写“0”。 ''' 填写“131072 Or 1 Or 8”。 ''' ''' Public Declare Function PlaySound Lib "winmm.dll" (ByVal lpszSoundName As String, ByVal hModule As Integer, ByVal dwFlags As Integer) As Integer ''' ''' 播放 MP3 相关项。 ''' ''' ''' ''' ''' ''' ''' Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrRetumString As String, ByVal uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer Public Const SWP_HIDEWINDOW As Integer = 8 * 16 '0x0080 Public Const SWP_SHOWWINDOW As Integer = 4 * 16 '0x0040 Public Const SWP_NOMOVE As Integer = 2 '0x0002 Public Const SWP_NOSIZE As Integer = 1 '0x0001 #End Region #Region "类" ''' ''' 支持浮点数与常见类型隐式转换的颜色。 ''' ''' Public Class MyColor '属性 Public A As Double = 0 Public R As Double = 0 Public G As Double = 0 Public B As Double = 0 '类型转换 Public Shared Widening Operator CType(ByVal col As Color) As MyColor Return New MyColor(col) End Operator Public Shared Widening Operator CType(ByVal conv As MyColor) As Color Return Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B)) End Operator Public Shared Widening Operator CType(ByVal conv As MyColor) As System.Drawing.Color Return System.Drawing.Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B)) End Operator Public Shared Widening Operator CType(ByVal bru As SolidColorBrush) As MyColor Return New MyColor(bru.Color) End Operator Public Shared Widening Operator CType(ByVal conv As MyColor) As SolidColorBrush Return New SolidColorBrush(Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B))) End Operator Public Shared Widening Operator CType(ByVal bru As Brush) As MyColor Return New MyColor(ColorConverter.ConvertFromString(bru.ToString)) End Operator Public Shared Widening Operator CType(ByVal conv As MyColor) As Brush Return New SolidColorBrush(Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B))) End Operator '颜色运算 Shared Operator +(ByVal a As MyColor, ByVal b As MyColor) As MyColor Return New MyColor With {.A = a.A + b.A, .B = a.B + b.B, .G = a.G + b.G, .R = a.R + b.R} End Operator Shared Operator -(ByVal a As MyColor, ByVal b As MyColor) As MyColor Return New MyColor With {.A = a.A - b.A, .B = a.B - b.B, .G = a.G - b.G, .R = a.R - b.R} End Operator Shared Operator *(ByVal a As MyColor, ByVal b As Double) As MyColor Return New MyColor With {.A = a.A * b, .B = a.B * b, .G = a.G * b, .R = a.R * b} End Operator Shared Operator /(ByVal a As MyColor, ByVal b As Double) As MyColor Return New MyColor With {.A = a.A / b, .B = a.B / b, .G = a.G / b, .R = a.R / b} End Operator '构造函数 Public Sub New() End Sub Public Sub New(ByVal col As Color) Me.A = col.A Me.R = col.R Me.G = col.G Me.B = col.B End Sub Public Sub New(ByVal newA As Double, ByVal col As Color) Me.A = newA Me.R = col.R Me.G = col.G Me.B = col.B End Sub Public Sub New(ByVal newR As Double, ByVal newG As Double, ByVal newB As Double) Me.A = 255 Me.R = newR Me.G = newG Me.B = newB End Sub Public Sub New(ByVal newA As Double, ByVal newR As Double, ByVal newG As Double, ByVal newB As Double) Me.A = newA Me.R = newR Me.G = newG Me.B = newB End Sub '复写 Public Shadows Function toString() As String Return "(" & A & "," & R & "," & G & "," & B & ")" End Function End Class Public Class AdvancedRect '属性 Public Property Width As Double = 0 Public Property Height As Double = 0 Public Property Left As Double = 0 Public Property Top As Double = 0 '构造函数 Public Sub New() End Sub Public Sub New(ByVal left As Double, ByVal top As Double, ByVal width As Double, ByVal height As Double) Me.Left = left Me.Top = top Me.Width = width Me.Height = height End Sub End Class '浮点矩形 Public Class FileSize Public Value As Integer = 0 '类型转换 Public Shared Widening Operator CType(ByVal value As Long) As FileSize Return New FileSize(value) End Operator Public Shared Widening Operator CType(ByVal value As FileSize) As Long Return value.Value End Operator Public Shared Widening Operator CType(ByVal value As Integer) As FileSize Return New FileSize(value) End Operator Public Shared Widening Operator CType(ByVal value As FileSize) As Integer Return value.Value End Operator '运算 Shared Operator +(ByVal a As FileSize, ByVal b As FileSize) As FileSize Return a.Value + b.Value End Operator Shared Operator -(ByVal a As FileSize, ByVal b As FileSize) As FileSize Return a.Value - b.Value End Operator Shared Operator *(ByVal a As FileSize, ByVal b As FileSize) As Integer Return a.Value * b.Value End Operator Shared Operator /(ByVal a As FileSize, ByVal b As FileSize) As Double Return MathRange(a.Value / b.Value, 0) End Operator Shared Operator =(ByVal a As FileSize, ByVal b As FileSize) As Boolean Return a.Value = b.Value End Operator Shared Operator <>(ByVal a As FileSize, ByVal b As FileSize) As Boolean Return Not a.Value = b.Value End Operator Shared Operator >(ByVal a As FileSize, ByVal b As FileSize) As Boolean Return a.Value > b.Value End Operator Shared Operator <(ByVal a As FileSize, ByVal b As FileSize) As Boolean Return a.Value < b.Value End Operator Shared Operator &(ByVal a As FileSize, ByVal b As String) As String Return a.ToString & b End Operator Shared Operator &(ByVal a As String, ByVal b As FileSize) As String Return a & b.ToString End Operator '构造函数 Public Sub New() End Sub Public Sub New(ByVal value As Integer) Me.Value = value End Sub '复写 Public Shadows Function ToString() As String Select Case Me.Value Case Is < 0 Return "未知" Case Is < 1024 Return Me.Value & "B" Case Is < 1024 ^ 2 Return Math.Round(Me.Value / 1024, 1) & "K" Case Is < 1024 ^ 3 Return Math.Round(Me.Value / 1024 ^ 2, 2) & "M" Case Else Return Math.Round(Me.Value / 1024 ^ 3, 2) & "G" End Select End Function End Class '文件大小 Public Class Time Private Property Value As Integer = 0 '类型转换 Public Shared Widening Operator CType(ByVal value As Integer) As Time Return New Time(value) End Operator Public Shared Widening Operator CType(ByVal value As Time) As Integer Return value.Value End Operator Public Shared Widening Operator CType(ByVal value As Int64) As Time Return New Time(value) End Operator Public Shared Widening Operator CType(ByVal value As Time) As Int64 Return value.Value End Operator '运算 Shared Operator +(ByVal a As Time, ByVal b As Time) As Time Return a.Value + b.Value End Operator Shared Operator -(ByVal a As Time, ByVal b As Time) As Time Return a.Value - b.Value End Operator Shared Operator *(ByVal a As Time, ByVal b As Time) As Integer Return a.Value * b.Value End Operator Shared Operator /(ByVal a As Time, ByVal b As Time) As Double Return MathRange(a.Value / b.Value, 0) End Operator Shared Operator =(ByVal a As Time, ByVal b As Time) As Boolean Return a.Value = b.Value End Operator Shared Operator <>(ByVal a As Time, ByVal b As Time) As Boolean Return Not a.Value = b.Value End Operator Shared Operator >(ByVal a As Time, ByVal b As Time) As Boolean Return a.Value > b.Value End Operator Shared Operator <(ByVal a As Time, ByVal b As Time) As Boolean Return a.Value < b.Value End Operator Shared Operator &(ByVal a As Time, ByVal b As String) As String Return a.toString & b End Operator Shared Operator &(ByVal a As String, ByVal b As Time) As String Return a & b.toString End Operator '构造函数 Public Sub New() End Sub Public Sub New(ByVal value As Integer) Me.Value = value End Sub '复写 Public Shadows Function toString() As String Dim left As Integer = Me.Value Dim a As Integer a = Math.Floor(left / 3600) toString = FillLength(a.ToString, "0", 2) left = left - a * 3600 a = Math.Floor(left / 60) toString = toString & ":" & FillLength(a.ToString, "0", 2) & ":" & FillLength((left - a * 60), "0", 2) End Function End Class '时间 #End Region #Region "控件" ''' ''' 获取控件或窗体的左边距。无视Alignment。 ''' ''' ''' ''' Public Function GetLeft(ByVal control) As Double GetLeft = 0 If control.GetType.BaseType.Name.Equals("Window") Then Return control.Left Else Select Case control.HorizontalAlignment Case HorizontalAlignment.Left, HorizontalAlignment.Stretch, HorizontalAlignment.Center Return control.Margin.Left Case HorizontalAlignment.Right Return CType(control.Parent, Object).ActualWidth - control.ActualWidth - control.Margin.Right 'Case HorizontalAlignment.Stretch ' Dim MaxWidth As Double = CType(control.Parent, Object).ActualWidth - control.Margin.Left - control.Margin.Right ' Return If(control.ActualWidth >= MaxWidth, control.Margin.Left, control.Margin.Left + (MaxWidth - control.ActualWidth) / 2) 'Case HorizontalAlignment.Center ' Dim CenterPos As Double = control.Margin.Left + (CType(control.Parent, Object).ActualWidth - control.Margin.Left - control.Margin.Right) / 2 ' Return CenterPos - control.ActualWidth / 2 End Select End If End Function ''' ''' 获取控件或窗体的顶边距。无视Alignment。 ''' ''' ''' ''' Public Function GetTop(ByVal control) As Double GetTop = 0 If control.GetType.BaseType.Name.Equals("Window") Then Return control.Top Else Select Case control.VerticalAlignment Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center Return control.Margin.Top Case VerticalAlignment.Bottom Return -control.Margin.Bottom 'Return CType(control.Parent, Object).ActualHeight - control.ActualHeight - control.Margin.Bottom 'Case VerticalAlignment.Stretch ' Dim MaxHeight As Double = CType(control.Parent, Object).ActualHeight - control.Margin.Top - control.Margin.Bottom ' Return If(control.ActualHeight >= MaxHeight, control.Margin.Top, control.Margin.Top + (MaxHeight - control.ActualHeight) / 2) 'Case VerticalAlignment.Center ' Dim CenterPos As Double = control.Margin.Top + (CType(control.Parent, Object).ActualHeight - control.Margin.Top - control.Margin.Bottom) / 2 ' Return CenterPos - control.ActualHeight / 2 End Select End If End Function ''' ''' 将一个IList中的内容添加到另外一个IList。 ''' ''' Public Sub IListCopy(ByVal list As IList, ByVal arr As IList) For Each item In arr list.Add(item) Next End Sub Public Sub SetLeft(ByVal control As Object, ByVal newValue As Double) If Double.IsNaN(newValue) Or Double.IsInfinity(newValue) Then Exit Sub '安全性检查 If control.GetType.BaseType.Name.Equals("Window") Then control.Left = newValue Else Select Case control.HorizontalAlignment Case HorizontalAlignment.Left, HorizontalAlignment.Stretch, HorizontalAlignment.Center control.Margin = New Thickness(newValue, control.Margin.Top, control.Margin.Right, control.Margin.Bottom) Case HorizontalAlignment.Right control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom) End Select End If End Sub '设置Left Public Sub SetTop(ByVal control As Object, ByVal newValue As Double) If Double.IsNaN(newValue) Or Double.IsInfinity(newValue) Then Exit Sub '安全性检查 If control.GetType.BaseType.Name.Equals("Window") Then control.Top = newValue Else Select Case control.VerticalAlignment Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom) Case VerticalAlignment.Bottom control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, -newValue) 'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, CType(control.Parent, Object).ActualHeight - control.ActualHeight - newValue) End Select End If End Sub '设置Top ''' ''' 拖动滚动条。 ''' ''' Public Sub ControlStartRun() Dim timer As New DispatcherTimer() timer.Interval = TimeSpan.FromMilliseconds(20) AddHandler timer.Tick, Sub() If IsNothing(DragingScroll) Then Exit Sub If Mouse.LeftButton = MouseButtonState.Pressed Then DragingScroll.Draging(Mouse.GetPosition(DragingScroll.btnDrag).Y) Else '鼠标放下 If Not DragingScroll.IsMouseOver Then DragingScroll.DragMouseLeave() DragingScroll = Nothing End If End Sub timer.Start() End Sub #End Region #Region "数学" ''' ''' 获取两数间的百分比。小数点精确到6位。 ''' ''' ''' Public Function MathPercent(ByVal ValueA As Double, ByVal ValueB As Double, ByVal Percent As Object) As Double Return Math.Round(ValueA * (1 - Percent) + ValueB * Percent, 6) '解决Double计算错误 End Function ''' ''' 获取两颜色间的百分比，根据RGB计算。小数点精确到6位。 ''' ''' ''' Public Function MathPercent(ByVal ValueA As MyColor, ByVal ValueB As MyColor, ByVal Percent As Object) As MyColor Return MathRound(ValueA * (1 - Percent) + ValueB * Percent, 6) '解决Double计算错误 End Function ''' ''' 检查一个数字是否正确（如检查无限、NaN等）。 ''' ''' 需要检查的数字。 ''' 是否正确。 ''' Public Function MathCheck(ByVal Num As Double) As Boolean Return Not (Double.IsInfinity(Num) Or Double.IsNaN(Num)) End Function '贝塞尔曲线计算 Public Function MathBezier(ByVal t As Double, ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double) As Double Dim a, b a = t Do b = 3 * a * ((1 / 3 + x1 - x2) * a * a + (x2 - 2 * x1) * a + x1) a = a + (t - b) * 0.5 Loop Until Math.Abs(b - t) < 0.01 '精度1% Return 3 * a * ((1 / 3 + y1 - y2) * a * a + (y2 - 2 * y1) * a + y1) End Function 'Byte合理化 Public Function MathByte(ByVal d As Double) As Byte If d < 0 Then d = 0 If d > 255 Then d = 255 Return Math.Round(d) End Function '提供扩展类支持的Round Public Function MathRound(ByVal col As MyColor, Optional ByVal w As Integer = 0) As MyColor Return New MyColor With {.A = Math.Round(col.A, w), .R = Math.Round(col.R, w), .G = Math.Round(col.G, w), .B = Math.Round(col.B, w)} End Function '把数值限定范围 Public Function MathRange(ByVal value As Double, ByVal min As Double, Optional ByVal max As Double = Double.MaxValue) As Double Return Math.Max(min, Math.Min(max, value)) End Function 'Byte类溢出处理 Public Function ByteOverflow(ByVal int As Integer) As Byte Dim Original = int Dim ReturnValue As Byte Try If int < 0 Then Do Until int >= 0 int = int + 256 Loop ReturnValue = int Else ReturnValue = int Mod 256 End If Return ReturnValue Catch ex As Exception ExShow(ex, "Byte 溢出处理出错：" & int) Return 0 End Try End Function #End Region #Region "文本" '填充长度 Public Function FillLength(ByVal str As String, ByVal code As String, ByVal length As Byte) If (Len(str) > length) Then Return Mid(str, 1, length) Return Mid(str.Replace(" ", "-").PadRight(length), str.Length + 1).Replace(" ", code) & str End Function '选择其一 Public Function OneOf(ByVal objects As Array) Return objects.GetValue(RandomInteger(0, objects.Length - 1)) End Function Public Function OneOf(ByVal objects As ArrayList) Return objects(RandomInteger(0, objects.Count - 1)) End Function '正则搜索 Public Function RegexSearch(ByVal str As String, ByVal regex As String) As ArrayList Try RegexSearch = New ArrayList Dim RegexSearchRes = (New RegularExpressions.Regex(regex)).Matches(str) If IsNothing(RegexSearchRes) Then Return RegexSearch For Each item As RegularExpressions.Match In RegexSearchRes RegexSearch.Add(item.Value) Next Catch Return New ArrayList End Try End Function '加密解密 Public Function SerAdd(ByVal str As String) As String Dim text As Byte() = Encoding.Unicode.GetBytes(str) '-----------------------------------------------1 Array.Reverse(text) '-----------------------------------------------2 Dim out(text.Length - 1) As Byte For i As Integer = 0 To text.Length - 4 Step 4 out(i) = text(i + 2) out(i + 1) = text(i + 1) out(i + 2) = text(i + 3) out(i + 3) = text(i) Next i If text.Length Mod 4 = 2 Then out(text.Length - 2) = text(text.Length - 1) out(text.Length - 1) = text(text.Length - 2) End If text = out '-----------------------------------------------3 ReDim out(text.Length - 1) For i As Integer = 0 To text.Length - 3 Step 3 out(i) = ByteOverflow(text(i + 2) + 12) out(i + 1) = ByteOverflow(text(i) - 85) out(i + 2) = ByteOverflow(text(i + 1) + 36) Next i Select Case text.Length Mod 3 Case 1 out(text.Length - 1) = ByteOverflow(text(text.Length - 1) - 52) Case 2 out(text.Length - 1) = ByteOverflow(text(text.Length - 1) + 16) out(text.Length - 2) = ByteOverflow(text(text.Length - 2) + 48) End Select text = out '-----------------------------------------------4 For i As Integer = 0 To text.Length - 1 text(i) = ByteOverflow(text(i) + i) Next i '-----------------------------------------------E SerAdd = "" For Each bt As Byte In text SerAdd = SerAdd & BitConverter.ToString({bt}) Next End Function Public Function SerRemove(ByVal str As String) As String Dim line1 As String, line2 As String line1 = "这就是解密函数……自己写的……很口胡很辣鸡……做一个加密只是为了防那些脑残熊孩子，既然都能搞到这函数了，那加密也没用，所以就别吐槽这辣鸡加密了吧233" line2 = "by 龙腾猫跃" Dim text(Len(str) / 2 - 1) As Byte For i As Integer = 0 To Len(str) - 2 Step 2 text(i / 2) = Byte.Parse(Mid(str, i + 1, 2), Globalization.NumberStyles.AllowHexSpecifier) Next '-----------------------------------------------4 For i As Integer = 0 To text.Length - 1 text(i) = ByteOverflow(text(i) - i) Next i '-----------------------------------------------3 Dim out(text.Length - 1) As Byte For i As Integer = 0 To text.Length - 3 Step 3 out(i) = ByteOverflow(text(i + 1) + 85) out(i + 1) = ByteOverflow(text(i + 2) - 36) out(i + 2) = ByteOverflow(text(i) - 12) Next i Select Case text.Length Mod 3 Case 1 out(text.Length - 1) = ByteOverflow(text(text.Length - 1) + 52) Case 2 out(text.Length - 1) = ByteOverflow(text(text.Length - 1) - 16) out(text.Length - 2) = ByteOverflow(text(text.Length - 2) - 48) End Select text = out '-----------------------------------------------2 ReDim out(text.Length - 1) For i As Integer = 0 To text.Length - 4 Step 4 out(i) = text(i + 3) out(i + 1) = text(i + 1) out(i + 2) = text(i) out(i + 3) = text(i + 2) Next i If text.Length Mod 4 = 2 Then out(text.Length - 2) = text(text.Length - 1) out(text.Length - 1) = text(text.Length - 2) End If text = out '-----------------------------------------------1 Array.Reverse(text) '-----------------------------------------------E SerRemove = Encoding.Unicode.GetString(text) End Function ''' ''' 从用户输入的字符串中提取数字 ''' ''' 用户输入的字符串 ''' 字符串中的数字，没有任何数字返回0 ''' Public Function GetDoubleFromString(ByVal str As String) As Double Dim regResult As ArrayList = RegexSearch(str, "(-?[0-9]\d*)?\.?[0-9]\d*") If regResult.Count = 0 Then Return 0 Else Return Val(regResult(0)) End If End Function '把Exception转为字符串 Public Function GetStringFromException(ByVal ex As Exception, Optional ByVal isLong As Boolean = False) As String '构造基本信息与InnerException信息 GetStringFromException = ex.Message.Replace(vbCrLf, "") If Not IsNothing(ex.InnerException) Then GetStringFromException = GetStringFromException & vbCrLf & "InnerException: " & ex.InnerException.Message.Replace(vbCrLf, "") If Not IsNothing(ex.InnerException.InnerException) Then GetStringFromException = GetStringFromException & vbCrLf & "InnerException: " & ex.InnerException.InnerException.Message.Replace(vbCrLf, "") End If End If '添加堆栈信息 If isLong Then GetStringFromException = GetStringFromException & vbCrLf For Each Stack As String In ex.StackTrace.Split(vbCrLf) If Stack.Contains("pcl.") Then GetStringFromException = GetStringFromException & vbCrLf & Stack Next End If '清除双回车 GetStringFromException = GetStringFromException.Replace(vbCrLf & vbCrLf, vbCrLf).Replace(vbCrLf & vbCrLf, vbCrLf) End Function #End Region #Region "Review完成 | 图片" ''' ''' 裁剪一个 BitmapSource。 ''' ''' 源图片。 Public Function CutBitmap(ByVal img As BitmapSource, ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer) As BitmapSource Try Return New CroppedBitmap(img, New Int32Rect(x, y, width, height)) Catch ex As Exception ExShow(ex, "裁剪图片失败", ErrorLevel.AllUsers) Return Nothing End Try End Function #End Region #Region "文件" ''' ''' 从应用资源释放文件。 ''' ''' 需要释放的文件在应用资源中的名称。 ''' 释放的路径，包含文件名。 ''' Public Sub OutputFileInResource(ByVal FileName As String, ByVal OutputPath As String, ByVal PassOnExists As Boolean) Try Dim Res = My.Resources.ResourceManager.GetObject(FileName) If IsNothing(Res) Then Throw New FileNotFoundException("没有找到名为" & FileName & "的资源") If PassOnExists And File.Exists(OutputPath) Then If GetFileSize(OutputPath) = Res.Length Then Exit Sub End If Directory.CreateDirectory(Mid(OutputPath, 1, OutputPath.LastIndexOf("\"))) Using OutputStream As New FileStream(OutputPath, FileMode.OpenOrCreate, FileAccess.Write) OutputStream.Write(Res, 0, Res.Length) OutputStream.Flush() End Using log("[System] 释放文件：" & FileName) Catch ex As Exception ExShow(ex, "释放文件失败", ErrorLevel.DebugOnly) Throw ex End Try End Sub ''' ''' 解压文件。 ''' ''' 需要解压的文件的完整路径。 ''' 解压的目标文件夹。 ''' 解压结束后（无论成功还是失败）执行的方法。 ''' Public Sub UnzipFile(ByVal SourceFile As String, ByVal UnzipDir As String, Optional ByVal RunThread As ParameterizedThreadStart = Nothing) Dim th As New Thread(Sub() Try Directory.CreateDirectory(UnzipDir) Using zip As New ZipFile(SourceFile) zip.ExtractAll(UnzipDir) End Using Catch ex As Exception ExShow(ex, "解压文件失败：" & SourceFile) End Try If Not IsNothing(RunThread) Then RunThread.Method.Invoke(Nothing, {Nothing}) End Sub) th.Start() End Sub '解压ZIP文件 ''' ''' 弹出选取文件对话框并且要求选取文件。 ''' ''' 要求的格式。如：“常用图片文件(*.png;*.jpeg)|*.png;*.jpg;*.jpeg”。 ''' 弹窗的标题。 ''' 选择的唯一文件的完整路径，如果没有选择可能为空字符串。 ''' Public Function SelectFile(ByVal FileFilter As String, ByVal Title As String) As String Using fileDialog As New Forms.OpenFileDialog fileDialog.AddExtension = True fileDialog.AutoUpgradeEnabled = True fileDialog.CheckFileExists = True fileDialog.Filter = FileFilter fileDialog.Multiselect = False fileDialog.Title = Title fileDialog.ShowDialog() Return fileDialog.FileName End Using End Function ''' ''' 弹出选取文件夹对话框并且要求选取文件夹。 ''' ''' 弹窗的标题。 ''' 选择的唯一文件夹的完整路径，如果没有选择可能为空字符串。 ''' Public Function SelectFolder(ByVal Title As String) As String Using folderDialog As New Forms.FolderBrowserDialog folderDialog.Description = Title folderDialog.ShowNewFolderButton = True folderDialog.ShowDialog() Return folderDialog.SelectedPath End Using End Function ''' ''' 从文件路径或者URL获取不包含文件名的路径。不包含路径将会抛出异常。 ''' ''' 文件路径，以标识符结尾。如果不包含文件名则必须以标识符结尾。 ''' ''' Public Function GetPathFromFullPath(ByVal FilePath As String) As String If Not (FilePath.Contains("\") Or FilePath.Contains("/")) Then Throw New FileFormatException("不包含路径：" & FilePath) If FilePath.EndsWith("\") Or FilePath.EndsWith("/") Then Return FilePath GetPathFromFullPath = Left(FilePath, FilePath.LastIndexOfAny({"\", "/"}) + 1) If GetPathFromFullPath = "" Then Throw New FileFormatException("不包含路径：" & FilePath) End Function ''' ''' 从文件路径或者URL获取不包含路径的文件名。不包含文件名将会抛出异常。 ''' ''' 文件路径。可以不完整。 ''' ''' Public Function GetFileNameFromPath(ByVal FilePath As String) As String If FilePath.EndsWith("\") Or FilePath.EndsWith("/") Then Throw New FileFormatException("不包含文件名：" & FilePath) If Not (FilePath.Contains("\") Or FilePath.Contains("/")) Then Return FilePath GetFileNameFromPath = Mid(FilePath, FilePath.LastIndexOfAny({"\", "/"}) + 2) If GetFileNameFromPath.Contains("\\") And GetFileNameFromPath.Contains("?") Then '包含网络参数 GetFileNameFromPath = Left(GetFileNameFromPath, FilePath.LastIndexOf("?")) End If If GetFileNameFromPath = "" Then Throw New FileFormatException("不包含文件名：" & FilePath) End Function ''' ''' 获取文件的版本信息。 ''' ''' 文件目录。 ''' ''' Public Function GetFileVersion(ByVal Path As String) As String Try Return Diagnostics.FileVersionInfo.GetVersionInfo(Path).FileVersion Catch ex As Exception ExShow(ex, "获取文件版本失败：" & Path, ErrorLevel.Slient) Return "" End Try End Function ''' ''' 获取一个文件夹下的所有文件的完整路径。 ''' ''' 源文件夹，不以“\”结尾。 ''' ''' Public Function GetFilesFromPath(ByVal SourcePath As String) As ArrayList GetFilesFromPath = New ArrayList GetFilesFromPath(SourcePath, GetFilesFromPath) End Function Private Function GetFilesFromPath(ByVal SourcePath As String, ByRef CurrentList As ArrayList) As ArrayList Try If Not Directory.Exists(SourcePath) Then Return New ArrayList '列举文件 For Each File As FileInfo In (New DirectoryInfo(SourcePath)).GetFiles CurrentList.Add(File.FullName) Next '列举目录 For Each Folder As DirectoryInfo In (New DirectoryInfo(SourcePath)).GetDirectories GetFilesFromPath(Folder.FullName, CurrentList) Next Catch ex As Exception ExShow(ex, "列举文件失败：" & SourcePath, ErrorLevel.Slient) End Try '返回 Return CurrentList End Function '获取文件大小（HTTP URL或文件路径） Public Function GetFileSize(ByVal Path As String, Optional ByRef FileMission As WebFile = Nothing) As Integer Try If Path.StartsWith("http") Then If MODE_OFFLINE Then Return 0 '获取网络文件大小 Dim Res As Net.WebRequest = Net.WebRequest.Create(Path) Dim Response As WebResponse = Res.GetResponse Dim Size As Integer = Response.ContentLength() If Not IsNothing(FileMission) Then '用Ref返回实际地址 If Not FileMission.AllWebAddress(0) = Response.ResponseUri.ToString Then If FileMission.RefreshName Then FileMission.LocalName = GetFileNameFromPath(Response.ResponseUri.ToString) FileMission.AllWebAddress(0) = Response.ResponseUri.ToString End If End If '释放资源 Response.Close() Res.Abort() Return Size Else If File.Exists(Path) Then Return New FileInfo(Path).Length Else Return 0 End If End If Catch ex As Exception ExShow(ex, "获取文件大小失败：" & Path, ErrorLevel.Slient) Return 0 End Try End Function '获取MD5 Public Function GetFileMD5(ByVal filepath As String) As String Try '网上抄的啊，自己改了改而已XD Dim result As String = "" Using fstream As New FileStream(filepath, FileMode.Open, FileAccess.Read) Dim dataToHash(fstream.Length - 1) As Byte fstream.Read(dataToHash, 0, fstream.Length) Dim hashvalue As Byte() = CType(CryptoConfig.CreateFromName("MD5"), HashAlgorithm).ComputeHash(dataToHash) Dim i As Double For i = 0 To hashvalue.Length - 1 result += FillLength(Hex(hashvalue(i)).ToLower, "0", 2) Next End Using Return result Catch ex As Exception ExShow(ex, "获取文件MD5失败：" & filepath, ErrorLevel.Slient) Return "" End Try End Function '读取文件 Public Function ReadFileToEnd(ByVal filePath As String, Optional ByVal encode As Encoding = Nothing, Optional ByVal isFullPath As Boolean = True) As String Try Dim actualPath As String = If(isFullPath, "", PATH) & filePath If File.Exists(actualPath) Then encode = If(IsNothing(encode), New UTF8Encoding(False), encode) Using reader As New StreamReader(actualPath, encode) ReadFileToEnd = reader.ReadToEnd End Using Else Return "" End If Catch ex As Exception ExShow(ex, "读取文件出错：" & filePath) Return "" End Try End Function '写入文件 Public Sub WriteFile(ByVal filePath As String, ByVal text As String, Optional ByVal add As Boolean = False, Optional ByVal encode As Encoding = Nothing, Optional ByVal isFullPath As Boolean = True) Try Dim actualpath As String = If(isFullPath, "", PATH) & filePath If Not File.Exists(actualpath) Then Directory.CreateDirectory(GetPathFromFullPath(actualpath)) File.Create(actualpath).Dispose() End If encode = If(IsNothing(encode), New UTF8Encoding(False), encode) Using writer As New StreamWriter(actualpath, add, encode) writer.Write(text) writer.Flush() End Using Catch ex As Exception ExShow(ex, "写入文件时出错：" & filePath) End Try End Sub Private Class IniCache Public content As String = "" Public cache As New Dictionary(Of String, String) End Class Private CacheIni As New Dictionary(Of String, IniCache) ''' ''' 获取Ini文件内容，这可能会使用到缓存。 ''' ''' 文件路径或简写。简写将会使用“PCL\文件名.ini”作为路径。 ''' ''' Private Function GetIni(ByVal FileName As String) As IniCache If Not FileName.Contains(":\") Then FileName = PATH & "PCL\" & FileName & ".ini" If CacheIni.ContainsKey(FileName) Then '返回缓存中的信息 Dim Cache As New IniCache CacheIni.TryGetValue(FileName, Cache) Return Cache '防止ByRef导致缓存变更 Else If File.Exists(FileName) Then '返回文件信息并且记入缓存 Dim Cache As String = (vbCrLf & ReadFileToEnd(FileName) & vbCrLf).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf).Replace(vbCrLf & vbCrLf, vbCrLf) Dim Ini As New IniCache With {.content = Cache} CacheIni.Add(FileName, Ini) Return Ini Else '返回空信息 Dim Ini As New IniCache With {.content = ""} CacheIni.Add(FileName, Ini) Return Ini End If End If End Function ''' ''' 读取Ini文件，这可能会使用到缓存。 ''' ''' 文件路径或简写。简写将会使用“PCL\文件名.ini”作为路径。 ''' 键。 ''' 没有找到键时返回的默认值。 Public Function ReadIni(ByVal FileName As String, ByVal Key As String, Optional ByVal DefaultValue As String = "") As String Try '获取目前文件 Dim NowIni As IniCache = GetIni(FileName) If IsNothing(NowIni) Then Return DefaultValue '使用缓存 If NowIni.cache.ContainsKey(Key) Then Return If(NowIni.cache(Key), DefaultValue) '新读取文件 If NowIni.content.Contains(vbCrLf & Key & ":") Then Dim Ret As String = Mid(NowIni.content, NowIni.content.IndexOf(vbCrLf & Key & ":") + 3) Ret = If(Ret.Contains(vbCrLf), Mid(Ret, 1, Ret.IndexOf(vbCrLf)), Ret).Replace(Key & ":", "") NowIni.cache.Add(Key, If(Ret = vbLf, "", Ret)) Return If(Ret = vbLf, "", Ret) Else Return DefaultValue End If Catch ex As Exception '读取失败 Return DefaultValue End Try End Function ''' ''' 写入ini文件，这会更新缓存。 ''' ''' 文件路径或简写。简写将会使用“PCL\文件名.ini”作为路径。 ''' 键。 ''' 值。 ''' Public Sub WriteIni(ByVal FileName As String, ByVal Key As String, ByVal Value As String) On Error Resume Next FileName = If(FileName.Contains(":\"), FileName, PATH & "PCL\" & FileName & ".ini") If IsNothing(Value) Then Value = "" Value = Value.Replace(vbCrLf, "") '创建文件夹 If Not Directory.Exists(GetPathFromFullPath(FileName)) Then Directory.CreateDirectory(GetPathFromFullPath(FileName)) '获取目前文件 Dim NowFile As String = GetIni(FileName).content '如果值一样就不处理 If NowFile.Contains(vbCrLf & Key & ":" & Value & vbCrLf) Then Exit Sub '处理文件 Dim FindResult As String = ReadIni(FileName, Key) If FindResult = "" And Not NowFile.Contains(vbCrLf & Key & ":") Then '不存在这个键 NowFile = NowFile & vbCrLf & Key & ":" & Value Else '存在这个键 NowFile = NowFile.Replace(vbCrLf & Key & ":" & FindResult & vbCrLf, vbCrLf & Key & ":" & Value & vbCrLf) End If WriteFile(FileName, NowFile) '刷新目前缓存 CacheIni(FileName).content = NowFile CacheIni(FileName).cache.Remove(Key) CacheIni(FileName).cache.Add(Key, Value) End Sub #End Region #Region "Review完成 | 网络" ''' ''' 获取网页源代码。 ''' ''' 网页的URL。 ''' 网页的编码，通常为UTF-8。 ''' ''' Public Function GetWebsiteCode(ByVal URL As String, ByVal Encode As Encoding) As String If MODE_OFFLINE Then Return "" '初始化 Dim req As HttpWebRequest = Nothing Dim res As HttpWebResponse = Nothing Dim strm As StreamReader = Nothing GetWebsiteCode = "" Try req = WebRequest.Create(URL) req.Timeout = 6000 res = req.GetResponse() strm = New StreamReader(res.GetResponseStream(), Encode) GetWebsiteCode = strm.ReadToEnd Catch ex As Exception If Not URL.Contains("https://sessionserver.mojang.com/session/minecraft/profile/") Then ExShow(ex, "获取网页源代码失败：" & URL) Finally '释放资源 If Not IsNothing(strm) Then strm.Dispose() If Not IsNothing(res) Then res.Close() If Not IsNothing(req) Then req.Abort() End Try End Function ''' ''' 从网络中直接下载文件。 ''' ''' 网络URL。 ''' 下载的本地地址。 ''' 是否下载成功。 ''' Public Function DownloadFile(ByVal URL As String, ByVal LocalFile As String) As Boolean If MODE_OFFLINE Then Return False '初始化 Try '建立目录 Directory.CreateDirectory(GetPathFromFullPath(LocalFile)) '尝试删除原文件 File.Delete(LocalFile) Catch ex As Exception ExShow(ex, "预处理文件失败：" & LocalFile) Return False End Try '下载 Using Client As New WebClient Try Client.DownloadFile(URL, LocalFile) log("[System] 直接下载文件成功：" & URL) Return True Catch ex As Exception ExShow(ex, "直接下载文件失败：" & URL) Return False End Try End Using End Function ''' ''' 进行Ping测试。这不会异步进行，失败将直接抛出异常。 ''' ''' 要进行Ping的IP。 ''' 最大响应时间，单位为毫秒。 ''' Ping用时，单位为毫秒。 ''' Public Function Ping(ByVal IP As String, ByVal MaxPingTime As Integer) As Integer If MODE_OFFLINE Then Throw New WebException("没有网络连接。") Using pin = New System.Net.NetworkInformation.Ping Return pin.Send(IP, MaxPingTime).RoundtripTime End Using End Function #End Region #Region "系统" ''' ''' 测试某段代码用时，单位为毫秒/次。 ''' ''' 需要测试的代码。 ''' ''' Public Function TimeTest(ByVal run As ThreadStart) As Double Dim StartTime As Long = My.Computer.Clock.TickCount Dim RunCount As Integer = 0 Do While True run.Invoke() RunCount = RunCount + 1 If My.Computer.Clock.TickCount - StartTime > 1000 Or RunCount > 100000 Then Exit Do Loop Return (My.Computer.Clock.TickCount - StartTime) / RunCount End Function ''' ''' 打开文件（等同于使用“运行”窗口）。 ''' ''' 文件名。可以为“notepad”等缩写。 ''' 运行参数。 ''' 是否等待该程序结束。默认为False。 ''' Public Sub Shell(ByVal FileName As String, Optional ByVal Arguments As String = "", Optional ByVal WaitForExit As Boolean = False) Try Dim Program As New Process Program.StartInfo.Arguments = Arguments Program.StartInfo.FileName = FileName Program.Start() If WaitForExit Then Program.WaitForExit() Catch ex As Exception ExShow(ex, "执行命令失败：" & FileName, ErrorLevel.AllUsers) End Try End Sub ''' ''' 返回一个枚举对应的字符串。 ''' ''' 一个已经实例化的枚举类型。 ''' ''' Public Function GetStringFromEnum(ByVal EnumData As Object) As String Return [Enum].GetName(EnumData.GetType, EnumData) End Function ''' ''' 从指定的枚举中查找某字符串对应的枚举项。 ''' ''' 源枚举。 ''' 对应枚举一项的字符串。 ''' ''' Public Function GetEnumFromString(ByVal EnumData As Object, ByVal Value As String) Return [Enum].Parse(EnumData.GetType, Value) End Function ''' ''' 获取格式类似于“11:08:52.037”的当前时间的字符串。 ''' ''' ''' Public Function GetTime() As String Return Date.Now.ToLongTimeString & "." & FillLength(Date.Now.Millisecond, "0", 3) End Function ''' ''' 数组去重。 ''' ''' ''' ''' Public Function ArrayNoDouble(ByVal array As Array) As ArrayList Dim ResultArray As New ArrayList For i = 0 To UBound(array) For ii = i + 1 To UBound(array) If array(i).Equals(array(ii)) Then GoTo NextElement Next ResultArray.Add(array(i)) NextElement: Next i Return ResultArray End Function ''' ''' 将数组从大到小排序。 ''' ''' 纯数字的ArrayList。 ''' Public Sub ArrayBigToSmall(ByRef Array As ArrayList) If Array.Count < 2 Then Exit Sub For i = 1 To Array.Count - 1 If Array(i) > Array(i - 1) Then Dim c = Array(i - 1) Array(i - 1) = Array(i) Array(i) = c If i >= 2 Then i = i - 2 End If Next i End Sub ''' ''' 强制将一个支持IList接口的对象转换为任意格式的一维数组。 ''' ''' 转换后的数组类型。 ''' ''' ''' Public Function ArrayConventer(Of T, B As IList)(ByVal Source As B) As T() Dim Re(Source.Count - 1) As T For i = 0 To Source.Count - 1 Re(i) = Source(i) Next Return Re End Function ''' ''' 检查是否拥有某一文件夹的读取权限。如果文件夹不存在，会返回 False。 ''' ''' 检查目录。 Public Function CheckDirectoryPermission(ByVal Path As String) As Boolean Try If Path = "" Then Return False If Not Directory.Exists(Path) Then Return False Dim folderCheck As New DirectoryInfo(Path) folderCheck.EnumerateFiles() Return True Catch Return False End Try End Function ''' ''' 获取程序启动参数。 ''' ''' 参数名。 ''' 默认值。 ''' ''' Public Function GetProgramArgument(ByVal Name As String, Optional ByVal DefaultValue As Object = "") Dim AllArguments() As String = Microsoft.VisualBasic.Command.Split(" ") For i = 0 To AllArguments.Length - 1 If AllArguments(i) = "-" & Name Then If AllArguments.Length = i + 1 Then Return True If AllArguments(i + 1).StartsWith("-") Then Return True Return AllArguments(i + 1) End If Next Return DefaultValue End Function ''' ''' 获取Json对象。 ''' ''' ''' ''' Public Function ReadJson(ByVal Text As String) As JObject Try Return CType(Newtonsoft.Json.JsonConvert.DeserializeObject(Text), JObject) Catch ex As Exception ExShow(ex, "Json读取失败：" & Left(Text, 30)) Throw New FileFormatException("错误的 Json：" & GetStringFromException(ex, True)) End Try End Function '执行命令行函数 'Public Function RunCMD(ByVal Commands As String, ByVal Wait As Boolean) As String ' Dim myProcess As New Process() ' Dim myProcessStartInfo As New ProcessStartInfo("cmd.exe") ' myProcessStartInfo.UseShellExecute = False ' myProcessStartInfo.RedirectStandardOutput = True ' myProcessStartInfo.CreateNoWindow = True ' myProcessStartInfo.Arguments = "/c """ & Commands & """" ' myProcess.StartInfo = myProcessStartInfo ' myProcess.Start() ' If Wait Then ' myProcess.WaitForExit() ' Dim myStreamReader As IO.StreamReader = myProcess.StandardOutput ' Dim myString As String = myStreamReader.ReadToEnd() ' myProcess.Close() ' myProcess.Dispose() ' Return myString ' Else ' Return "" ' End If 'End Function '注册表IO Public Function ReadReg(ByVal Key As String, Optional ByVal DefaultValue As String = "") As String Try Dim parentKey As Microsoft.Win32.RegistryKey, softKey As Microsoft.Win32.RegistryKey parentKey = My.Computer.Registry.CurrentUser softKey = parentKey.OpenSubKey("Software\" & APPLICATION_SHORT_NAME, True) If softKey Is Nothing Then ReadReg = DefaultValue '不存在则返回默认值 Else Dim readValue As New System.Text.StringBuilder readValue.AppendLine(softKey.GetValue(Key)) Dim value = readValue.ToString.Replace(vbCrLf, "") '去除莫名的回车 Return If(value = "", DefaultValue, value) '错误则返回默认值 End If Catch ex As Exception ExShow(ex, "读取注册表出错：" & Key, ErrorLevel.Slient) Return DefaultValue End Try End Function Public Sub WriteReg(ByVal Key As String, ByVal Value As String, Optional ByVal ShowException As Boolean = False) Try Dim parentKey As Microsoft.Win32.RegistryKey, softKey As Microsoft.Win32.RegistryKey parentKey = My.Computer.Registry.CurrentUser softKey = parentKey.OpenSubKey("Software\" & APPLICATION_SHORT_NAME, True) If softKey Is Nothing Then softKey = parentKey.CreateSubKey("Software\" & APPLICATION_SHORT_NAME) '如果不存在就创建 softKey.SetValue(Key, Value) Catch ex As Exception ExShow(ex, "写入注册表出错：" & Key, If(ShowException, modMain.ErrorLevel.DebugOnly, modMain.ErrorLevel.Slient)) If ShowException Then Throw '如果显示错误就丢一个 End Try End Sub Private UUID As Integer = 0 ''' ''' 获取一个全程序内不会重复的数字（伪UUID）。 ''' ''' UUID，一个大于0的有序整数。 ''' Public Function GetUUID() As Integer UUID = UUID + 1 Return UUID End Function #End Region #Region "Review完成 | 窗体" ''' ''' 等待显示的弹窗。 ''' ''' Public WaitingMyMsgbox As ArrayList = If(IsNothing(WaitingMyMsgbox), New ArrayList, WaitingMyMsgbox) ''' ''' 显示弹窗。 ''' Public Function MyMsgbox(ByVal Converter As MyMsgboxConverter) As Integer Try '存入等待列表 If Thread.CurrentThread.IsBackground Or Not Thread.CurrentThread.GetApartmentState = ApartmentState.STA Or Not AniRunning Then If IsNothing(WaitingMyMsgbox) Then WaitingMyMsgbox = New ArrayList '初始化 WaitingMyMsgbox.Add(Converter) '返回值 If Converter.IsWaitExit Then Do While Converter.ReturnCode = 0 Thread.Sleep(50) Loop Return Converter.ReturnCode Else Return 0 End If End If '在主线程，显示窗体 Dim MsgBox As New MetroMsgbox(Converter) With {.Owner = frmMain, .Width = MAINFORM_WIDTH - 20, .Height = MAINFORM_HEIGHT - 20, .Left = (My.Computer.Screen.WorkingArea.Width - MAINFORM_WIDTH) / 2 + 10, .Top = (My.Computer.Screen.WorkingArea.Height - MAINFORM_HEIGHT) / 2 + 10} If Converter.IsWaitExit Then MsgBox.ShowDialog() Return Converter.ReturnCode Else MsgBox.Show() Return 0 End If Catch ex As Exception ExShow(ex, "显示弹窗失败：" & Converter.Title, ErrorLevel.MsgboxAndFeedback) Return 0 End Try End Function ''' ''' 显示弹窗。 ''' ''' 弹窗的标题。 ''' 弹窗的内容。 ''' 显示的第一个按钮，默认为“确定”。 ''' 显示的第二个按钮，默认为空。 ''' 显示的第三个按钮，默认为空。 ''' 是否为警告弹窗，若为 True，第一个按钮会显示为红色。 ''' 是否等待弹窗关闭。若为 True，将会返回从 1 开始的点击的按钮编号，否则返回 0。 ''' ''' Public Function MyMsgbox(ByVal Caption As String, Optional ByVal Title As String = APPLICATION_FULL_NAME, Optional ByVal Button1 As String = "确定", Optional ByVal Button2 As String = "", Optional ByVal Button3 As String = "", Optional ByVal IsWarn As Boolean = False, Optional ByVal IsWaitExit As Boolean = True) As Integer Dim NewMsgBoxConverter As New MyMsgboxConverter With {.Button1 = Button1, .Button2 = Button2, .Button3 = Button3, .Caption = Caption, .IsWarn = IsWarn, .Title = Title, .IsWaitExit = IsWaitExit} Return MyMsgbox(NewMsgBoxConverter) End Function ''' ''' 存储弹窗信息的转换器。 ''' ''' Public Class MyMsgboxConverter Public Title As String Public Caption As String = "" Public Button1 As String = "确定" Public Button2 As String = "" Public Button3 As String = "" Public IsWarn As Boolean = False Public IsWaitExit As Boolean = True ''' ''' 弹窗是否已经关闭。 ''' ''' Public IsExited As Boolean = False ''' ''' 点击的按钮编号，从 1 开始。 ''' ''' Public ReturnCode As Integer = 0 End Class 'Public Function MyMsgbox(ByVal title As String, ByVal page As Grid, Optional ByVal caption As String = "", Optional ByVal btn1 As String = "确定", Optional ByVal btn2 As String = "", Optional ByVal btn3 As String = "", Optional ByVal wait As Boolean = False) As Object ' Dim wind As New MetroMsgbox With {.Owner = frmMain, .Width = MAINFORM_WIDTH - 20, .Height = MAINFORM_HEIGHT - 20, .Left = (My.Computer.Screen.WorkingArea.Width - MAINFORM_WIDTH) / 2 + 10, .Top = (My.Computer.Screen.WorkingArea.Height - MAINFORM_HEIGHT) / 2 + 10} ' wind.labTitle.Text = title ' wind.panCaption.Child = page ' wind.btn1.Text = btn1 ' wind.btn2.Text = btn2 ' wind.btn3.Text = btn3 ' wind.btn2.Visibility = If(btn2 = "", Visibility.Collapsed, Visibility.Visible) ' wind.btn3.Visibility = If(btn3 = "", Visibility.Collapsed, Visibility.Visible) ' msgboxCallback = 0 ' If wait Then ' wind.Show() ' Return wind ' Else ' wind.ShowDialog() ' Return msgboxCallback ' End If 'End Function ''' 设置 WebBrowser 静默，即是否不产生弹窗。 ''' 需要改变的 WebBrowser。 ''' 是否开启静默模式。 Public Sub SetWebBrowserSilent(ByVal WebBrowser As WebBrowser, ByVal IsSilent As Boolean) Try Dim fi As FieldInfo = WebBrowser.GetType.GetField("_axIWebBrowser2", BindingFlags.Instance Or BindingFlags.NonPublic) If Not IsNothing(fi) Then Dim browser = fi.GetValue(WebBrowser) If Not IsNothing(browser) Then browser.GetType().InvokeMember("Silent", BindingFlags.SetProperty, Nothing, browser, {IsSilent}) End If End If Catch ex As Exception ExShow(ex, "设置浏览器失败", ErrorLevel.AllUsers) End Try End Sub #End Region #Region "随机" '打乱数组 Public Function RandomArray(ByVal array As ArrayList) As ArrayList RandomArray = New ArrayList Do While array.Count > 0 Dim i As Integer = RandomInteger(0, array.Count - 1) RandomArray.Add(array(i)) array.RemoveAt(i) Loop End Function '获取随机整数 Public Function RandomInteger(ByVal min As Integer, ByVal max As Integer) As Integer Return Math.Round((max - min) * Rnd.NextDouble) + min End Function #End Region #Region "Review 完成 | 音乐" ''' ''' 播放音乐。 ''' ''' 音乐文件完整路径。 ''' Public Sub PlayBgm(ByVal FilePath As String, ByVal IsStop As Boolean, Optional ByVal IsShowHint As Boolean = False) Try If IsStop Then '停止 log("[System] 停止播放音乐：" & FilePath) mciSendString("close " & FilePath, 0, 0, 0) PlaySound(Nothing, Nothing, Nothing) Else '播放 log("[System] 播放音乐：" & FilePath) mciSendString("open " & FilePath, "", 0, 0) Dim code = mciSendString("play " & FilePath & " repeat", "", 0, 0) If code = 259 Then PlaySound(FilePath, 0, 131072 Or 1 Or 8) '换用 PlaySound 播放不支持循环的 .wav 'If IsShowHint Then ShowHint("该音乐不支持循环播放，音乐将在播放完一次后停止。") 'code = mciSendString("play " & FilePath, "", 0, 0) ElseIf code = 277 Then If IsShowHint Then MyMsgbox("无效的音乐文件。" & vbCrLf & "PCL 不支持部分 MP3 的播放，请尝试更换文件。目前已知网易云下载的 MP3 会出现此问题，原因不明。", "播放音乐失败") ElseIf Not code = 0 Then Throw New Exception(code) End If End If 'PlaySound(FilePath, 0, 131072 Or 1 Or 8) Catch ex As Exception ExShow(ex, "播放音乐失败", ErrorLevel.AllUsers) End Try End Sub #End Region End Module '基础函数 'Module ComputerInfo ' '声明 ' 'Private cpuCounter As New PerformanceCounter("Processor", "% Processor Time", "_Total") ' 'Private downloadCounter As New PerformanceCounter("Network Interface", "Bytes Received/sec", New PerformanceCounterCategory("Network Interface").GetInstanceNames()(0)) ' 'Private uploadCounter As New PerformanceCounter("Network Interface", "Bytes Sent/sec", New PerformanceCounterCategory("Network Interface").GetInstanceNames()(0)) ' Private pcInfo As New Microsoft.VisualBasic.Devices.ComputerInfo ' '启动代码 ' Public Sub InfoStartRun(ByVal time As Integer) ' Dim timer As New DispatcherTimer() ' timer.Interval = TimeSpan.FromMilliseconds(time) ' AddHandler timer.Tick, AddressOf InfoTimer ' timer.Start() ' End Sub ' '每次执行的代码 ' Private Sub InfoTimer() ' '防止断网时获取错误 ' On Error Resume Next ' infoDownloadSpeed = 0 ' infoUploadSpeed = 0 ' '获取值 ' 'infoCpuPercent = cpuCounter.NextValue ' 'infoDownloadSpeed = downloadCounter.NextValue / 1024 ' 'infoUploadSpeed = uploadCounter.NextValue / 1024 ' End Sub ' '获取信息 ' Public infoCpuPercent As Integer = 0 'CPU使用率 ' Public infoDownloadSpeed As Integer = 0 '下载速度(KB) ' Public infoUploadSpeed As Integer = 0 '上传速度(KB) ' Public Function infoNetworkSpeed() As Integer ' Return infoDownloadSpeed + infoUploadSpeed ' End Function '网络速度(KB) ' Public Function infoRamPercent() As Integer ' Return (pcInfo.TotalPhysicalMemory - pcInfo.AvailablePhysicalMemory) / pcInfo.TotalPhysicalMemory * 100 ' End Function '内存使用率 ' Public Function infoRamUsed() As Integer ' Return (pcInfo.TotalPhysicalMemory - pcInfo.AvailablePhysicalMemory) / 1024 / 1024 ' End Function '内存使用量(MB) ' Public Function infoRamTotal() As Integer ' Return pcInfo.TotalPhysicalMemory / 1024 / 1024 ' End Function '内存总量(MB) ' Public Function infoRamAvailable() As Integer ' Return pcInfo.AvailablePhysicalMemory / 1024 / 1024 ' End Function '内存可用量(MB) 'End Module '电脑信息获取 Public Module MyAnimationer #Region "声明" ''' ''' 动画组列表。（组名→ArrayList） ''' ''' Private AniGroups As New Dictionary(Of String, ArrayList) ''' ''' 上一次记刻的时间。 ''' ''' Public AniLastTick As Integer ''' ''' 动画执行是否开启。 ''' ''' Public AniRunning As Boolean = False #End Region #Region "类与枚举" ''' ''' 单个动画对象。 ''' ''' Public Structure Animation ''' ''' 动画种类。 ''' ''' Public AniType As AniType ''' ''' 动画副种类。 ''' ''' Public AniSubType As AniSubType ''' ''' 动画总长度。 ''' ''' Public TotalLength As Integer ''' ''' 已经执行的动画长度。如果为负数则为延迟。 ''' ''' Public FinishLength As Integer ''' ''' 已经完成的百分比。 ''' ''' Public Percent As Double ''' ''' 是否为“以后”。 ''' ''' Public After As Boolean ''' ''' 插值器类型。 ''' ''' Public Ease As AniEase ''' ''' 动画对象。 ''' ''' Public Obj As Object ''' ''' 动画值。 ''' ''' Public Value As Object ''' ''' 上次执行时的动画值。 ''' ''' Public Last As Object Public Overrides Function ToString() As String Return GetStringFromEnum(AniType) & " | " & FinishLength & "/" & TotalLength & "(" & Math.Round(Percent * 100) & "%) | " & Obj.name & "(" & Obj.GetType.Name & ")" End Function End Structure ''' ''' 动画基础种类。 ''' ''' Public Enum AniType As Byte ''' ''' 单个Double的动画，包括位置、长宽、透明度等。这需要附属类型。 ''' ''' DoubleAnimation = 0 ''' ''' 颜色属性的动画。这需要附属类型。 ''' ''' ColorAnimation = 1 ''' ''' 缩放控件大小。比起4个DoubleAnimation来说效率更高。 ''' ''' Scale = 2 ''' ''' 文字一个个出现。 ''' ''' TextAppear = 3 ''' ''' 执行代码。 ''' ''' Code = 4 ''' ''' 执行按照规定格式书写的伪代码。比起Code来说这有很大的局限性，但效率更高。 ''' ''' CodeEvent = 5 ''' ''' 以 WPF 方式缩放控件。 ''' ScaleTransform = 6 ''' ''' 以 WPF 方式旋转控件。 ''' RotateTransform = 7 End Enum ''' ''' 动画扩展种类。 ''' ''' Public Enum AniSubType As Byte X = 0 Y = 1 Width = 2 Height = 3 Opacity = 4 Value = 5 Radius = 10 BorderThickness = 11 Background = 6 BorderBrush = 7 Foreground = 8 Stroke = 9 End Enum #End Region #Region "种类" 'DoubleAnimation ''' ''' 移动X轴的动画。 ''' ''' 动画的对象。 ''' 进行移动的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaX(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.X, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 移动Y轴的动画。 ''' ''' 动画的对象。 ''' 进行移动的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaY(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.Y, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 改变宽度的动画。 ''' ''' 动画的对象。 ''' 宽度改变的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaWidth(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.Width, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 改变高度的动画。 ''' ''' 动画的对象。 ''' 高度改变的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaHeight(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.Height, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 改变透明度的动画。 ''' ''' 动画的对象。 ''' 透明度改变的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaOpacity(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.Opacity, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 改变对象的Value属性的动画。 ''' ''' 动画的对象。 ''' Value属性改变的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaValue(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.Value, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 改变对象的Radius属性的动画。 ''' ''' 动画的对象。 ''' Radius属性改变的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaRadius(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.Radius, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function ''' ''' 改变对象的BorderThickness属性的动画。 ''' ''' 动画的对象。 ''' BorderThickness属性改变的值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaBorderThickness(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.DoubleAnimation, .AniSubType = AniSubType.BorderThickness, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function 'ColorAnimation ''' ''' 改变Background颜色属性的动画。 ''' ''' 动画的对象。 ''' 颜色改变的值。以RGB加减法进行计算。不用担心超额。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaBackGround(ByVal Obj As Object, ByVal Value As MyColor, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.ColorAnimation, .AniSubType = AniSubType.Background, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay, .Last = New MyColor} End Function ''' ''' 改变BorderBrush颜色属性的动画。 ''' ''' 动画的对象。 ''' 颜色改变的值。以RGB加减法进行计算。不用担心超额。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaBorderBrush(ByVal Obj As Object, ByVal Value As MyColor, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.ColorAnimation, .AniSubType = AniSubType.BorderBrush, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay, .Last = New MyColor} End Function ''' ''' 改变Foreground颜色属性的动画。 ''' ''' 动画的对象。 ''' 颜色改变的值。以RGB加减法进行计算。不用担心超额。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaForeGround(ByVal Obj As Object, ByVal Value As MyColor, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.ColorAnimation, .AniSubType = AniSubType.Foreground, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay, .Last = New MyColor} End Function ''' ''' 改变Stroke颜色属性的动画。 ''' ''' 动画的对象。 ''' 颜色改变的值。以RGB加减法进行计算。不用担心超额。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaStroke(ByVal Obj As Object, ByVal Value As MyColor, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.ColorAnimation, .AniSubType = AniSubType.Stroke, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay, .Last = New MyColor} End Function 'Scale ''' ''' 缩放控件的动画。 ''' ''' 动画的对象。 ''' 大小改变的百分比（如-0.6）或值。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' 大小改变是否为绝对值。若为False则会按照控件当前大小计算相对缩放值。 ''' ''' Public Function AaScale(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False, Optional ByVal Absolute As Boolean = False) As Animation Dim ChangeRect As New AdvancedRect If Absolute Then ChangeRect = New AdvancedRect(-0.5 * Value, -0.5 * Value, Value, Value) Else ChangeRect = New AdvancedRect(-0.5 * Obj.ActualWidth * Value, -0.5 * Obj.ActualHeight * Value, Obj.ActualWidth * Value, Obj.ActualHeight * Value) End If Return New Animation With {.AniType = AniType.Scale, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = ChangeRect, .After = After, .FinishLength = -Delay} End Function 'TextAppear ''' ''' 让一段文字一个个字出现或消失的动画。 ''' ''' 动画的对象。必须是Label或TextBlock。 ''' 是否为一个个字隐藏。默认为False（一个个字出现）。这些字必须已经存在了。 ''' 是否采用根据文本长度决定时间的方式。 ''' 动画长度（毫秒）。若TimePerText为True，这代表每个字所占据的时间。 ''' 动画延迟执行的时间（毫秒）。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaTextAppear(ByVal Obj As Object, Optional ByVal Hide As Boolean = False, Optional ByVal TimePerText As Boolean = True, Optional ByVal Time As Integer = 70, Optional ByVal Delay As Integer = 0, Optional ByVal After As Boolean = False) As Animation 'Are we cool yet？ Return New Animation With {.AniType = AniType.TextAppear, .TotalLength = If(TimePerText, Time * Len(If(Obj.GetType.Name = "TextBlock", Obj.Text, Obj.Context.ToString)), Time), .Obj = Obj, .Value = {If(Obj.GetType.Name = "TextBlock", Obj.Text, Obj.Context.ToString), Hide}, .After = After, .FinishLength = -Delay} End Function 'Code ''' ''' 执行代码。 ''' ''' 一个ThreadStart。这将会在执行时在主线程调用。 ''' 代码延迟执行的时间（毫秒）。 ''' 是否等到以前的动画完成后才执行。 ''' ''' Public Function AaCode(ByVal Code As ThreadStart, Optional ByVal Delay As Integer = 0, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.Code, .TotalLength = 1, .Value = Code, .After = After, .FinishLength = -Delay} End Function 'CodeEvent ''' ''' 执行按照规定格式书写的伪代码。这有很大的局限性，但不会建立线程，性能也更好。 ''' ''' 伪代码元素数组。 ''' 代码延迟执行的时间（毫秒）。 ''' 是否等到以前的动画完成后才执行。 ''' ''' Public Function AaCode(ByVal Code As Array, Optional ByVal Delay As Integer = 0, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.CodeEvent, .TotalLength = 1, .Value = Code, .After = After, .FinishLength = -Delay} End Function 'ScaleTransform ''' ''' 按照 WPF 方式缩放控件的动画。 ''' ''' 动画的对象。它必须已经拥有了单一的 ScaleTransform 值。 ''' 大小改变的百分比（如-0.6）。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaScaleTransform(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.ScaleTransform, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function 'RotateTransform ''' ''' 按照 WPF 方式旋转控件的动画。 ''' ''' 动画的对象。它必须已经拥有了单一的 ScaleTransform 值。 ''' 大小改变的百分比（如-0.6）。 ''' 动画长度（毫秒）。 ''' 动画延迟执行的时间（毫秒）。 ''' 插值器类型。 ''' 是否等到以前的动画完成后才继续本动画。 ''' ''' Public Function AaRotateTransform(ByVal Obj As Object, ByVal Value As Double, Optional ByVal Time As Integer = 400, Optional ByVal Delay As Integer = 0, Optional ByVal Ease As AniEase = Nothing, Optional ByVal After As Boolean = False) As Animation Return New Animation With {.AniType = AniType.RotateTransform, .TotalLength = Time, .Ease = If(Ease, New AniEaseNone), .Obj = Obj, .Value = Value, .After = After, .FinishLength = -Delay} End Function '特殊 ''' ''' 将一个StackPanel中的各个项目依次显示。 ''' ''' Public Function AaStack(ByVal Stack As StackPanel) As ArrayList AaStack = New ArrayList Dim AniDelay As Integer = 0 For Each Item In Stack.Children Item.Opacity = 0 AaStack.Add(AaOpacity(Item, 1, 100, AniDelay)) AniDelay = AniDelay + 25 Next End Function #End Region #Region "插值器" '基类 Public MustInherit Class AniEase ''' ''' 获取增加值。 ''' ''' 较大的时间百分比。 ''' 较小的时间百分比。 ''' Public MustOverride Function GetDelta(t1 As Double, t0 As Double) As Double End Class ''' ''' 线性，无缓动。 ''' Public Class AniEaseNone Inherits AniEase Public Overrides Function GetDelta(t1 As Double, t0 As Double) As Double t1 = MathRange(t1, 0, 1) t0 = MathRange(t0, 0, 1) Return t1 - t0 End Function End Class ''' ''' 平滑开始。 ''' Public Class AniEaseStart Inherits AniEase Public Overrides Function GetDelta(t1 As Double, t0 As Double) As Double t1 = MathRange(t1, 0, 1) t0 = MathRange(t0, 0, 1) Return (t1 - t0) * (t1 + t0) End Function End Class ''' ''' 平滑结束。 ''' Public Class AniEaseEnd Inherits AniEase Public Overrides Function GetDelta(t1 As Double, t0 As Double) As Double t1 = MathRange(t1, 0, 1) t0 = MathRange(t0, 0, 1) Return (t1 - t0) * (2 - t1 - t0) End Function End Class ''' ''' 跳跃开始。 ''' Public Class AniEaseJumpStart Inherits AniEase ''' ''' ''' ''' 跳跃结束时占整个动画的百分比。 Public Sub New(JumpEndPercent As Double) o = JumpEndPercent End Sub Private o As Double Public Overrides Function GetDelta(t1 As Double, t0 As Double) As Double t1 = MathRange(t1, 0, 1) t0 = MathRange(t0, 0, 1) Return (t1 - t0) * (t1 + t0 - o) / (1 - o) End Function End Class ''' ''' 跳跃结束。 ''' Public Class AniEaseJumpEnd Inherits AniEase ''' ''' ''' ''' 跳跃开始时占整个动画的百分比。 Public Sub New(JumpStartPercent As Double) o = JumpStartPercent End Sub Private o As Double Public Overrides Function GetDelta(t1 As Double, t0 As Double) As Double t1 = MathRange(t1, 0, 1) t0 = MathRange(t0, 0, 1) Return (t1 - t0) * (o + 1 - t1 - t0) / o End Function End Class #End Region '等待处理的动画组列表 Private AniWaitingList As New ArrayList Private AniWaitingListName As New ArrayList ''' ''' 开始一个动画组。 ''' ''' 由Aa开头的函数初始化的Animation对象集合。 ''' 动画组的名称。如果重复会直接停止同名动画组。 ''' 是否重新开始这一帧的计时。如果该动画组连续执行请设置为False。 ''' Public Sub AniStart(ByVal AniGroup As ArrayList, ByVal Name As String, Optional ByVal refreshTime As Boolean = True) '把组动画（如 AniStack）分解 Dim AniGroupSet As New ArrayList For i = 0 To AniGroup.Count - 1 If AniGroup(i).GetType.ToString.Contains("ArrayList") Then AniGroupSet.AddRange(AniGroup(i)) Else AniGroupSet.Add(AniGroup(i)) End If Next i '添加到正在执行的动画组 If refreshTime Then AniLastTick = Computer.Clock.TickCount '避免处理动画时已经造成了极大的延迟，导致动画突然结束 AniStop(Name) AniGroups.Add(Name, AniGroupSet) End Sub ''' ''' 开始一个动画组。 ''' ''' 由Aa开头的函数初始化的Animation对象集合。 ''' 动画组的名称。如果重复会直接停止同名动画组。 ''' 是否重新开始这一帧的计时。如果该动画组连续执行请设置为False。 ''' Public Sub AniStart(ByVal aniGroup As Array, ByVal name As String, Optional ByVal refreshTime As Boolean = True) '让Array和ArrayList都可以添加 AniStart(New ArrayList(aniGroup), name, refreshTime) End Sub ''' ''' 停止一个动画组。 ''' ''' 需要停止的动画组的名称。 ''' Public Sub AniStop(ByVal Name As String) If AniGroups.ContainsKey(Name) Then AniGroups.Remove(Name) End Sub Private AniMissions As New ArrayList Private AniFPSCounter As Integer = 0 Private AniFPSTimer As Long = 0 ''' ''' 当前的动画 FPS。 ''' Public AniFPS As Integer = 0 ''' ''' 开始动画执行。 ''' ''' Public Sub AniStartRun() '初始化计时器 AniLastTick = My.Computer.Clock.TickCount AniFPSTimer = My.Computer.Clock.TickCount AniRunning = True '标记动画执行开始 Dim th = New Thread(Sub() Do While True '两帧之间的间隔时间 Dim DeltaTime As Integer = My.Computer.Clock.TickCount - AniLastTick If DeltaTime < 2 Then GoTo Sleeper AniLastTick = My.Computer.Clock.TickCount '执行动画 frmMain.Dispatcher.Invoke(Sub() AniTimer(DeltaTime)) '记录 FPS If AniLastTick - AniFPSTimer >= 1000 Then AniFPS = AniFPSCounter AniFPSCounter = 0 AniFPSTimer = AniLastTick If MODE_DEVELOPER Then frmMain.Dispatcher.Invoke(Sub() frmMain.Title = "PCL / FPS : " & AniFPS) End If AniFPSCounter = AniFPSCounter + 1 Sleeper: '控制 FPS Thread.Sleep(1) Loop End Sub) th.Start() End Sub Private AniCodeList As New ArrayList ''' ''' 动画定时器事件。 ''' ''' Public Sub AniTimer(DeltaTime As Integer) Rnd.NextDouble() '重置随机数发生器 For Each Code In AniCodeList frmMain.Dispatcher.Invoke(Code) Next AniCodeList.Clear() Try Dim i As Integer = 0 '循环每个动画组 Do While i < AniGroups.Count '初始化 Dim aniGroup = AniGroups.Values(i) Dim CanRemoveAfter = True '是否应该去除“之后”标记 Dim ii = 0 '循环每个动画 Do While ii < aniGroup.Count Dim Anim As Animation = aniGroup(ii) '执行种类 If Anim.After = False Then '之前 CanRemoveAfter = False '取消“之后”标记 '增加执行时间 Anim.FinishLength = Anim.FinishLength + DeltaTime '执行动画 If Anim.FinishLength > 0 Then Anim = AniRun(Anim) '执行动画 '如果当前动画已执行完毕 If Anim.FinishLength >= Anim.TotalLength Then '删除 aniGroup.RemoveAt(ii) GoTo NextAni End If aniGroup(ii) = Anim Else '之后 If CanRemoveAfter Then '之后改为之前 CanRemoveAfter = False Anim.After = False aniGroup(ii) = Anim '重新循环该动画 GoTo NextAni Else '不能去除该“之后”标记，结束该动画组 Exit Do End If End If ii = ii + 1 NextAni: Loop '如果当前动画组都执行完毕则删除 If aniGroup.Count = 0 Then AniGroups.Remove(AniGroups.Keys(i)) i = i - 1 End If '继续循环 i = i + 1 Loop Catch ex As Exception ExShow(ex, "动画刻执行失败", ErrorLevel.Slient) End Try End Sub ''' ''' 执行一个动画。 ''' ''' 执行的动画对象。 ''' Private Function AniRun(ByVal Ani As Animation) As Animation Try Select Case Ani.AniType Case AniType.DoubleAnimation Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.FinishLength / Ani.TotalLength, Ani.Percent)) Select Case Ani.AniSubType Case AniSubType.X SetLeft(Ani.Obj, GetLeft(Ani.Obj) + Delta) Case AniSubType.Y SetTop(Ani.Obj, GetTop(Ani.Obj) + Delta) Case AniSubType.Opacity Ani.Obj.Opacity = MathRange(Ani.Obj.Opacity + Delta, 0, 1) Case AniSubType.Width Ani.Obj.Width = MathRange(Ani.Obj.Width + Delta, 0) Case AniSubType.Height Ani.Obj.Height = MathRange(Ani.Obj.Height + Delta, 0) Case AniSubType.Value Ani.Obj.Value = Ani.Obj.Value + Delta Case AniSubType.Radius Ani.Obj.Radius = Ani.Obj.Radius + Delta Case AniSubType.BorderThickness Ani.Obj.BorderThickness = New Thickness(CType(Ani.Obj.BorderThickness, Thickness).Bottom + Delta) End Select Case AniType.ColorAnimation '利用Last记录了余下的小数值 Dim Delta As MyColor = MathPercent(New MyColor, Ani.Value, Ani.Ease.GetDelta(Ani.FinishLength / Ani.TotalLength, Ani.Percent)) + Ani.Last Select Case Ani.AniSubType Case AniSubType.Background Dim NewColor As MyColor = New MyColor(Ani.Obj.Background.Color) + Delta Ani.Obj.Background = NewColor Ani.Last = NewColor - New MyColor(Ani.Obj.Background.Color) Case AniSubType.Foreground Dim NewColor As MyColor = New MyColor(Ani.Obj.Foreground.Color) + Delta Ani.Obj.Foreground = NewColor Ani.Last = NewColor - New MyColor(Ani.Obj.Foreground.Color) Case AniSubType.Stroke Dim NewColor As MyColor = New MyColor(Ani.Obj.Stroke.Color) + Delta Ani.Obj.Stroke = NewColor Ani.Last = NewColor - New MyColor(Ani.Obj.Stroke.Color) Case AniSubType.BorderBrush Dim NewColor As MyColor = New MyColor(Ani.Obj.BorderBrush.Color) + Delta Ani.Obj.BorderBrush = NewColor Ani.Last = NewColor - New MyColor(Ani.Obj.BorderBrush.Color) End Select Case AniType.Scale Dim Delta As Double = Ani.Ease.GetDelta(Ani.FinishLength / Ani.TotalLength, Ani.Percent) Ani.Obj.Margin = New Thickness(Ani.Obj.Margin.Left + MathPercent(0, Ani.Value.Left, Delta), Ani.Obj.Margin.Top + MathPercent(0, Ani.Value.Top, Delta), Ani.Obj.Margin.Right, Ani.Obj.Margin.Bottom) Ani.Obj.Width = Math.Max(Ani.Obj.Width + MathPercent(0, Ani.Value.Width, Delta), 0) Ani.Obj.Height = Math.Max(Ani.Obj.Height + MathPercent(0, Ani.Value.Height, Delta), 0) Case AniType.TextAppear Dim NewText As String = Mid(Ani.Value(0), 1, If(Ani.Value(1), Len(Ani.Value(0)), 0) + Math.Round(Len(Ani.Value(0)) * If(Ani.Value(1), -1, 1) * Ani.Ease.GetDelta(Ani.FinishLength / Ani.TotalLength, 0))) If Ani.Obj.GetType.Name = "TextBlock" Then Ani.Obj.Text = NewText Else Ani.Obj.Context = NewText End If Case AniType.Code AniCodeList.Add(Ani.Value) Case AniType.CodeEvent Select Case Ani.Value(0) Case "Close" Ani.Value(1).Close() Case "Clear" Ani.Value(1).Clear() Case "Remove" Ani.Value(1).Remove(Ani.Value(2)) Case "Add" Ani.Value(1).Add(Ani.Value(2)) Case "Set" Ani.Value(1) = Ani.Value(2) Case "Tag" Ani.Value(1).Tag = Ani.Value(2) Case "Enabled" Ani.Value(1).IsEnabled = Ani.Value(2) Case "State" Ani.Value(1).State = Ani.Value(2) Case "IsHitTestVisible" Ani.Value(1).IsHitTestVisible = Ani.Value(2) Case "ShowInTaskbar" Ani.Value(1).ShowInTaskbar = Ani.Value(2) Case "Nothing" Ani.Value(1) = Nothing Case "Visible" Ani.Value(1).Visibility = If(Ani.Value(2), Visibility.Visible, Visibility.Collapsed) Case "End" EndForce() Case Else AaCodeCall(Ani.Value(0), Ani.Value) End Select Case AniType.ScaleTransform Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.FinishLength / Ani.TotalLength, Ani.Percent)) CType(Ani.Obj.RenderTransform, ScaleTransform).ScaleX = CType(Ani.Obj.RenderTransform, ScaleTransform).ScaleX + Delta CType(Ani.Obj.RenderTransform, ScaleTransform).ScaleY = CType(Ani.Obj.RenderTransform, ScaleTransform).ScaleY + Delta Case AniType.RotateTransform Dim Delta As Double = MathPercent(0, Ani.Value, Ani.Ease.GetDelta(Ani.FinishLength / Ani.TotalLength, Ani.Percent)) CType(Ani.Obj.RenderTransform, RotateTransform).Angle = CType(Ani.Obj.RenderTransform, RotateTransform).Angle + Delta End Select Ani.Percent = Ani.FinishLength / Ani.TotalLength '修改执行百分比 Catch ex As Exception ExShow(ex, "执行动画失败：" & GetStringFromEnum(Ani.AniType), ErrorLevel.Slient) End Try Return Ani End Function End Module '动画 Public Module Web ''' ''' 正在下载的列表。 ''' ''' Public WebGroups As New Dictionary(Of String, WebGroup) Private WebDownloadingList As New ArrayList Public WebDownloadCountMax As Integer = ReadIni("setup", "DownMaxinum", "20") #Region "类与枚举" ''' ''' 下载文件的文件大小处理方式。 ''' Public Enum WebRequireSize As Integer ''' ''' 在下载前已经知道了文件大小。 ''' Known = 0 ''' ''' 下载前不知道文件大小，需要从网络中获取。 ''' Require = 1 ''' ''' 下载前不知道文件大小，也不获取大小。 ''' DontNeed = 2 ''' ''' 不需要知道准确大小，只要求文件至少有一定的大小。 ''' AtLeast = 3 End Enum Public Class WebGroup Public Name As String ''' ''' 文件列表（WebFile）。 ''' ''' Public Files As ArrayList ''' ''' 是否尝试从服务器确认文件大小。 ''' ''' Public GetServerFileSize As WebRequireSize ''' ''' 下载成功时执行的线程。 ''' ''' Public OnSuccess As System.Threading.ParameterizedThreadStart ''' ''' 下载失败时执行的线程。 ''' ''' Public OnFail As System.Threading.ParameterizedThreadStart ''' ''' 已下载的文件数目（下载成功或失败的）。（用于文件数较多情况下的快速进度计算） ''' Public FinishedCount As Integer = 0 ''' ''' 下载完成的文件数目的百分比。取值为0到1。 ''' ''' Public ReadOnly Property Percent As Double Get Select Case Files.Count Case 0 Percent = 0 Case 1 Percent = Math.Round(CType(Files(0), WebFile).Percent, 4) Case Is < 60 Dim TotalPercent As Double = 0 For i = 0 To Files.Count - 1 TotalPercent = TotalPercent + CType(Files(i), WebFile).Percent Next Percent = Math.Round(TotalPercent / Files.Count, 4) Case Else Percent = Math.Round(FinishedCount / Files.Count, 4) End Select End Get End Property ''' ''' 该文件组的唯一标识符。 ''' ''' Public UUID As Integer = GetUUID() End Class Public Class WebFile ''' ''' 文件所有可能的网络URL。 ''' ''' Public AllWebAddress As ArrayList ''' ''' 文件当前的网络URL。 ''' ''' Public ReadOnly Property WebAddress As String Get Return If(AllWebAddress(0), "") End Get End Property ''' ''' 文件在本地的完整地址。 ''' ''' Public ReadOnly Property LocalAddress As String Get Return LocalFolder & LocalName End Get End Property ''' ''' 文件在本地的所在的文件夹，以“\”结尾。 ''' ''' Public LocalFolder As String ''' ''' 是否需要刷新文件名。 ''' ''' Public RefreshName As Boolean = False Private _LocalName As String = "" ''' ''' 当前的文件名。如果需要刷新文件名，它有可能改变。 ''' ''' Public Property LocalName As String Get If _LocalName = "" Or IsNothing(_LocalName) Then _LocalName = GetFileNameFromPath(WebAddress) Return _LocalName End Get Set(ByVal value As String) _LocalName = value End Set End Property ''' ''' 使用下一个下载地址。 ''' ''' Public Function NextAddress() As Boolean If AllWebAddress.Count > 1 Then AllWebAddress.RemoveAt(0) If RefreshName Then LocalName = GetFileNameFromPath(WebAddress) Return True Else Return False End If End Function Private _State As WebDownloadStats = WebDownloadStats.FirstLoad ''' ''' 状态标记。 ''' ''' Public Property State As WebDownloadStats Get Return _State End Get Set(ByVal value As WebDownloadStats) If value = _State Then Exit Property '改变状态 _State = value Select Case value Case WebDownloadStats.FirstLoad '等待下载 GetSize = 0 Speed = 0 Percent = 0 SyncLock WebWaitingLockObj WebWaitingList.Add(Me) End SyncLock Case WebDownloadStats.Wait '等待下载 frmDownloadRight.RefreshFile(Me) GetSize = 0 Speed = 0 Percent = 0 SyncLock WebWaitingLockObj WebWaitingList.Insert(0, Me) End SyncLock WebWaitingToRun() Case WebDownloadStats.GetSize '获取大小 frmDownloadRight.RefreshFile(Me) WebStateGetSize(Me) Case WebDownloadStats.Download '下载 frmDownloadRight.RefreshFile(Me) WebStateDownload(Me) Case WebDownloadStats.Success '下载成功 Speed = 0 Percent = 1 WebStateSuccess(Me) WebGroups(GroupName).FinishedCount = WebGroups(GroupName).FinishedCount + 1 frmDownloadRight.RefreshFile(Me) WebFinishCheck(Me.GroupName) Case WebDownloadStats.Fail '下载失败 GetSize = 0 Speed = 0 Percent = 0 If Not WebStateFail(Me) Then WebGroups(GroupName).FinishedCount = WebGroups(GroupName).FinishedCount + 1 frmDownloadRight.RefreshFile(Me) WebFinishCheck(Me.GroupName) End If Case WebDownloadStats.Retry '重试 _State = value frmDownloadRight.RefreshFile(Me) Thread.Sleep(If(WebGroups(GroupName).Files.Count = 1, 200, 1000)) #Disable Warning BC42026 State = WebDownloadStats.Wait End Select End Set End Property ''' ''' 该文件的唯一标识符。 ''' ''' Public UUID As Integer = GetUUID() Public GetServerFileSize As WebRequireSize Public GroupName As String Public RefreshThread As Thread ''' ''' 文件总大小，可能为 0。 ''' ''' Public TotalSize As FileSize = 0 ''' ''' 已经下载了的部分的大小。 ''' ''' Public GetSize As FileSize = 0 ''' ''' 下载速度，单位为秒。 ''' ''' Public Speed As FileSize = 0 ''' ''' 已经下载的百分比。取值为 0 到 1。 ''' ''' Public Percent As Double = 0 ''' ''' 计算下载速度的计刻。 ''' ''' Public SpeedCount As Integer End Class Public Enum WebDownloadStats As Byte ''' ''' 第一次加入列表。等同于 Wait，但是不会刷新队列。 ''' FirstLoad = 6 ''' ''' 等待中。若队列有空闲，需要获取大小的转为 GetSize，不需要获取大小的转为 Download。 ''' ''' Wait = 0 ''' ''' 正在获取大小。获取大小成功的转为 Download，失败的转为 Fail。 ''' ''' GetSize = 1 ''' ''' 正在下载。下载成功的转为 Success，失败的转为 Fail。 ''' ''' Download = 2 ''' ''' 下载成功。 ''' ''' Success = 3 ''' ''' 下载失败。可以重试的转为 Retry。 ''' ''' Fail = 4 ''' ''' 等待重试。半秒后转为 Wait。 ''' Retry = 5 End Enum #End Region '开始下载 ''' ''' 需要下载的文件。 ''' Public Class WebRequireFile ''' ''' 所有可能的下载地址。若前一个地址下载失败会自动尝试下一个地址。 ''' Public WebURLs As ArrayList ''' ''' 本地文件夹地址。不包含文件名。 ''' Public LocalFolder As String = "" ''' ''' 本地文件名，不包含文件夹路径。若为空，则会从下载地址自动生成文件名。 ''' Public LocalName As String = "" ''' ''' 根据文件大小处理方式在这里提交准确大小或至少应有的大小。 ''' Public KnownFileSize As Integer = 0 End Class ''' ''' 开始下载一个列表中的文件。 ''' ''' WebRequireFile 的一维数组。 ''' 下载列表的名称。 ''' 下载成功时执行的代码。 ''' 下载失败时执行的代码。 ''' 文件大小处理方式。 ''' Public Sub WebStart(ByVal SourceFiles() As WebRequireFile, ByVal Name As String, ByVal OnSuccess As ParameterizedThreadStart, ByVal OnFail As ParameterizedThreadStart, ByVal RequireSize As WebRequireSize) Dim th As New Thread(Sub() Try '检查哪些文件需要下载，并将真正需要下载的文件整理为 CheckedFiles 数组 Dim CheckedFiles As New ArrayList(SourceFiles) '检查文件是否存在文件名，如果不存在文件名则跳过过滤 If Not CheckedFiles(0).LocalName = "" Then '过滤已经存在的文件 Select Case RequireSize Case WebRequireSize.Known '已知文件大小，检查文件：如果大小一致则不下载 For i = 0 To CheckedFiles.Count - 1 If CheckedFiles.Count - 1 < i Then Exit For If GetFileSize(CheckedFiles(i).LocalFolder & CheckedFiles(i).LocalName) = CheckedFiles(i).KnownFileSize Then CheckedFiles.RemoveAt(i) i = i - 1 End If Next Case WebRequireSize.Require '不知道文件大小，所以不进行过滤 Case WebRequireSize.DontNeed '不需要知道文件大小，检查文件：如果文件存在则不下载 For i = 0 To CheckedFiles.Count - 1 If CheckedFiles.Count - 1 < i Then Exit For If File.Exists(CheckedFiles(i).LocalFolder & CheckedFiles(i).LocalName) Then CheckedFiles.RemoveAt(i) i = i - 1 End If Next Case WebRequireSize.AtLeast '文件有大小要求，检查文件：如果文件大小大于指定值则不下载 For i = 0 To CheckedFiles.Count - 1 If CheckedFiles.Count - 1 < i Then Exit For If GetFileSize(CheckedFiles(i).LocalFolder & CheckedFiles(i).LocalName) >= Math.Max(1, CheckedFiles(i).KnownFileSize) Then CheckedFiles.RemoveAt(i) i = i - 1 End If Next End Select '去重 CheckedFiles = ArrayNoDouble(CheckedFiles.ToArray) '如果没有剩余文件直接成功 If CheckedFiles.Count = 0 Then '直接成功 frmMain.Dispatcher.Invoke(OnSuccess, Name) Exit Sub End If End If '初始化文件组 Dim NewGroup As New WebGroup With {.OnSuccess = OnSuccess, .OnFail = OnFail, .Files = New ArrayList, .GetServerFileSize = RequireSize, .Name = Name} '二次处理文件，将 WebRequireFile 转为 WebFile For i = 0 To CheckedFiles.Count - 1 Dim NewFile As WebFile If CheckedFiles(0).LocalName = "" Then NewFile = New WebFile With {.AllWebAddress = CheckedFiles(i).WebURLs, .GetServerFileSize = RequireSize, .GroupName = Name, .LocalFolder = CheckedFiles(i).LocalFolder, .TotalSize = New FileSize(CheckedFiles(i).KnownFileSize), .RefreshName = True} Else NewFile = New WebFile With {.AllWebAddress = CheckedFiles(i).WebURLs, .GetServerFileSize = RequireSize, .GroupName = Name, .LocalFolder = CheckedFiles(i).LocalFolder, .TotalSize = New FileSize(CheckedFiles(i).KnownFileSize), .LocalName = CheckedFiles(i).LocalName, .RefreshName = False} End If NewGroup.Files.Add(NewFile) Next WebWaitingList.AddRange(NewGroup.Files) '添加进总列表 If NewGroup.Files.Count = 0 Then Exit Sub If WebGroups.ContainsKey(Name) Then frmDownloadRight.RemoveGroup(WebGroups(Name)) WebGroups.Remove(Name) End If log("[System] 开始下载列表文件：" & Name) WebTaskbarShow = ReadIni("setup", "DownProcess", "True") = "True" WebGroups.Add(Name, NewGroup) frmDownloadRight.AddGroup(NewGroup) '要求执行刷新 WebWaitingToRun() Catch ex As Exception ExShow(ex, "处理下载列表失败：" & Name, ErrorLevel.MsgboxAndFeedback) frmMain.Dispatcher.Invoke(OnFail, Name) End Try End Sub) th.Start() End Sub '下载中 ''' ''' 处于 Waiting 状态的文件。 ''' Private WebWaitingList As New ArrayList Public WebWaitingLockObj As Object = New Object ''' ''' 若队列有空闲，尝试让 Waiting 状态的文件开始下载。 ''' Private Sub WebWaitingToRun() SyncLock WebWaitingLockObj For i = 0 To Math.Min(6, WebWaitingList.Count - 1) Try If WebDownloadingList.Count >= WebDownloadCountMax Or i > Math.Min(6, WebWaitingList.Count - 1) Then Exit Sub If WebDownloadingList.Contains(WebWaitingList(i).UUID) Then GoTo NextFile WebDownloadingList.Add(WebWaitingList(i).UUID) WebWaitingList(i).State = If(WebWaitingList(i).GetServerFileSize = WebRequireSize.Require Or WebWaitingList(i).GetServerFileSize = WebRequireSize.AtLeast, WebDownloadStats.GetSize, WebDownloadStats.Download) WebWaitingList.RemoveAt(i) '移出等待队列 i = i - 1 Catch i = i - 1 End Try NextFile: Next End SyncLock End Sub ''' ''' 获取文件大小，之后转入 Fail 或 Download 状态。 ''' Private Sub WebStateGetSize(File As WebFile) Dim th As New Thread(Sub() Try If MODE_OFFLINE Then File.State = WebDownloadStats.Fail : Exit Sub Select Case File.GetServerFileSize Case WebRequireSize.AtLeast '要求至少有一定大小 Dim TrueSize = GetFileSize(File.WebAddress, File) If TrueSize < 1 Then Throw New Exception("获取文件大小失败！") ElseIf TrueSize < File.TotalSize Then Throw New Exception("文件过小！（" & New FileSize(TrueSize).ToString & "/" & File.TotalSize.ToString & "）") End If File.TotalSize = TrueSize Case WebRequireSize.Require '只是需要知道大小 File.TotalSize = GetFileSize(File.WebAddress, File) If File.TotalSize < 1 Then Throw New Exception("获取文件大小失败！") End Select '获取大小成功，开始下载 File.State = WebDownloadStats.Download Catch ex As Exception ExShow(ex, "获取文件大小失败（" & File.LocalName & "）", ErrorLevel.Slient) File.State = WebDownloadStats.Fail End Try End Sub) th.Start() End Sub ''' ''' 下载文件，之后转入 Fail 或 Success 状态。 ''' Private Sub WebStateDownload(File As WebFile) Dim th As New Thread(Sub() Try '准备 If Not Directory.Exists(File.LocalFolder) Then Directory.CreateDirectory(File.LocalFolder) File.SpeedCount = My.Computer.Clock.TickCount '下载 My.Computer.Network.DownloadFile(File.WebAddress, File.LocalAddress & DOWNLOADING_END, "", "", False, 10000, True) '下载完毕检查 File.GetSize = GetFileSize(File.LocalAddress & DOWNLOADING_END) If File.GetServerFileSize = WebRequireSize.DontNeed Or (File.GetSize = File.TotalSize And File.GetSize > 1) Then '下载成功 IO.File.Delete(File.LocalAddress) Rename(File.LocalAddress & DOWNLOADING_END, File.LocalAddress) log("[Download] 下载文件成功：" & File.WebAddress) File.State = WebDownloadStats.Success Else '下载失败 log("[Download] 下载文件失败（文件大小不匹配）：" & File.LocalAddress & "，所需大小：" & File.TotalSize.ToString & "，实际大小：" & File.GetSize.ToString & "（" & File.GetSize.Value & "）", True) IO.File.Delete(File.LocalAddress & DOWNLOADING_END) File.State = WebDownloadStats.Fail End If Catch ex As Exception ExShow(ex, "下载文件失败（" & File.LocalName & "）", ErrorLevel.Slient) File.State = WebDownloadStats.Fail End Try End Sub) th.Start() '刷新显示线程 File.RefreshThread = New Thread(Sub() Try Do While File.State = WebDownloadStats.Download Thread.Sleep(950) If Not File.State = WebDownloadStats.Download Then Exit Sub Dim NewSize = GetFileSize(File.LocalAddress & DOWNLOADING_END) File.Speed = (NewSize - File.GetSize) / (My.Computer.Clock.TickCount - File.SpeedCount) * 1000 File.SpeedCount = My.Computer.Clock.TickCount File.GetSize = NewSize File.Percent = If(File.TotalSize = 0, 0, Math.Round(File.GetSize / File.TotalSize, 3)) If Not File.State = WebDownloadStats.Download Then Exit Sub frmDownloadRight.RefreshFile(File) Loop Catch End Try End Sub) File.RefreshThread.Start() End Sub ''' ''' 下载失败，之后可能转入 Retry。若重试成功才返回 True。 ''' ''' Private Function WebStateFail(File As WebFile) '重试 If File.NextAddress() And Not MODE_OFFLINE Then '重试成功 log("[Download] 重试地址：" & File.WebAddress) File.State = WebDownloadStats.Retry WebStateFail = True Else '重试失败 WebStateFail = False End If '队列处理 WebDownloadingList.Remove(File.UUID) WebWaitingToRun() End Function ''' ''' 下载成功。 ''' Private Sub WebStateSuccess(File As WebFile) '队列处理 WebDownloadingList.Remove(File.UUID) WebWaitingToRun() End Sub '任务栏进度条 Public WebTaskbarShow As Boolean = True Private WebTaskbarLastState As TaskbarItemProgressState = TaskbarItemProgressState.None Private WebTaskbarLastValue As Double = 0 ''' ''' 下载完成检查。 ''' ''' Public Sub WebFinishCheck(ByVal Name As String) Try If Not WebGroups.Keys.Contains(Name) Then Exit Sub Dim Group As WebGroup = WebGroups(Name) If IsNothing(Group.Files) Then Exit Sub If Not Group.Files.Count = Group.FinishedCount Then Exit Sub '遍历文件：如果存在失败的文件，将 isFail 设置为 True Dim isFail As Boolean = False For i = Group.Files.Count - 1 To 0 Step -1 If Group.Files(i).State = WebDownloadStats.Fail Then isFail = True Next i '下载完成 log("[Download] 列表文件下载完成：" & Name) '结束 WebGroups.Remove(Name) frmDownloadRight.RemoveGroup(Group) If isFail Then frmMain.Dispatcher.Invoke(Group.OnFail, Name) Else frmMain.Dispatcher.Invoke(Group.OnSuccess, Name) End If Catch ex As Exception ExShow(ex, "检查下载列表出错") End Try End Sub ''' ''' 停止下载列表文件。 ''' ''' ''' Public Sub WebDownloadStop(ByVal Name As String) If WebGroups.ContainsKey(Name) Then frmDownloadRight.RemoveGroup(WebGroups(Name)) WebGroups.Remove(Name) End If End Sub Public Sub WebStartRun() Dim th As New Thread(Sub() Do While True WebTimer() Thread.Sleep(250) Loop End Sub) th.Priority = ThreadPriority.BelowNormal th.Start() End Sub Public Sub WebTimer() If Not WebTaskbarShow Then Exit Sub '应有值 Dim ShouldState As TaskbarItemProgressState Dim ShouldValue As Double '获取应有值 Try If WebGroups.Count > 0 Then Dim TotalPercent As Double = 0 For Each Group As WebGroup In WebGroups.Values TotalPercent = TotalPercent + Group.Percent Next ShouldState = If(TotalPercent = 0, TaskbarItemProgressState.Indeterminate, TaskbarItemProgressState.Normal) ShouldValue = TotalPercent / WebGroups.Count Else ShouldState = TaskbarItemProgressState.None ShouldValue = 0 End If Catch End Try '更新值 If Not WebTaskbarLastState = ShouldState Then frmMain.Dispatcher.Invoke(Sub() frmMain.TaskbarItemInfo.ProgressState = ShouldState) WebTaskbarLastState = ShouldState End If If Not WebTaskbarLastValue = ShouldValue Then frmMain.Dispatcher.Invoke(Sub() frmMain.TaskbarItemInfo.ProgressValue = ShouldValue) WebTaskbarLastValue = ShouldValue End If End Sub End Module 'HTTP下载 Public Module BitDrawer Public GifList As New ArrayList 'Gif列表 'Timer Public Sub GifStartRun() Dim time As New DispatcherTimer() time.Interval = TimeSpan.FromMilliseconds(1) AddHandler time.Tick, AddressOf GifTimer time.Start() End Sub Public Sub GifTimer() For i = 0 To GifList.Count - 1 Dim gif As MyBitmap = GifList(i) '切换Gif的帧 If My.Computer.Clock.TickCount - gif.RoundLastTime >= gif.RoundTime Then gif.RoundLastTime = My.Computer.Clock.TickCount If gif.CurrentFlame = gif.MaxFlame - 1 Then If gif.PlayOnce Then '如果只播放一次那么拜拜 GifList.Remove(gif) Else '如果不只播放一次那么继续 gif.SetGifFrame(0) End If Else gif.SetGifFrame(gif.CurrentFlame + 1) End If End If '刷新绑定控件的显示 If Not IsNothing(gif.Control) Then gif.Control.Source = New MyBitmap(gif.Pic) Next End Sub '类 Public Class MyBitmap ''' ''' 存储的图片 ''' ''' Public Pic As System.Drawing.Bitmap ''' ''' (Gif)绑定的控件 ''' ''' Public Control As System.Windows.Controls.Image = Nothing ''' ''' (Gif)每一帧的时间 ''' ''' Public RoundTime As Integer ''' ''' (Gif)上一次改变时的时间 ''' ''' Public RoundLastTime As Integer ''' ''' (Gif)是否只播放一次 ''' ''' Public PlayOnce As Boolean = False ''' ''' (Gif)当前帧，从0开始 ''' ''' Public CurrentFlame As Integer = 0 ''' ''' (Gif)最大帧数，从1开始 ''' ''' Public MaxFlame As Integer '类型转换 '支持的类：Image ImageSource Bitmap ImageBrush Public Shared Widening Operator CType(ByVal Image As System.Drawing.Image) As MyBitmap Return New MyBitmap(Image) End Operator Public Shared Widening Operator CType(ByVal Image As MyBitmap) As System.Drawing.Image Return Image.Pic End Operator Public Shared Widening Operator CType(ByVal Image As ImageSource) As MyBitmap Return New MyBitmap(Image) End Operator Public Shared Widening Operator CType(ByVal Image As MyBitmap) As ImageSource Dim ptr As IntPtr = Image.Pic.GetHbitmap() Dim re As ImageSource = System.Windows.Interop.Imaging.CreateBitmapSourceFromHBitmap( ptr, IntPtr.Zero, Int32Rect.Empty, BitmapSizeOptions.FromEmptyOptions()) DeleteObject(ptr) Return re End Operator Public Shared Widening Operator CType(ByVal Image As System.Drawing.Bitmap) As MyBitmap Return New MyBitmap(Image) End Operator Public Shared Widening Operator CType(ByVal Image As MyBitmap) As System.Drawing.Bitmap Return Image.Pic End Operator Public Shared Widening Operator CType(ByVal Image As ImageBrush) As MyBitmap Return New MyBitmap(Image) End Operator Public Shared Widening Operator CType(ByVal Image As MyBitmap) As ImageBrush Return New ImageBrush(New MyBitmap(Image.Pic)) End Operator '构造函数 Public Sub New() End Sub Public Sub New(ByVal FilePath As String) Try If FilePath.StartsWith(PATH_IMAGE) Then '使用缓存 If BitmapCache.ContainsKey(FilePath) Then Pic = BitmapCache(FilePath).Pic Else Pic = New MyBitmap(CType((New ImageSourceConverter).ConvertFromString(FilePath), ImageSource)) BitmapCache.Add(FilePath, Pic) End If Else Using inputStream As New FileStream(FilePath, FileMode.Open) Pic = New System.Drawing.Bitmap(inputStream) End Using End If Catch ex As Exception Pic = My.Application.TryFindResource(FilePath) If IsNothing(Pic) Then Pic = New System.Drawing.Bitmap(1, 1) ExShow(ex, "加载图片失败，该图片加载已被跳过：" & FilePath, ErrorLevel.DebugOnly) End If End Try End Sub Public Sub New(ByVal 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(ByVal Image As System.Drawing.Image) Pic = Image End Sub Public Sub New(ByVal Image As System.Drawing.Bitmap) Pic = Image End Sub Public Sub New(ByVal 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 ''' ''' 设置Gif的当前帧 ''' ''' 帧的编号，从0开始，超限制报错 ''' Public Sub SetGifFrame(ByVal count As Integer) Pic.SelectActiveFrame(New FrameDimension(Pic.FrameDimensionsList()(0)), count) CurrentFlame = count End Sub ''' ''' 把这个对象视作Gif初始化 ''' ''' 两帧之间的间隔（毫秒）。 ''' 是否只播放一次，True为是。 ''' 绑定的控件。 ''' Public Sub GifLoad(ByVal round As Integer, ByVal once As Boolean, Optional ByVal control As System.Windows.Controls.Image = Nothing) RoundTime = round RoundLastTime = My.Computer.Clock.TickCount PlayOnce = once Me.Control = control GifList.Add(Me) MaxFlame = Pic.GetFrameCount(New FrameDimension(Pic.FrameDimensionsList()(0))) End Sub ''' ''' 获取旋转的图片，这个方法不会导致原对象改变 ''' ''' 旋转角度，单位为角度不是弧度啊 ''' 旋转后的Bitmap ''' Public Function Rotation(ByVal angle As Double) As System.Drawing.Bitmap With Me Dim img As System.Drawing.Image = Me.Pic Dim bitSize As Single = Math.Sqrt(img.Width ^ 2 + img.Height ^ 2) bitSize = img.Width Dim bmp As System.Drawing.Bitmap = 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 ''' ''' 获取左右翻转的图片，这个方法不会导致原对象改变 ''' ''' ''' Public Function LeftRightFilp() As System.Drawing.Bitmap Dim bmp As System.Drawing.Bitmap = New System.Drawing.Bitmap(Me.Pic) bmp.RotateFlip(System.Drawing.RotateFlipType.RotateNoneFlipX) Return bmp End Function End Class '合并Bitmap Public Function BitmapAdd(ByVal background As System.Drawing.Bitmap, ByVal position As System.Drawing.Point, ByVal img As System.Drawing.Bitmap) As System.Drawing.Bitmap Dim graph As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(background) graph.DrawImage(img, position) Return background End Function '裁剪Bitmap Public Function BitmapCut(ByVal img As BitmapSource, ByVal x As Integer, ByVal y As Integer, ByVal width As Integer, ByVal height As Integer) As BitmapSource Return New CroppedBitmap(img, New Int32Rect(x, y, width, height)) End Function End Module '绘图 'Public Module FTP ' Public Function DownloadFTPFile(ByVal ftpclient As FTPDownloader, ByVal webPath As String, ByVal localPath As String) ' File.Delete(localPath) ' DownloadFTPFile = False ' Try ' If Not ftpclient.ftpIsLogin Then ftpclient.Login() ' If webPath.Contains("/") Then ftpclient.ChangeDirectory(Mid(webPath, 1, webPath.LastIndexOf("/"))) ' ftpclient.DownloadFile(Mid(webPath, webPath.LastIndexOf("/") + 2), localPath) ' Return True ' Catch ex As Exception ' End Try ' End Function '直接下载单个文件 ' Public Class FTPDownloader '#Region "变量声明" ' Private m_sRemoteHost, m_sRemotePath, m_sRemoteUser As String ' Private m_sRemotePassword, m_sMess As String ' Private m_iRemotePort, m_iBytes As Int32 ' Private m_objClientSocket As Socket ' Private m_iRetValue As Int32 ' Public ftpIsLogin As Boolean ' Private m_sMes, m_sReply As String ' '设置用户来对FTP服务器读取和写入数据的数据包的大小 ' Public Const BLOCK_SIZE = 512 ' Private m_aBuffer(BLOCK_SIZE) As Byte ' Private ASCII As Encoding = Encoding.ASCII ' Public flag_bool As Boolean ' '普通变量定义 ' Private m_sMessageString As String '#End Region '#Region "构造函数" ' Public Sub New() ' m_sRemoteHost = "localhost" ' m_sRemotePath = "." ' m_sRemoteUser = "anonymous" ' m_sRemotePassword = "" ' m_sMessageString = "" ' m_iRemotePort = 21 ' ftpIsLogin = False ' End Sub ' Public Sub New(ByVal sRemoteHost As String, ByVal sRemotePath As String, ByVal sRemoteUser As String, ByVal sRemotePassword As String, ByVal iRemotePort As Int32) ' m_sRemoteHost = sRemoteHost ' m_sRemotePath = sRemotePath ' m_sRemoteUser = sRemoteUser ' m_sRemotePassword = sRemotePassword ' m_sMessageString = "" ' m_iRemotePort = iRemotePort ' ftpIsLogin = False ' End Sub '#End Region '#Region "属性" ' '设置或获取FTP服务器的名称 ' Public Property RemoteHostFTPServer() As String ' Get ' Return m_sRemoteHost ' End Get ' Set(ByVal Value As String) ' m_sRemoteHost = Value ' End Set ' End Property ' '设置或获取FTP服务器的端口 ' Public Property RemotePort() As Int32 ' Get ' Return m_iRemotePort ' End Get ' Set(ByVal Value As Int32) ' m_iRemotePort = Value ' End Set ' End Property ' '设置或获取FTP服务器的远程路径 ' Public Property RemotePath() As String ' Get ' Return m_sRemotePath ' End Get ' Set(ByVal Value As String) ' m_sRemotePath = Value ' End Set ' End Property ' '设置或获取FTP服务器的用户 ' Public Property RemoteUser() As String ' Get ' Return m_sRemoteUser ' End Get ' Set(ByVal Value As String) ' m_sRemoteUser = Value ' End Set ' End Property ' '设置FTP服务器的密码 ' Public Property RemotePassword() As String ' Get ' Return m_sRemotePassword ' End Get ' Set(ByVal Value As String) ' m_sRemotePassword = Value ' End Set ' End Property ' '设置信息 ' Public Property MessageString() As String ' Get ' Return m_sMessageString ' End Get ' Set(ByVal Value As String) ' m_sMessageString = Value ' End Set ' End Property '#End Region ' '登录FTP服务器 ' Public Function Login() As Boolean ' If ftpIsLogin Then Return True ' m_objClientSocket = _ ' New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) ' Dim ep As New IPEndPoint(Dns.GetHostEntry(m_sRemoteHost).AddressList(0), m_iRemotePort) ' Try ' m_objClientSocket.Connect(ep) ' Catch ex As Exception ' MessageString = m_sReply ' Throw New IOException("无法链接到FTP服务器。") ' End Try ' ReadReply() ' If (m_iRetValue <> 220) Then ' CloseConnection() ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' '为了发送一个对服务器的用户登录ID，发送一个FTP命令 ' SendCommand("USER " & m_sRemoteUser) ' If (Not (m_iRetValue = 331 Or m_iRetValue = 230)) Then ' Cleanup() ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' If (m_iRetValue <> 230) Then ' '为了发送一个对服务器的用户密码，发送一个FTP命令 ' SendCommand("PASS " & m_sRemotePassword) ' If (Not (m_iRetValue = 230 Or m_iRetValue = 202)) Then ' Cleanup() ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' End If ' ftpIsLogin = True ' '为了改变映射的远程服务器的文件夹的目录，调用用户定义的ChangeDirectory函数 ' ChangeDirectory(m_sRemotePath) ' '返回最终结果 ' Return ftpIsLogin ' End Function ' '获取文件列表 ' Public Function GetFileList(ByVal sMask As String) As String() ' Dim cSocket As Socket ' Dim bytes As Int32 ' Dim seperator As Char = ControlChars.Lf ' Dim mess() As String ' m_sMes = "" ' '检查是否登录 ' If (Not (ftpIsLogin)) Then Login() ' cSocket = CreateDataSocket() ' '发送FTP命令 ' SendCommand("NLST " & sMask) ' If (Not (m_iRetValue = 150 Or m_iRetValue = 125)) Then ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' m_sMes = "" ' Do While (True) ' Array.Clear(m_aBuffer, 0, m_aBuffer.Length) ' bytes = cSocket.Receive(m_aBuffer, m_aBuffer.Length, 0) ' m_sMes += ASCII.GetString(m_aBuffer, 0, bytes) ' If (bytes < m_aBuffer.Length) Then ' Exit Do ' End If ' Loop ' mess = m_sMes.Split(seperator) ' cSocket.Close() ' ReadReply() ' If (m_iRetValue <> 226) Then ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' Return mess ' End Function ' '获取文件大小 ' Public Function GetFileSize(ByVal sFileName As String) As Integer ' Dim size As Integer ' '检查是否登录 ' If Not ftpIsLogin Then Login() ' '发送FTP命令 ' SetBinaryMode(True) ' SendCommand("SIZE " & sFileName) ' size = 0 ' If (m_iRetValue = 213) Then ' size = Int64.Parse(m_sReply.Substring(4)) ' Else ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' Return size ' End Function ' '下载文件 ' Public Sub DownloadFile(ByVal fileName As String, Optional ByVal localFile As String = "", Optional ByVal isResume As Boolean = False) ' Dim st As Stream ' Dim cSocket As Socket ' Dim offset, npos As Integer ' If Not ftpIsLogin Then Login() '检查是否登录 ' SetBinaryMode(True) '设置下载模式 ' '检查下载目录 ' If localFile = "" Then localFile = fileName ' If Not (File.Exists(localFile)) Then ' st = File.Create(localFile) ' st.Close() ' End If ' '下载 ' Using output As New FileStream(localFile, FileMode.Open) ' cSocket = CreateDataSocket() ' offset = 0 ' If isResume Then ' offset = output.Length ' If offset > 0 Then ' '发送一个FTP命令重新启动 ' SendCommand("REST " & offset) ' If (m_iRetValue <> 350) Then offset = 0 ' npos = output.Seek(offset, SeekOrigin.Begin) ' End If ' End If ' '发送一个FTP命令重新找到一个文件 ' SendCommand("RETR " & fileName) ' If (Not (m_iRetValue = 150 Or m_iRetValue = 125)) Then ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' Do While (True) ' Array.Clear(m_aBuffer, 0, m_aBuffer.Length) ' m_iBytes = cSocket.Receive(m_aBuffer, m_aBuffer.Length, 0) ' output.Write(m_aBuffer, 0, m_iBytes) ' If (m_iBytes <= 0) Then ' Exit Do ' End If ' Loop ' End Using ' If (cSocket.Connected) Then ' cSocket.Close() ' End If ' ReadReply() ' If (Not (m_iRetValue = 226 Or m_iRetValue = 250)) Then ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' End Sub ' '设置下载模式 ' Public Sub SetBinaryMode(ByVal bMode As Boolean) ' '发送FTP命令，设置为二进制模式(True)或ASCII模式(False) ' SendCommand(If(bMode, "TYPE I", "TYPE A")) ' If (m_iRetValue <> 200) Then ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' End Sub ' 'Dim str_file_path As String = "C:\test.txt" '要上传的文件名及路径 ' 'Dim str_filename As String = IO.Path.GetFileName(str_file_path) '要上传的文件名 ' 'Dim MyFileSize As Integer = FileLen(str_file_path) '要上传得文件大小 ' 'If (ftpClient.Login() = True) Then ' ' '创建一个新文件夹 ' ' ftpClient.CreateDirectory("FTPFOLDERNEW") ' ' '将新的文件夹设置为活动文件夹。 ' ' ftpClient.ChangeDirectory("FTPFOLDERNEW") ' ' '设置FTP模式 ' ' ftpClient.SetBinaryMode(True) ' ' '从你的硬盘上上载一个文件到FTP网页 ' ' ftpClient.UploadFile(str_file_path) ' ' '获得刚刚上传的文件的大小 ' ' Dim lng_filesize As Integer ' ' lng_filesize = ftpClient.GetFileSize(str_filename) ' ' If lng_filesize = MyFileSize Then ' ' MsgBox("成功上传文件" & str_filename & " 文件大小" & lng_filesize) ' ' Else ' ' MsgBox("上传失败") ' ' End If ' ' '对上载文件重命名 ' ' 'ftpClient.RenameFile("SampleFile.xml", "SampleFile_new.xml") ' ' '删除一个文件 ' ' 'ftpClient.DeleteFile("SampleFile_new.xml") ' ' ftpClient.CloseConnection() ' 'End If ' ''这是一个从你的本地硬盘上向你的FTP文件夹中上载文件的函数 ' 'Public Sub UploadFile(ByVal sFileName As String) ' ' UploadFile(sFileName, False) ' 'End Sub ' ''这是一个从你的本地硬盘上向你的FTP网页上上载的函数和设置恢复标志 ' 'Public Sub UploadFile(ByVal sFileName As String, ' ' ByVal bResume As Boolean) ' ' Dim cSocket As Socket ' ' Dim offset As Integer ' ' Dim input As FileStream ' ' Dim bFileNotFound As Boolean ' ' If (Not (ftpIsLogin)) Then ' ' Login() ' ' End If ' ' cSocket = CreateDataSocket() ' ' offset = 0 ' ' If (bResume) Then ' ' Try ' ' SetBinaryMode(True) ' ' offset = GetFileSize(sFileName) ' ' Catch ex As Exception ' ' offset = 0 ' ' End Try ' ' End If ' ' If (offset > 0) Then ' ' SendCommand("REST " & offset) ' ' If (m_iRetValue <> 350) Then ' ' '远程服务器可能不支持恢复。 ' ' offset = 0 ' ' End If ' ' End If ' ' '发送一个FTP命令，存储一个文件。 ' ' SendCommand("STOR " & Path.GetFileName(sFileName)) ' ' If (Not (m_iRetValue = 125 Or m_iRetValue = 150)) Then ' ' MessageString = m_sReply ' ' Throw New IOException(m_sReply.Substring(4)) ' ' End If ' ' '在上载之前，检查文件是否存在。 ' ' bFileNotFound = False ' ' If (File.Exists(sFileName)) Then ' ' '打开输入流读取源文件 ' ' input = New FileStream(sFileName, FileMode.Open) ' ' If (offset <> 0) Then ' ' input.Seek(offset, SeekOrigin.Begin) ' ' End If ' ' '上载这个文件 ' ' m_iBytes = input.Read(m_aBuffer, 0, m_aBuffer.Length) ' ' Do While (m_iBytes > 0) ' ' cSocket.Send(m_aBuffer, m_iBytes, 0) ' ' m_iBytes = input.Read(m_aBuffer, 0, m_aBuffer.Length) ' ' Loop ' ' input.Close() ' ' Else ' ' bFileNotFound = True ' ' End If ' ' If (cSocket.Connected) Then ' ' cSocket.Close() ' ' End If ' ' '如果找不到文件，检查返回值 ' ' If (bFileNotFound) Then ' ' MessageString = m_sReply ' ' Throw New IOException("The file: " & sFileName & " was not found. " & _ ' ' "Cannot upload the file to the FTP site") ' ' End If ' ' ReadReply() ' ' If (Not (m_iRetValue = 226 Or m_iRetValue = 250)) Then ' ' MessageString = m_sReply ' ' Throw New IOException(m_sReply.Substring(4)) ' ' End If ' 'End Sub ' ''从远程FTP服务器上删除一个文件。 ' 'Public Function DeleteFile(ByVal sFileName As String) As Boolean ' ' Dim bResult As Boolean ' ' bResult = True ' ' If (Not (ftpIsLogin)) Then ' ' Login() ' ' End If ' ' '发送一个FTP命令，删除一个文件。 ' ' SendCommand("DELE " & sFileName) ' ' If (m_iRetValue <> 250) Then ' ' bResult = False ' ' MessageString = m_sReply ' ' End If ' ' '返回最终结果 ' ' Return bResult ' 'End Function ' ''在远程FTP服务器上重命名一个文件 ' 'Public Function RenameFile(ByVal sOldFileName As String, ' 'ByVal sNewFileName As String) As Boolean ' ' Dim bResult As Boolean ' ' bResult = True ' ' If (Not (ftpIsLogin)) Then ' ' Login() ' ' End If ' ' '发送一个FTP命令，对一个文件重命名 ' ' SendCommand("RNFR " & sOldFileName) ' ' If (m_iRetValue <> 350) Then ' ' MessageString = m_sReply ' ' Throw New IOException(m_sReply.Substring(4)) ' ' End If ' ' '发送一个FTP命令，对一个文件更改为新名称 ' ' '如果新的文件名存在，会被覆盖。 ' ' SendCommand("RNTO " & sNewFileName) ' ' If (m_iRetValue <> 250) Then ' ' MessageString = m_sReply ' ' Throw New IOException(m_sReply.Substring(4)) ' ' End If ' ' '返回最终结果 ' ' Return bResult ' 'End Function ' ''这是一个在远程服务器上创建目录的函数 ' 'Public Function CreateDirectory(ByVal sDirName As String) As Boolean ' ' Dim bResult As Boolean ' ' bResult = True ' ' If (Not (ftpIsLogin)) Then ' ' Login() ' ' End If ' ' '发送一个FTP命令，在FTP服务器上制作一个目录 ' ' SendCommand("MKD " & sDirName) ' ' If (m_iRetValue <> 257) Then ' ' bResult = False ' ' MessageString = m_sReply ' ' End If ' ' '返回最终结果 ' ' Return bResult ' 'End Function ' ''这是一个在远程FTP服务器上删除目录的函数 ' 'Public Function RemoveDirectory(ByVal sDirName As String) As Boolean ' ' Dim bResult As Boolean ' ' bResult = True ' ' '检查是否已登录FTP服务器 ' ' If (Not (ftpIsLogin)) Then ' ' Login() ' ' End If ' ' '发送一个FTP命令，删除在FTP服务器上的目录 ' ' SendCommand("RMD " & sDirName) ' ' If (m_iRetValue <> 250) Then ' ' bResult = False ' ' MessageString = m_sReply ' ' End If ' ' '返回最终结果 ' ' Return bResult ' 'End Function ' '改变当前工作目录 ' Public Function ChangeDirectory(ByVal sDirName As String) As Boolean ' Dim bResult As Boolean ' bResult = True ' '检查你是否在根目录 ' If (sDirName.Equals(".")) Then Return False ' '检查是否已登录FTP服务器 ' If Not (ftpIsLogin) Then Login() ' '发送FTP命令，改变在FTP服务器上的目录。 ' SendCommand("CWD " & sDirName) ' If (m_iRetValue <> 250) Then ' bResult = False ' MessageString = m_sReply ' End If ' Me.m_sRemotePath = sDirName ' '返回最终结果 ' Return bResult ' End Function ' '关闭FTP链接 ' Public Sub CloseConnection() ' If Not (m_objClientSocket Is Nothing) Then ' '发送一个FTP命令，结束FTP服务系统 ' SendCommand("QUIT") ' End If ' Cleanup() ' End Sub '#Region "内部函数" ' '从FTP服务器得到回应。 ' Private Sub ReadReply() ' m_sMes = "" ' m_sReply = ReadLine() ' m_iRetValue = Int32.Parse(m_sReply.Substring(0, 3)) ' End Sub ' '重置 ' Private Sub Cleanup() ' If Not (m_objClientSocket Is Nothing) Then ' m_objClientSocket.Close() ' m_objClientSocket = Nothing ' End If ' ftpIsLogin = False ' End Sub ' '从FTP服务器读取一行 ' Private Function ReadLine(Optional ByVal bClearMes As Boolean = False) As String ' Dim seperator As Char = ControlChars.Lf ' Dim mess() As String ' If (bClearMes) Then ' m_sMes = "" ' End If ' Do While (True) ' Array.Clear(m_aBuffer, 0, BLOCK_SIZE) ' Try ' m_iBytes = m_objClientSocket.Receive(m_aBuffer, m_aBuffer.Length, 0) ' Catch ex As Exception ' Login() ' m_iBytes = m_objClientSocket.Receive(m_aBuffer, m_aBuffer.Length, 0) ' End Try ' m_sMes += ASCII.GetString(m_aBuffer, 0, m_iBytes) ' If (m_iBytes < m_aBuffer.Length) Then ' Exit Do ' End If ' Loop ' mess = m_sMes.Split(seperator) ' If (m_sMes.Length > 2) Then ' m_sMes = mess(mess.Length - 2) ' Else ' m_sMes = mess(0) ' End If ' If (Not (m_sMes.Substring(3, 1).Equals(" "))) Then ' Return ReadLine(True) ' End If ' Return m_sMes ' End Function ' '向FTP服务器发送命令 ' Private Sub SendCommand(ByVal command As String) ' command = command & ControlChars.CrLf ' Dim cmdbytes As Byte() = ASCII.GetBytes(command) ' m_objClientSocket.Send(cmdbytes, cmdbytes.Length, 0) ' ReadReply() ' End Sub ' '创建一个数据包 ' Private Function CreateDataSocket() As Socket ' Dim index1, index2, len As Int32 ' Dim partCount, i, port As Int32 ' Dim ipData, buf, ipAddress As String ' Dim parts(6) As Int32 ' Dim ch As Char ' Dim s As Socket ' Dim ep As IPEndPoint ' '发送一个FTP命令，用于被动数据链接 ' SendCommand("PASV") ' If (m_iRetValue <> 227) Then ' MessageString = m_sReply ' Throw New IOException(m_sReply.Substring(4)) ' End If ' index1 = m_sReply.IndexOf("(") ' index2 = m_sReply.IndexOf(")") ' ipData = m_sReply.Substring(index1 + 1, index2 - index1 - 1) ' len = ipData.Length ' partCount = 0 ' buf = "" ' For i = 0 To ((len - 1) And partCount <= 6) ' ch = Char.Parse(ipData.Substring(i, 1)) ' If (Char.IsDigit(ch)) Then ' buf += ch ' ElseIf (ch <> ",") Then ' MessageString = m_sReply ' Throw New IOException("Malformed PASV reply: " & m_sReply) ' End If ' If ((ch = ",") Or (i + 1 = len)) Then ' Try ' parts(partCount) = Int32.Parse(buf) ' partCount += 1 ' buf = "" ' Catch ex As Exception ' MessageString = m_sReply ' Throw New IOException("Malformed PASV reply: " & m_sReply) ' End Try ' End If ' Next ' ipAddress = parts(0) & "." & parts(1) & "." & parts(2) & "." & parts(3) ' '在Visual Basic .Net 2002中进行调用。你想移动8位。在Visual Basic .NET 2002中，你必须将此数乘2的8次方。 ' '端口=parts(4)*(2^8) ' '进行这个调用，并且用Visual Basic .NET 2003解释当前行。 ' port = parts(4) << 8 ' '确定数据端口数 ' port = port + parts(5) ' s = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp) ' ep = New IPEndPoint(Dns.GetHostEntry(ipAddress).AddressList(0), port) ' Try ' s.Connect(ep) ' Catch ex As Exception ' MessageString = m_sReply ' Throw New IOException("Cannot connect to remote server.") ' '如果你不能链接到特定的FTP服务器，也就是说，将其布尔值设置为False。 ' flag_bool = False ' End Try ' '如果你能够链接到特定的FTP服务器，将布尔值设置为True。 ' flag_bool = True ' Return s ' End Function '#End Region ' End Class 'End Module 'FTP协议下载