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 |
|||
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