📄 back.frm
字号:
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{69958DD9-23E5-11D6-ACD7-0050BAC05F28}#8.0#0"; "CurtButton.ocx"
Begin VB.Form Back
BorderStyle = 1 'Fixed Single
Caption = "Back"
ClientHeight = 2910
ClientLeft = 45
ClientTop = 435
ClientWidth = 6120
Icon = "Back.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 2910
ScaleWidth = 6120
StartUpPosition = 2 '屏幕中心
Begin MSComCtl2.MonthView RQ
Height = 2220
Left = 120
TabIndex = 0
Top = 120
Width = 4065
_ExtentX = 7170
_ExtentY = 3916
_Version = 393216
ForeColor = -2147483630
BackColor = -2147483633
Appearance = 1
StartOfWeek = 25493505
CurrentDate = 39531
End
Begin VB.ListBox LB
Height = 690
Left = 4320
Style = 1 'Checkbox
TabIndex = 9
Top = 360
Width = 1695
End
Begin VB.Frame Frame1
Height = 570
Left = 120
TabIndex = 4
Top = 2280
Width = 3735
Begin VB.ComboBox MS
Height = 300
ItemData = "Back.frx":08CA
Left = 2280
List = "Back.frx":08D4
Style = 2 'Dropdown List
TabIndex = 6
Top = 180
Width = 1095
End
Begin MSComCtl2.DTPicker SJ
Height = 300
Left = 600
TabIndex = 7
Top = 180
Width = 1095
_ExtentX = 1931
_ExtentY = 529
_Version = 393216
Format = 25493506
UpDown = -1 'True
CurrentDate = 39532.4166666667
End
Begin CurtButton多风格按钮控件.CurtButton TG
Height = 300
Left = 3390
TabIndex = 10
Top = 180
Width = 300
_ExtentX = 529
_ExtentY = 529
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "Back.frx":08F0
Caption = "+"
Appearance = 3
HoverColor = -2147483633
MouseDownColor = -2147483634
EdgeColor = -2147483635
ShadowColor = 16761024
BorderColor = -2147483635
Alignment = 9
HoverFillStyle = 2
End
Begin VB.Label Label2
Caption = "时间:"
Height = 255
Left = 120
TabIndex = 8
Top = 240
Width = 495
End
Begin VB.Label Label1
Caption = "模式:"
Height = 255
Left = 1800
TabIndex = 5
Top = 240
Width = 495
End
End
Begin VB.FileListBox WJ
Height = 990
Left = 4320
Pattern = "*.dat"
TabIndex = 3
Top = 1350
Width = 1695
End
Begin VB.Timer JS
Interval = 900
Left = 120
Top = 2400
End
Begin CurtButton多风格按钮控件.CurtButton BF
Height = 420
Left = 3960
TabIndex = 1
Top = 2400
Width = 960
_ExtentX = 1693
_ExtentY = 741
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "Back.frx":090C
Caption = "备份(&B)"
Appearance = 3
HoverColor = -2147483633
MouseDownColor = -2147483634
EdgeColor = -2147483635
ShadowColor = 16761024
BorderColor = -2147483635
Alignment = 9
HoverFillStyle = 2
End
Begin CurtButton多风格按钮控件.CurtButton TC
Height = 420
Left = 5040
TabIndex = 2
Top = 2400
Width = 960
_ExtentX = 1693
_ExtentY = 741
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Picture = "Back.frx":0928
Caption = "退出(&Q)"
Appearance = 3
HoverColor = -2147483633
MouseDownColor = -2147483634
EdgeColor = -2147483635
ShadowColor = 16761024
BorderColor = -2147483635
Alignment = 9
HoverFillStyle = 2
End
Begin VB.Label Label4
Caption = "备份规则:"
Height = 255
Left = 4320
TabIndex = 12
Top = 120
Width = 1695
End
Begin VB.Label Label3
Caption = "备份数据库:"
Height = 255
Left = 4320
TabIndex = 11
Top = 1140
Width = 1245
End
Begin VB.Menu XT
Caption = "系统(&S)"
Visible = 0 'False
Begin VB.Menu BF1
Caption = "备份(&B)"
End
Begin VB.Menu QC1
Caption = "退出(&Q)"
End
End
End
Attribute VB_Name = "Back"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function Shell_NotifyIcon Lib "Shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
'---------- dwMessage可以是以下NIM_ADD、NIM_DELETE、NIM_MODIFY 标识符之一----------
Private Const NIIF_NONE = &H0 '气泡提示类型
Private Const NIIF_WARNING = &H2
Private Const NIIF_ERROR = &H3
Private Const NIIF_INFO = &H1
Private Const NIIF_GUID = &H4
Private Const NIF_MESSAGE = &H1 'NOTIFYICONDATA结构中uFlags的控制信息
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4
Private Const NIF_STATE = &H8
Private Const NIF_INFO = &H10
Private Const NIM_ADD = &H0 '在任务栏中增加一个图标
Private Const NIM_DELETE = &H2 '删除任务栏中的一个图标
Private Const NIM_MODIFY = &H1 '修改任务栏中个图标信息
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDBLCLK = &H203
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_MBUTTONDBLCLK = &H209
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_RBUTTONDBLCLK = &H206
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const SW_RESTORE = 9
Private Const SW_HIDE = 0
'系统托盘类型
Private Type NOTIFYICONDATA
cbSize As Long '该数据结构的大小
hwnd As Long '处理任务栏中图标的窗口句柄
uID As Long '定义的任务栏中图标的标识
uFlags As Long '任务栏图标功能控制，可以是以下值的组合（一般全包括）
' NIF_MESSAGE 表示发送控制消息；
' NIF_ICON表示显示控制栏中的图标；
' NIF_TIP表示任务栏中的图标有动态提示。
uCallbackMessage As Long '任务栏图标通过它与用户程序交换消息，处理该消息的窗口由hWnd决定
hIcon As Long '任务栏中的图标的控制句柄
szTip As String * 128 '图标的提示信息。若要产生气泡提示信息，则一定要128才性，为64则无法生成气泡，其它功能都正常，原因不明
'气泡提示信息部分
dwState As Long
dwStateMask As Long
szInfo As String * 256 '气泡提示内容
uTimeout As Long '气泡提示显示时间
szInfoTitle As String * 64 '气泡提示标题
dwInfoFlags As Long '气泡提示类型，见 NIIF_*** 部分
End Type
'系统托盘变量
Private m_oNotifyIconData As NOTIFYICONDATA
Dim Lj(3) As String
Dim MC(3) As String
Dim ID As Long
Private Sub BF_Click()
For I = 1 To 3
SetXX "正在复制第" & I & "个数据库：" & Lj(I) & "\data.dat"
CopyN Lj(I) & "\data.dat", Lj(0) & "\data.dat"
SetXX "正在压缩" & I & "数据库：" & Lj(0) & "\" & MC(I) & Format(Now, "(mmdd)") & WJ.ListCount + 1 & "……"
DBEngine.CompactDatabase Lj(0) & "\data.dat", Lj(0) & "\" & MC(I) & Format(Now, "(mmdd)") & WJ.ListCount + 1 & ".dat", , , ";pwd=CWJ6921505016218"
SetXX "正在删除旧数据库……"
Kill Lj(0) & "\data.dat"
WJ.Refresh
Next
SetXX "完成数据库备份……"
End Sub
Private Sub BF1_Click()
BF_Click
End Sub
Private Sub Form_Load()
Lj(0) = "D:\back"
Lj(1) = "\\192.168.1.2\data$\NewData"
Lj(2) = "\\192.168.1.2\data$\GZ"
Lj(3) = "\\192.168.1.2\data$\JW"
MC(1) = "公司"
MC(2) = "广州"
MC(3) = "金娃"
Dim Fso As New FileSystemObject
If Not Fso.FolderExists("D:\Back") Then
Fso.CreateFolder ("D:\Back")
SetAttr "D:\Back", vbSystem + vbHidden
End If
RQ.Value = Now
WJ.FileName = "D:\Back"
WJ.Pattern = "*" & Format(RQ.Value, "mmdd") & "*.dat"
MS.ListIndex = 0
LB_SX
With m_oNotifyIconData
.hwnd = Me.hwnd
.uID = Me.Icon
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP Or NIF_INFO
.uCallbackMessage = WM_MOUSEMOVE
.uCallbackMessage = WM_LBUTTONDOWN
.hIcon = Me.Icon.Handle
.szTip = App.Title + "(版本 " & App.Major & "." & App.Minor & "." & App.Revision & ")" & vbNullChar
.cbSize = Len(m_oNotifyIconData)
End With
'Me.Hide
Call Shell_NotifyIcon(NIM_ADD, m_oNotifyIconData)
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lMsg As Single
lMsg = X / Screen.TwipsPerPixelX
Select Case lMsg
Case WM_LBUTTONUP
'单击左键，显示窗体
ShowWindow Me.hwnd, SW_RESTORE
'下面两句的目的是把窗口显示在窗口最顶层
Me.Show
Me.SetFocus
Call Shell_NotifyIcon(NIM_DELETE, m_oNotifyIconData)
Case WM_RBUTTONUP
PopupMenu XT '如果是在系统Tray图标上点右键，则弹出菜单MenuTray
'' Case WM_MOUSEMOVE
'' Case WM_LBUTTONDOWN
'' Case WM_LBUTTONDBLCLK
'' Case WM_RBUTTONDOWN
'' Case WM_RBUTTONDBLCLK
'' Case Else
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Select Case UnloadMode
Case vbFormControlMenu
Outbox = MsgBox("您确定要退出备份程序吗？", vbQuestion + vbYesNo, "提示")
If Outbox = vbNo Then Cancel = True Else Cancel = False
End Select
End Sub
Private Sub Form_Resize()
Select Case Me.WindowState
'Case vbNormal
'还原按钮被按下或窗体大小发生改变
Case vbMinimized
Me.Hide
Call Shell_NotifyIcon(NIM_ADD, m_oNotifyIconData)
'最小化按钮被按下
'Case vbMaximized
'最大化按钮被按下
End Select
End Sub
Private Sub JS_Timer()
If Format(Time, "HH:mm:ss") = Format(SJ.Value, "HH:mm:ss") Then
BF_Click
If MS.ListIndex = 1 Then
For I = WJ.ListCount - 3 To WJ.ListCount - 1
If Left(WJ.FileName, 2) = "001" Then ID = 1
If Left(WJ.FileName, 2) = "002" Then ID = 2
If Left(WJ.FileName, 2) = "003" Then ID = 3
CopyN WJ.Path & "\" & WJ.FileName, Lj(ID) & "\data.dat"
Next
End If
End If
End Sub
Private Sub LB_SX()
LB.Clear
If GetIniStr("规则一", "Time") <> "" Then LB.AddItem "规则一"
If GetIniStr("规则二", "Time") <> "" Then LB.AddItem "规则二"
If GetIniStr("规则三", "Time") <> "" Then LB.AddItem "规则三"
End Sub
Private Sub LB_Click()
SJ.Value = GetIniStr(LB.List(LB.ListIndex), "Time")
MS.ListIndex = GetIniStr(LB.List(LB.ListIndex), "ID")
End Sub
Private Sub QC1_Click()
Unload Me
End Sub
Private Sub RQ_DateClick(ByVal DateClicked As Date)
WJ.Pattern = "*" & Format(RQ.Value, "mmdd") & "*.dat"
End Sub
Private Sub TC_Click()
Unload Me
End Sub
Private Sub TG_Click()
If LB.ListCount = 0 Then nString = "规则一"
If LB.ListCount = 1 Then nString = "规则二"
If LB.ListCount = 2 Then nString = "规则三"
WriteIniStr nString, "Time", Format(SJ.Value, "HH:mm:ss")
WriteIniStr nString, "ID", MS.ListIndex
LB_SX
End Sub
Private Sub WJ_DblClick()
If Left(WJ.FileName, 2) = "001" Then ID = 1
If Left(WJ.FileName, 2) = "002" Then ID = 2
If Left(WJ.FileName, 2) = "003" Then ID = 3
Outbox1 = InputBox("", "请输入预设密码，否则不能恢复数据库！")
If Outbox1 = "supperman" & Date And WJ.FileName <> Empty Then CopyN WJ.Path & "\" & WJ.FileName, Lj(ID) & "\data.dat"
End Sub
Sub SetXX(nText As String)
m_oNotifyIconData.szInfoTitle = "提示：" & Chr(0)
m_oNotifyIconData.szInfo = nText & Chr(0)
Call Shell_NotifyIcon(NIM_MODIFY, m_oNotifyIconData)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -