Dnomd343
4 years ago
6 changed files with 452 additions and 32 deletions
@ -1,2 +1,4 @@ |
|||||
Form_main = 52, 52, 810, 479, , 26, 26, 784, 453, C |
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 |
||||
|
|||||
@ -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 |
||||
@ -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 |
||||
Loading…
Reference in new issue