📄 整点报时.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{BA15ACB6-8B32-4ABF-AD1E-FA042F275322}#1.0#0"; "VsMenu.ocx"
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "整点报时"
ClientHeight = 750
ClientLeft = 150
ClientTop = 720
ClientWidth = 4680
Icon = "整点报时.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 750
ScaleWidth = 4680
StartUpPosition = 3 '窗口缺省
Begin VsMenu.ctxVsMenu ctxVsMenu1
Left = 480
Top = 120
_ExtentX = 900
_ExtentY = 900
BmpCount = 0
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
DrawStyle = 2
MenuDrawStyle = 2
UserSelectedMenuBackColour= 65408
UserSelectedMenuBorderColour= 8388863
UserTopMenuBackColour= 65280
UserTopMenuSelectedColour= 12632256
UserTopMenuHotColour= 12632256
UserTopMenuHotBorderColour= 16711808
UserMenuBorderColour= 16711680
UserCheckBackColour= 12632256
UserCheckBorderColour= 12632256
UserGradientOne = 8388736
UserGradientTwo = 16777215
UserUseGradient = -1 'True
UserSelectedItemForeColour= 255
UserSideBarColour= 12632256
End
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 375
Left = 120
TabIndex = 0
Top = 240
Width = 4455
_ExtentX = 7858
_ExtentY = 661
_Version = 393216
Appearance = 1
Scrolling = 1
End
Begin VB.Timer Timer1
Interval = 1000
Left = 1800
Top = 240
End
Begin VB.Timer Timer3
Interval = 1000
Left = 2400
Top = 240
End
Begin VB.Label Label2
AutoSize = -1 'True
Height = 180
Left = 2280
TabIndex = 2
Top = 720
Width = 90
End
Begin VB.Label Label1
AutoSize = -1 'True
Height = 180
Left = 120
TabIndex = 1
Top = 0
Width = 90
End
Begin VB.Menu index
Caption = "主菜单 "
Begin VB.Menu mnutimeclose
Caption = "定时关机"
End
Begin VB.Menu mnuclose
Caption = "关机"
End
Begin VB.Menu mnureboot
Caption = "重启"
End
Begin VB.Menu mnuxiao
Caption = "注销"
End
Begin VB.Menu mnubar1
Caption = "-"
End
Begin VB.Menu mnucleandisk
Caption = "清理磁盘"
End
Begin VB.Menu mnukeybroad
Caption = "屏幕键盘"
End
Begin VB.Menu mnuclock
Caption = "定时闹钟"
End
Begin VB.Menu mnuexplorer
Caption = "打开资源管理器"
End
Begin VB.Menu mnubar2
Caption = "-"
End
Begin VB.Menu mnureg
Caption = "备份注册表"
End
Begin VB.Menu mnubakcreg
Caption = "还原注册表"
End
Begin VB.Menu mnubar3
Caption = "-"
End
Begin VB.Menu mnuopendoor
Caption = "打开光驱"
End
Begin VB.Menu mnuclosedoor
Caption = "关闭光驱"
End
Begin VB.Menu mnubar4
Caption = "-"
End
Begin VB.Menu mnuabout
Caption = "关于"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Download by http://www.codefans.net
'定义时、分秒
Dim hh As Integer, mm As Integer, ss As Integer
'定义年、日
Dim yy As Long, dd As Integer
Dim RegBackupMarking As Boolean
Private Sub Form_Load()
Me.Icon = LoadResPicture(102, vbResIcon)
On Error Resume Next
'让程序在不同地点只能运行一次
'用此程序段的原因：因为App.PrevInstance 只能影响同目录的同一程序
'但不能影响其它目录的同一程序。
'--------------------------------------------------------------
Dim MdiMenuHwnd As Long
Dim hMenu As Long
Dim Semaphore As String, Sema As Long, Security As SECURITY_ATTRIBUTES
Dim PrevSemaphore As Long, Turn As Long
Security.bInheritHandle = True
'默认的安全值
Security.lpSecurityDescriptor = 0
Security.nLength = Len(Security)
Semaphore = "整点报时"
'创建或打开一个Semaphore记数信号，设资源空闲使用量为1
Sema = CreateSemaphore(Security, 1, 1, Semaphore)
'申请一个权限，并立即返回
Turn = WaitForSingleObject(Sema, 0)
'如果不是正常返回，则表示没有申请到资源的使用权限
If Turn <> 0 Then
MsgBox "整点报时已经在运行了！", vbExclamation Or vbOKOnly, Me.Caption
End
End If
'--------------------------------------------------------------
nfIconData.hwnd = Me.hwnd
nfIconData.uID = Me.Icon
nfIconData.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
nfIconData.uCallbackMessage = WM_TRAYICON
nfIconData.hIcon = Me.Icon.Handle
nfIconData.szTip = App.Title + "(版本 " & App.Major & "." & App.Minor & "." & App.Revision & ")" & vbNullChar
nfIconData.cbSize = Len(nfIconData)
Shell_NotifyIcon NIM_ADD, nfIconData
pWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf WndProc)
App.TaskVisible = False
'设置自启动
Dim hKey As Long, retu As Long
'打开注册表项
RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", hKey
'设置自启动项目
retu = RegSetValueEx(hKey, "整点报时", 0, REG_SZ, ByVal CheckFilePath(App.Path) & "整点报时.exe", LenB(StrConv(CheckFilePath(App.Path) & "整点报时.exe", vbFromUnicode)) + 1)
RegCloseKey hKey
ProgressBar1.Visible = False
'使标签2处于进度条的中间
Label2.Move (ProgressBar1.Width - Label2.Width) / 2
'屏蔽关闭按钮和菜单
'第一个是删除关闭菜单并使关闭按钮变灰
MdiMenuHwnd = GetSystemMenu(Me.hwnd, False)
hMenu = GetMenuItemCount(MdiMenuHwnd)
DeleteMenu MdiMenuHwnd, hMenu - 1, MF_BYPOSITION
'这个是删除菜单分界线
MdiMenuHwnd = GetSystemMenu(Me.hwnd, False)
hMenu = GetMenuItemCount(MdiMenuHwnd)
DeleteMenu MdiMenuHwnd, hMenu - 1, MF_BYPOSITION
'这个是删除菜单分界线
hMenu = GetMenuItemCount(MdiMenuHwnd)
DeleteMenu MdiMenuHwnd, hMenu - 1, MF_BYPOSITION
Timer3.Enabled = False
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
Shell_NotifyIcon NIM_DELETE, nfIconData
pWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf WndProc)
End Sub
Private Sub mnuabout_Click()
FrmAbout.Show 0
End Sub
Private Sub mnubakcreg_Click()
On Error Resume Next
RegBackupMarking = False '表示正在还原的标志
If Dir("注册表备份.cab") = vbNullString Then
MsgBox "没有找到您备份的注册表。", vbOKOnly, "还原注册表"
Else
'还原注册表，没有提示且立即生效,首先解压缩
ProgressBar1.Value = 0
Me.Show
ProgressBar1.Visible = True
Timer3.Enabled = True
index.Visible = False
Me.MousePointer = 11
Label1.Caption = "注册表正在解压缩，请稍候......"
DoEvents
iw1.Run "Cabarc.exe -p x 注册表备份.cab", vbHide, True
Label1.Caption = "注册表正在还原，请稍候......"
iw1.Run "regedit.exe /s RegBackup.reg", vbHide, True
ProgressBar1.Value = 100
Label2.Caption = "100%"
Label1.Caption = "注册表还原成功"
Label2.Caption = "100%"
Me.MousePointer = 0
Timer3.Enabled = False
MsgBox "注册表还原成功", vbInformation, "提示"
Me.Hide
ProgressBar1.Visible = False
index.Visible = True
Kill CheckFilePath(App.Path) & "*.reg"
End If
End Sub
Private Sub mnucleandisk_Click()
On Error Resume Next
Shell iw1.SpecialFolders("AppData") & "\整点报时\磁盘清理.exe", vbNormalFocus
End Sub
Private Sub mnuclock_Click()
FrmClock.Show
End Sub
Private Sub mnuclose_Click()
On Error Resume Next
Shell Sound.GetWinSys() & "\shutdown.exe -s -t 0"
End Sub
Private Sub mnuclosedoor_Click()
On Error Resume Next
mciSendString "set cdaudio door closed", vbNullString, 0, 0
End Sub
Private Sub mnuexplorer_Click()
On Error Resume Next
Shell Environ$("windir") & "\explorer.exe /e,", vbNormalFocus
End Sub
Private Sub mnukeybroad_Click()
On Error Resume Next
Shell Sound.GetWinSys() & "\osk.exe", vbMinimizedFocus
End Sub
Private Sub mnuopendoor_Click()
On Error Resume Next
mciSendString "set cdaudio door open", vbNullString, 0, 0
End Sub
Private Sub mnureboot_Click()
On Error Resume Next
Shell Sound.GetWinSys() & "\shutdown.exe -r -t 0"
End Sub
Private Sub mnureg_Click()
On Error Resume Next
RegBackupMarking = True '表示正在备份的标志
If Dir("注册表备份.cab") <> vbNullString Then
Kill App.Path & "注册表备份.cab"
End If
Me.Show
Timer3.Enabled = True
ProgressBar1.Visible = True
ProgressBar1.Value = 0
index.Visible = False
Me.MousePointer = 11
Label1.Caption = "注册表正在备份，请稍候......"
DoEvents
iw1.Run "regedit.exe /e RegBackup.reg", vbHide, True
'说明：带 -p 连同文件夹一起压缩，否则只压缩文件,-p加在n之前
Label1.Caption = "注册表正在压缩，请稍候......"
iw1.Run "Cabarc.exe -p n 注册表备份.cab *.reg", vbHide, True
ProgressBar1.Value = 100
Label1.Caption = "注册表备份完毕"
Label2.Caption = "100%"
Timer3.Enabled = False
Me.MousePointer = 0
If Dir("注册表备份.cab") <> vbNullString Then
MsgBox "注册表备份成功", vbOKOnly, "注册表备份"
Me.Hide
ProgressBar1.Visible = False
index.Visible = True
End If
Kill CheckFilePath(App.Path) & "*.reg"
End Sub
Private Sub mnutimeclose_Click()
On Error GoTo err100
If mnutimeclose.Caption = "定时关机" Then
mnutimeclose.Caption = "取消定时关机"
Dim xx As Single
xx = InputBox("请输入时间,1表示一个小时、0.5表示半个小时", "关机时间/小时", 1)
If xx <= 0 Then
xx = InputBox("请重新输入时间,1表示一个小时、0.5表示半个小时", "关机时间", 1)
mnutimeclose_Click
End If
xx = xx * 3600
Shell Sound.GetWinSys() & "\shutdown.exe -s -t " & xx
Else
Shell Sound.GetWinSys() & "\shutdown.exe -a"
mnutimeclose.Caption = "定时关机"
End If
err100:
End Sub
Private Sub mnuxiao_Click()
On Error Resume Next
Shell Sound.GetWinSys() & "\shutdown.exe -l -t 0"
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
If Right(CStr(Format(Now, "hh:mm:ss")), 5) = "00:00" Then
Select Case Format(Now, "hh")
Case 0
Sound.PlayWaveRes "00" '调用PlayWaveRes函数播放声音
Case 1
Sound.PlayWaveRes "01"
Case 2
Sound.PlayWaveRes "02"
Case 3
Sound.PlayWaveRes "03"
Case 4
Sound.PlayWaveRes "04"
Case 5
Sound.PlayWaveRes "05"
Case 6
Sound.PlayWaveRes "06"
Case 7
Sound.PlayWaveRes "07"
Case 8
Sound.PlayWaveRes "08"
Case 9
Sound.PlayWaveRes "09"
Case 10
Sound.PlayWaveRes "10"
Case 11
Sound.PlayWaveRes "11"
Case 12
Sound.PlayWaveRes "12"
Case 13
Sound.PlayWaveRes "13"
Case 14
Sound.PlayWaveRes "14"
Case 15
Sound.PlayWaveRes "15"
Case 16
Sound.PlayWaveRes "16"
Case 17
Sound.PlayWaveRes "17"
Case 18
Sound.PlayWaveRes "18"
Case 19
Sound.PlayWaveRes "19"
Case 20
Sound.PlayWaveRes "20"
Case 21
Sound.PlayWaveRes "21"
Case 22
Sound.PlayWaveRes "22"
Case 23
Sound.PlayWaveRes "23"
End Select
End If
End Sub
Function CheckFilePath(FilePath As String) As String
'存、读档时对文件路径的检查
If Right$(FilePath, 1) = "\" Then
CheckFilePath = FilePath
Else
CheckFilePath = FilePath & "\"
End If
End Function
Private Sub Timer3_Timer()
Select Case RegBackupMarking
Case True
If ProgressBar1.Value <> 100 Then
ProgressBar1.Value = ProgressBar1.Value + 1
Label2.Caption = ProgressBar1.Value & "%"
End If
Case False
If ProgressBar1.Value <> 100 Then
ProgressBar1.Value = ProgressBar1.Value + 1
Label2.Caption = ProgressBar1.Value & "%"
End If
End Select
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -