From 4c1c1a4ab38f57888f0cdc5b83384fd404a955ab Mon Sep 17 00:00:00 2001 From: Dnomd343 Date: Sat, 25 Jul 2020 21:08:48 +0800 Subject: [PATCH] update visual --- src/visual/Form_main.frm | 279 +++++++++++++++++++++- src/visual/HRD_Visual.vbp | 6 +- src/visual/HRD_Visual.vbw | 4 +- src/visual/{Module.bas => Module_hrd.bas} | 22 +- src/visual/Module_main.bas | 87 +++++++ src/visual/Module_update.bas | 86 +++++++ 6 files changed, 452 insertions(+), 32 deletions(-) rename src/visual/{Module.bas => Module_hrd.bas} (91%) create mode 100644 src/visual/Module_main.bas create mode 100644 src/visual/Module_update.bas diff --git a/src/visual/Form_main.frm b/src/visual/Form_main.frm index 3842ee1..0f186b7 100644 --- a/src/visual/Form_main.frm +++ b/src/visual/Form_main.frm @@ -2,10 +2,10 @@ VERSION 5.00 Begin VB.Form Form_main AutoRedraw = -1 'True BorderStyle = 1 'Fixed Single - Caption = "HRD Visual v1.1 by Dnomd343" + Caption = "HRD Visual" ClientHeight = 6495 ClientLeft = 45 - ClientTop = 390 + ClientTop = 690 ClientWidth = 4815 LinkTopic = "Form1" MaxButton = 0 'False @@ -13,6 +13,30 @@ Begin VB.Form Form_main ScaleHeight = 6495 ScaleWidth = 4815 StartUpPosition = 2 '屏幕中心 + Begin VB.PictureBox Picture_Print + Appearance = 0 'Flat + AutoRedraw = -1 'True + BackColor = &H80000005& + BorderStyle = 0 'None + BeginProperty Font + Name = "微软雅黑" + Size = 9 + Charset = 134 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + ForeColor = &H80000008& + Height = 15 + Left = 0 + ScaleHeight = 15 + ScaleWidth = 15 + TabIndex = 5 + Top = 0 + Visible = 0 'False + Width = 15 + End Begin VB.Timer Timer_Tip Enabled = 0 'False Interval = 1200 @@ -67,11 +91,30 @@ Begin VB.Form Form_main Top = 5900 Width = 2040 End + Begin VB.Label Label_Print + AutoSize = -1 'True + BeginProperty Font + Name = "微软雅黑" + Size = 9 + Charset = 134 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + Height = 15 + Left = 0 + TabIndex = 6 + Top = 0 + Visible = 0 'False + Width = 15 + End Begin VB.Label Label_Tip Alignment = 2 'Center Appearance = 0 'Flat AutoSize = -1 'True BackColor = &H80000005& + BackStyle = 0 'Transparent BeginProperty Font Name = "微软雅黑" Size = 12 @@ -89,6 +132,68 @@ Begin VB.Form Form_main Visible = 0 'False Width = 15 End + Begin VB.Menu menu_function + Caption = "功能" + Begin VB.Menu menu_output_pic + Caption = "导出图片" + Begin VB.Menu ouput_pic_no_code + Caption = "无编码图片" + End + Begin VB.Menu output_pic_with_code + Caption = "带编码图片" + End + End + Begin VB.Menu menu_analyse_code + Caption = "解析编码" + End + Begin VB.Menu menu_get_code + Caption = "生成编码" + End + Begin VB.Menu menu_clear + Caption = "清空显示" + End + End + Begin VB.Menu menu_setting + Caption = "设置" + Begin VB.Menu menu_on_top + Caption = "窗口最上" + Checked = -1 'True + End + Begin VB.Menu menu_is_tip + Caption = "输出提示" + Checked = -1 'True + End + Begin VB.Menu menu_skin + Caption = "外观颜色" + Begin VB.Menu skin_white + Caption = "极简白" + End + Begin VB.Menu skin_blue + Caption = "胖次蓝" + End + Begin VB.Menu skin_yellow + Caption = "土豪金" + End + Begin VB.Menu skin_green + Caption = "原谅绿" + End + Begin VB.Menu skin_pink + Caption = "木耳粉" + End + End + End + Begin VB.Menu menu_help + Caption = "帮助" + Begin VB.Menu usage + Caption = "使用说明" + End + Begin VB.Menu update + Caption = "检查更新" + End + Begin VB.Menu about + Caption = "关于" + End + End End Attribute VB_Name = "Form_main" Attribute VB_GlobalNameSpace = False @@ -104,20 +209,145 @@ Dim output As Case_size ' Dim case_main As Case_detail ' 布局信息 Dim exclude(-1 To 1, -1 To 1) As Boolean ' 记录按下位置周围是否能放置棋子 true -> 不难 / false -> 能 Private Sub Form_Load() ' 窗体初始化 + Form_main.Caption = Form_main.Caption & " " & version Call Init_case + Call Get_settings ' 读取上一次的设置 + menu_on_top.Checked = Not on_top: Call menu_on_top_Click + menu_is_tip.Checked = Not is_tip: Call menu_is_tip_Click + If style_color = "white" Then + Call skin_white_Click + ElseIf style_color = "blue" Then + Call skin_blue_Click + ElseIf style_color = "yellow" Then + Call skin_yellow_Click + ElseIf style_color = "green" Then + Call skin_green_Click + ElseIf style_color = "pink" Then + Call skin_pink_Click + Else + Call skin_blue_Click + End If + Call Save_settings ' 保存设置 print_now = False output.start_x = 150 output.start_y = 150 output.gap = 100 output.square_width = 1000 - style.block_line_width = 1 - style.case_line_width = 2 - style.block_line_color = RGB(0, 158, 240) - style.case_line_color = RGB(0, 158, 240) - style.block_color = RGB(225, 245, 255) - style.case_color = RGB(248, 254, 255) Call Output_case(Form_main, case_main, output) ' 显示界面 End Sub +Private Sub ouput_pic_no_code_Click() ' 导出无编码图片 + Call output_pic(False) + MsgBox "图片已保存" +End Sub +Private Sub ouput_pic_with_code_Click() ' 导出带编码图片 + Call output_pic(True) + MsgBox "图片已保存" +End Sub +Private Sub menu_analyse_code_Click() ' 解析编码 + If Try_parse_code(Text_Code) = False Then + MsgBox "编码错误" + Else + Text_Code = UCase(Text_Code) & String(9 - Len(Text_Code), "0") ' 修改为大写并补0 + MsgBox "解析完成" + End If +End Sub +Private Sub menu_get_code_Click() ' 生成编码 + Call Try_get_code + If case_main.kind(0) <> 0 Then + Text_Focus.SetFocus ' 防止文本框光标闪烁 + MsgBox "2 * 2块未确定" + Text_Code.ForeColor = vbBlack + Text_Code = "---" + Else + Text_Code = Text_Code & String(9 - Len(Text_Code), "0") ' 补0 + Text_Code.ForeColor = vbBlack + MsgBox "编码：" & Text_Code + End If +End Sub +Private Sub menu_clear_Click() ' 清空显示 + Call Command_Clear_Click + Text_Code = "---" +End Sub +Private Sub menu_on_top_Click() ' 是否出口最上 + menu_on_top.Checked = Not menu_on_top.Checked + on_top = menu_on_top.Checked + If on_top = True Then + SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 1 Or 2 + Else + SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 1 Or 2 + End If + Call Save_settings +End Sub +Private Sub menu_is_tip_Click() ' 是否显示提示 + menu_is_tip.Checked = Not menu_is_tip.Checked + is_tip = menu_is_tip.Checked + Call Save_settings +End Sub +Private Sub skin_white_Click() ' 白色皮肤 + Call skin_empty + skin_white.Checked = True + style_color = "white" + Call load_skin(white_style) +End Sub +Private Sub skin_blue_Click() ' 蓝色皮肤 + Call skin_empty + skin_blue.Checked = True + style_color = "blue" + Call load_skin(blue_style) +End Sub +Private Sub skin_yellow_Click() ' 黄色皮肤 + Call skin_empty + skin_yellow.Checked = True + style_color = "yellow" + Call load_skin(yellow_style) +End Sub +Private Sub skin_green_Click() ' 绿色皮肤 + Call skin_empty + skin_green.Checked = True + style_color = "green" + Call load_skin(green_style) +End Sub +Private Sub skin_pink_Click() ' 粉色皮肤 + Call skin_empty + skin_pink.Checked = True + style_color = "pink" + Call load_skin(pink_style) +End Sub +Private Sub skin_empty() ' 清除所有皮肤项勾选 + skin_white.Checked = False + skin_blue.Checked = False + skin_yellow.Checked = False + skin_green.Checked = False + skin_pink.Checked = False +End Sub +Private Sub load_skin(new_style As Case_style) ' 载入皮肤 + style.block_line_width = new_style.block_line_width + style.case_line_width = new_style.case_line_width + style.block_line_color = new_style.block_line_color + style.case_line_color = new_style.case_line_color + style.block_color = new_style.block_color + style.case_color = new_style.case_color + Call Output_case(Form_main, case_main, output) + Call Save_settings +End Sub +Private Sub usage_click() ' 使用说明 + Dim usage_data As String + usage_data = usage_data & "· 鼠标拖拽画出棋子" & vbCrLf + usage_data = usage_data & "· 单击删除棋子" & vbCrLf + usage_data = usage_data & "· 输入编码自动生成布局" & vbCrLf + usage_data = usage_data & "· 双击文本框可清空内容" & vbCrLf + usage_data = usage_data & "· 清除按钮可清空上方内容" & vbCrLf + usage_data = usage_data & "· 完成按钮可补0生成九位编码" & vbCrLf + usage_data = usage_data & "· 空白处右键可导出无编码图片" & vbCrLf + usage_data = usage_data & "· 空白处点击滚轮可导出带编码图片" & vbCrLf + MsgBox usage_data, , "使用说明" +End Sub +Private Sub update_Click() ' 检查更新 + Call Check_update +End Sub +Private Sub about_Click() ' 关于 + MsgBox "HRD Visual：华容道编码可视化工具" & vbCrLf & " 版本：" & version & " (by Dnomd343)", , "关于" +End Sub Private Sub Command_Clear_Click() ' 清除当前显示 Call Init_case Call Output_case(Form_main, case_main, output) ' 刷新显示界面 @@ -153,6 +383,26 @@ Private Sub Text_Code_KeyPress(KeyAscii As Integer) ' Timer_KeyPress.Enabled = True End If End Sub +Private Sub output_pic(with_code As Boolean) ' 导出图片 可选择带不带编码 + Picture_Print.Width = output.start_x * 2 + output.square_width * 4 + output.gap * 5 ' 设置图片大小 + Picture_Print.Height = output.start_y * 2 + output.square_width * 5 + output.gap * 6 + If with_code = True Then Picture_Print.Height = Picture_Print.Height + 1000 + Picture_Print.Cls + Picture_Print.BackColor = vbWhite + If with_code = True Then + Picture_Print.FontSize = 36 + Picture_Print.CurrentX = (Picture_Print.Width - Get_str_width(Text_Code)) / 2 ' 设置输出编码文字的位置 + Picture_Print.CurrentY = output.start_y * 2 + output.square_width * 5 + output.gap * 6 + Picture_Print.Print Text_Code + End If + Call Output_case(Picture_Print, case_main, output) ' 显示布局 + SavePicture Picture_Print.Image, Text_Code & ".bmp" ' 保存图片 +End Sub +Private Function Get_str_width(str As String) As Integer ' 获取字符串显示时的宽度 + Label_Print.FontSize = Picture_Print.FontSize + Label_Print = str ' 载入到Label中 利用自动大小计算 + Get_str_width = Label_Print.Width +End Function Private Function Try_parse_code(code As String) As Boolean ' 尝试解码 Dim i As Integer, dat As String, flag As Boolean If Len(code) > 9 Then Try_parse_code = False: Exit Function ' 输入超9位 退出 @@ -196,10 +446,10 @@ Private Sub Timer_KeyPress_Timer() Timer_KeyPress.Enabled = False End Sub Private Sub Show_tip(tip_data As String) ' 显示提示 1.2s后消失 + If is_tip = False Then Exit Sub Timer_Tip.Enabled = False ' 防止闪烁 Label_Tip = tip_data Label_Tip.ForeColor = style.block_line_color - Label_Tip.BackColor = style.block_color Label_Tip.Top = (Form_main.Height - Label_Tip.Height) / 2 - 480 Label_Tip.Left = (Form_main.Width - Label_Tip.Width) / 2 - 60 Label_Tip.Visible = True @@ -211,6 +461,7 @@ Private Sub Timer_Tip_Timer() End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) ' 按下鼠标按键 Text_Focus.SetFocus + If Button <> 1 Then Exit Sub Dim x_ As Integer, y_ As Integer, num As Integer Dim raw_x As Single, raw_y As Single Dim addr_x As Integer, addr_y As Integer @@ -240,6 +491,7 @@ Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y A If clear = True Then ' 若被标识为点击在棋子上 Call Clear_block(num) ' 清除该棋子 Call Output_case(Form_main, case_main, output) ' 刷新显示界面 + Text_Code.ForeColor = vbBlack Text_Code = "---" Call Try_get_code Exit Sub ' 退出 @@ -305,11 +557,20 @@ Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y A Call Print_Block(Form_main, print_x, print_y, print_width, print_height, style.block_line_width, style.block_color, style.block_line_color) ' 绘制 End Sub Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) ' 释放鼠标按键 + If Button = 2 Or Button = 4 Then ' 如果按下滚轮或右键 + If Text_Code.ForeColor = vbRed Then Show_tip ("编码有问题哦"): Exit Sub + If Button = 2 Then Call output_pic(False) ' 按下右键 不带编码 + If Button = 4 Then Call output_pic(True) ' 按下滚轮 带编码 + Call Show_tip("图片已保存") + Exit Sub + End If Dim i As Integer, j As Integer, num As Integer Dim block_x As Integer, block_y As Integer Dim block_width As Integer, block_height As Integer If print_now = False Then Exit Sub ' 判断是否在绘制模式 print_now = False ' 退出绘制模式 + Text_Code.ForeColor = vbBlack + If case_main.kind(0) <> 0 Then Text_Code = "---" block_x = min(click_x, mouse_x) - 1 ' 计算绘制棋子的起始位置 block_y = min(click_y, mouse_y) - 1 block_width = Abs(click_x - mouse_x) + 1 ' 计算绘制棋子的宽和高 diff --git a/src/visual/HRD_Visual.vbp b/src/visual/HRD_Visual.vbp index b6ad3ca..98c7de8 100644 --- a/src/visual/HRD_Visual.vbp +++ b/src/visual/HRD_Visual.vbp @@ -1,7 +1,9 @@ Type=Exe Form=Form_main.frm Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\..\Windows\SysWOW64\stdole2.tlb#OLE Automation -Module=Module; Module.bas +Module=Module_hrd; Module_hrd.bas +Module=Module_main; Module_main.bas +Module=Module_update; Module_update.bas IconForm="Form_main" Startup="Sub Main" HelpFile="" @@ -12,7 +14,7 @@ Name="HRD_Visual" HelpContextID="0" CompatibleMode="0" MajorVer=1 -MinorVer=0 +MinorVer=2 RevisionVer=0 AutoIncrementVer=0 ServerSupportFiles=0 diff --git a/src/visual/HRD_Visual.vbw b/src/visual/HRD_Visual.vbw index 6bf6150..122950c 100644 --- a/src/visual/HRD_Visual.vbw +++ b/src/visual/HRD_Visual.vbw @@ -1,2 +1,4 @@ Form_main = 52, 52, 810, 479, , 26, 26, 784, 453, C -Module = 134, 45, 892, 472, +Module_hrd = 134, 45, 892, 472, +Module_main = 0, 0, 755, 427, +Module_update = 130, 130, 885, 557, Z diff --git a/src/visual/Module.bas b/src/visual/Module_hrd.bas similarity index 91% rename from src/visual/Module.bas rename to src/visual/Module_hrd.bas index 6dd0542..5aaccb2 100644 --- a/src/visual/Module.bas +++ b/src/visual/Module_hrd.bas @@ -1,29 +1,11 @@ -Attribute VB_Name = "Module" +Attribute VB_Name = "Module_hrd" Option Explicit Type Case_detail status(0 To 3, 0 To 4) As Integer ' 255 -> undefined ; 254 -> space kind(0 To 14) As Integer ' 0 -> 2 * 2 ; 1 -> 2 * 1 ; 2 -> 1 * 2 ; 3 -> 1 * 1 code As String ' length -> 9 End Type -Type Case_size ' 记录棋盘的大小 - start_x As Integer - start_y As Integer - square_width As Integer - gap As Integer -End Type -Type Case_style ' 记录显示的颜色与边框粗细 - block_line_width As Integer - case_line_width As Integer - block_line_color As OLE_COLOR - case_line_color As OLE_COLOR - block_color As OLE_COLOR - case_color As OLE_COLOR -End Type Public Parse_data As Case_detail ' 解析编码的返回数据 -Public style As Case_style ' 通用显示样式 -Sub main() ' 程序入口 - Form_main.Show -End Sub Public Sub Output_case(obj, case_data As Case_detail, case_output As Case_size) ' 将输入的布局显示到obj上 Dim i As Integer, x As Integer, y As Integer Dim block_type As Integer @@ -77,7 +59,7 @@ Public Sub Print_Block(obj, print_start_x, print_start_y, print_width, print_hei End Sub Function change_str(dat As Integer) As String ' 输入一个十六进制位 转化为字符串返回 If dat <= 9 And dat >= 0 Then - change_str = Str(dat) + change_str = str(dat) ElseIf dat >= 10 And dat <= 15 Then change_str = Chr(dat + 55) Else diff --git a/src/visual/Module_main.bas b/src/visual/Module_main.bas new file mode 100644 index 0000000..1c253f6 --- /dev/null +++ b/src/visual/Module_main.bas @@ -0,0 +1,87 @@ +Attribute VB_Name = "Module_main" +Option Explicit +Type Case_size ' 记录棋盘的大小 + start_x As Integer + start_y As Integer + square_width As Integer + gap As Integer +End Type +Type Case_style ' 记录显示的颜色与边框粗细 + block_line_width As Integer + case_line_width As Integer + block_line_color As OLE_COLOR + case_line_color As OLE_COLOR + block_color As OLE_COLOR + case_color As OLE_COLOR +End Type +Public version As String +Public white_style As Case_style +Public blue_style As Case_style +Public yellow_style As Case_style +Public green_style As Case_style +Public pink_style As Case_style +Public style As Case_style ' 通用显示样式 +Public on_top As Boolean, is_tip As Boolean, style_color As String +Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long +Private Sub init_style() ' 预置配色 + 'skin_white + white_style.block_line_width = 1 + white_style.case_line_width = 2 + white_style.block_line_color = RGB(0, 0, 0) + white_style.case_line_color = RGB(0, 0, 0) + white_style.block_color = RGB(250, 250, 250) + white_style.case_color = RGB(256, 256, 256) + 'skin_blue + blue_style.block_line_width = 1 + blue_style.case_line_width = 2 + blue_style.block_line_color = RGB(0, 158, 240) + blue_style.case_line_color = RGB(0, 158, 240) + blue_style.block_color = RGB(225, 245, 255) + blue_style.case_color = RGB(248, 254, 255) + 'skin_yellow + yellow_style.block_line_width = 1 + yellow_style.case_line_width = 2 + yellow_style.block_line_color = RGB(153, 0, 0) + yellow_style.case_line_color = RGB(149, 149, 149) + yellow_style.block_color = RGB(255, 215, 0) + yellow_style.case_color = RGB(231, 231, 231) + 'skin_green + green_style.block_line_width = 1 + green_style.case_line_width = 2 + green_style.block_line_color = RGB(61, 184, 78) + green_style.case_line_color = RGB(46, 118, 72) + green_style.block_color = RGB(61, 184, 78) + green_style.case_color = RGB(233, 247, 212) + 'skin_pink + pink_style.block_line_width = 1 + pink_style.case_line_width = 2 + pink_style.block_line_color = RGB(220, 20, 60) + pink_style.case_line_color = RGB(255, 20, 147) + pink_style.block_color = RGB(255, 192, 203) + pink_style.case_color = RGB(255, 240, 245) +End Sub +Public Sub Get_settings() ' 从注册表获取上一次的设置 + On Error GoTo first_time ' 出错表明注册表键值不存在 + Dim ws + Set ws = CreateObject("Wscript.Shell") + If ws.RegRead("HKEY_CURRENT_USER\Software\HRD_Visual\on_top") = "False" Then on_top = False Else on_top = True + If ws.RegRead("HKEY_CURRENT_USER\Software\HRD_Visual\is_tip") = "False" Then is_tip = False Else is_tip = True + style_color = ws.RegRead("HKEY_CURRENT_USER\Software\HRD_Visual\skin") + Exit Sub +first_time: ' 第一次设置 + on_top = True + is_tip = True + style_color = "blue" +End Sub +Public Sub Save_settings() ' 保存设置到注册表 + Dim ws + Set ws = CreateObject("Wscript.Shell") + ws.RegWrite "HKEY_CURRENT_USER\Software\HRD_Visual\on_top", Trim(on_top), "REG_SZ" + ws.RegWrite "HKEY_CURRENT_USER\Software\HRD_Visual\is_tip", Trim(is_tip), "REG_SZ" + ws.RegWrite "HKEY_CURRENT_USER\Software\HRD_Visual\skin", style_color, "REG_SZ" +End Sub +Sub Main() ' 程序入口 + version = "v1.2" + Call init_style + Form_main.Show +End Sub diff --git a/src/visual/Module_update.bas b/src/visual/Module_update.bas new file mode 100644 index 0000000..db51991 --- /dev/null +++ b/src/visual/Module_update.bas @@ -0,0 +1,86 @@ +Attribute VB_Name = "Module_update" +Option Explicit +Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long +Dim update_version As String +Dim update_file_name As String +Dim update_url As String +Dim update_detail As String +Dim my_file_name As String +Private Sub Get_update_information() ' 从服务器返回数据中提取更新信息 + Dim str As String + update_detail = "" + Open "update.txt" For Input As #1 + Line Input #1, str ' version + Line Input #1, str + update_version = str + Line Input #1, str ' file_name + Line Input #1, str + update_file_name = str + Line Input #1, str ' url + Line Input #1, str + update_url = str + Line Input #1, str ' detail + Do While Not EOF(1) + Line Input #1, str + If Left(str, 1) = "[" Then GoTo out + update_detail = update_detail & str & vbCrLf + Loop +out: + Close #1 +End Sub +Private Sub Create_update_shell() ' 创建用于更新的vbs脚本 + my_file_name = App.EXEName & ".exe" + Open "update.vbs" For Output As #1 + Print #1, "Set ws = CreateObject(""Wscript.Shell"")" + Print #1, "Set fso = CreateObject(""Scripting.FileSystemObject"")" + Print #1, "ws.Run ""taskkill /f /im " & my_file_name & """, 0" + Print #1, "Wscript.sleep 2000" + Print #1, "fso.GetFile(""" & my_file_name & """).Attributes = 0" + Print #1, "fso.DeleteFile (""" & my_file_name & """)" + Print #1, "fso.MoveFile """ & update_file_name & """, """ & my_file_name & """" + Print #1, "msgbox ""更新完成"",, ""提示" & """" + Print #1, "Wscript.sleep 2000" + Print #1, "ws.Run """ & my_file_name & """, 9" + Print #1, "fso.DeleteFile(""update.vbs"")" + Print #1, "fso.DeleteFile (""" & my_file_name & "-bak" & """)" + Close #1 + SetAttr "update.vbs", vbHidden +End Sub +Public Sub Delete_file(file_name As String) ' 删除文件 自动规避错误 + If Check_file(file_name) = True Then + SetAttr file_name, 0 + Kill file_name + End If +End Sub +Public Function Download_file(url As String, file_name As String) As Boolean ' 下载文件 成功返回true 错误返回false + If URLDownloadToFile(0, url, file_name, 0, 0) = 0 Then + Download_file = True + Else + Download_file = False + End If +End Function +Public Function Check_file(file_name As String) As Boolean ' 判断文件是否存在 + If Dir(file_name, vbNormal Or vbHidden Or vbReadOnly Or vbSystem) <> "" Then ' 如果文件存在 + Check_file = True + Else + Check_file = False + End If +End Function +Public Sub Check_update() ' 检查更新 + Call Delete_file("update.txt") + Call Delete_file("update.vbs") + If Not Download_file("https://hrd.dnomd343.top/update/HRD_Visual", "update.txt") Then MsgBox "连接服务器失败", , "检查更新": Exit Sub + If Check_file("update.txt") = False Then MsgBox "更新失败", , "检查更新": Exit Sub + Call Get_update_information + Call Delete_file("update.txt") + If update_version = version Then MsgBox "当前已是最新版本", , "检查更新": Exit Sub + If MsgBox("检查到新版本：" & update_version & vbCrLf & vbCrLf & "更新特性" & vbCrLf & update_detail & vbCrLf & "是否更新？", vbYesNo, "检查更新") = vbNo Then Exit Sub + If Not Download_file(update_url, update_file_name) Then MsgBox "下载更新文件失败", , "检查更新": Exit Sub + If Check_file(update_file_name) = False Then MsgBox "下载发生错误", , "检查更新": Exit Sub + Call Create_update_shell + If Check_file("update.vbs") = False Then MsgBox "发生未知错误", , "检查更新": Exit Sub + Call Delete_file(App.EXEName & ".exe-bak") + FileCopy App.EXEName & ".exe", App.EXEName & ".exe-bak" + SetAttr App.EXEName & ".exe-bak", vbHidden + Shell "cmd.exe /c ""update.vbs""", vbHide +End Sub