📄 form_main.frm
字号:
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Object = "{54FC599E-9611-11D2-8350-E97AACC90D73}#1.1#0"; "SPLTRBAR.OCX"
Begin VB.Form Form_main
Caption = "忘不了密码小管家"
ClientHeight = 3675
ClientLeft = 1845
ClientTop = 1785
ClientWidth = 6270
Icon = "Form_main.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 3675
ScaleWidth = 6270
Begin ComctlLib.TreeView TV_Code
Height = 3240
Left = 0
TabIndex = 0
Top = 360
Width = 1995
_ExtentX = 3519
_ExtentY = 5715
_Version = 327682
Indentation = 265
LabelEdit = 1
Style = 5
ImageList = "ImLForTV"
BorderStyle = 1
Appearance = 1
End
Begin SplitterBars.VSplitterBar VSSplitter
Height = 3435
Left = 2025
Top = 135
Width = 30
_ExtentX = 53
_ExtentY = 6059
BorderStyle = 1
End
Begin VB.Frame Frame_Large
Height = 3525
Left = 2070
TabIndex = 1
Top = 60
Width = 4110
Begin VB.TextBox Txt_Code
Height = 240
Left = 75
TabIndex = 10
Top = 405
Width = 3795
End
Begin VB.TextBox Txt_Desciption
Height = 2310
Left = 90
MultiLine = -1 'True
TabIndex = 9
Top = 1080
Width = 1680
End
Begin VB.CheckBox Chk_Opt
Caption = "自动复制到剪贴板"
ForeColor = &H8000000D&
Height = 405
Index = 0
Left = 2445
TabIndex = 8
Top = 675
Width = 1095
End
Begin VB.CheckBox Chk_Opt
Caption = "显示为""*""号"
ForeColor = &H8000000D&
Height = 435
Index = 1
Left = 2445
TabIndex = 7
Top = 1080
Width = 1095
End
Begin VB.Frame Frame1
Height = 1680
Index = 1
Left = 2340
TabIndex = 2
Top = 1665
Width = 1545
Begin VB.CommandButton cmd_addFile
Caption = "新建项目"
Height = 285
Left = 180
TabIndex = 6
Top = 180
Width = 1095
End
Begin VB.CommandButton Cmd_AddSub
Caption = "新建组"
Height = 255
Left = 180
TabIndex = 5
Top = 540
Width = 1095
End
Begin VB.CommandButton cmd_Save
Caption = "保存修改"
Height = 255
Left = 180
TabIndex = 4
Top = 990
Width = 1095
End
Begin VB.CommandButton cmd_Delete
Caption = "删除项目"
Height = 270
Index = 1
Left = 180
TabIndex = 3
Top = 1305
Width = 1110
End
Begin VB.Line Line1
BorderColor = &H80000001&
BorderWidth = 2
Index = 1
X1 = 90
X2 = 1410
Y1 = 900
Y2 = 900
End
End
Begin VB.Label Lbl_info
Caption = "密码显示："
ForeColor = &H8000000D&
Height = 195
Index = 0
Left = 90
TabIndex = 12
Top = 180
Width = 2940
End
Begin VB.Label Lbl_info
Caption = "说明："
ForeColor = &H8000000D&
Height = 240
Index = 1
Left = 135
TabIndex = 11
Top = 810
Width = 1680
End
End
Begin VB.Label Lbl_info
Caption = "虚拟密码箱："
ForeColor = &H8000000D&
Height = 195
Index = 2
Left = 45
TabIndex = 13
ToolTipText = "双击显示帮助窗口"
Top = 135
Width = 1860
End
Begin ComctlLib.ImageList ImLForTV
Left = 5520
Top = 2160
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 3
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "Form_main.frx":0442
Key = ""
EndProperty
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "Form_main.frx":075C
Key = ""
EndProperty
BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "Form_main.frx":0A76
Key = ""
EndProperty
EndProperty
End
End
Attribute VB_Name = "Form_main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim mDB As Database '模块级的数据库变量
Dim mRS As Recordset
'两个选项开关，决定是否 "自动复制"和“显示为'*'号”
Dim mAutoCopy As Boolean
Dim mDisplayXing As Boolean
Dim mTmpTrueCode As String '显示为 * 号后，用于储存原来的密码字符串
'用于对项目名称的更改
Dim mFullPathOld As String '项目原有的名称
Dim mFullPathNew As String '项目更改后的名称
'废弃的代码！！
'Private Sub IntTv() '初始化TreeView控件内的内容
'
'On Error GoTo SortErr:
'Dim TvNodes As Nodes
'Dim LocalDB As Database
'Dim LocalRS(2) As Recordset
'Dim mytab As TableDef
'Dim i As Long
'
'
'
'Set TvNodes = Form_main.TV_Code.Nodes
'
'Set LocalDB = OpenDatabase(gDBCurrent_Vstr)
'Set LocalRS(1) = LocalDB.OpenRecordset(gTitle_vstr(1))
'Set LocalRS(2) = LocalDB.OpenRecordset(gTitle_vstr(2))
'
'
'TvNodes.Add , , , gTitle_vstr(1), 1, 2
'TvNodes.Add , , , gTitle_vstr(2), 1, 2
'
'
'
''!!^_^
''出现类型不匹配的原因:
''记录集指针指向了文件尾记录的后面，Do While语句无法中止继续读操作， 得到 null值
''引发错误 BeCarefull!
'
'
''??没有当前记录问题？
'LocalRS(1).MoveLast
'LocalRS(1).MoveFirst
'
'
'
'
'
''难解之迷
'
'For i = 1 To LocalRS(1).RecordCount
'TvNodes.Add 1, tvwChild, , RTrim(LocalRS(1)(gTableField_VStr(1))), 3
'LocalRS(1).MoveNext
'Next i
'
'
''Populate REcordCount Property
''LocalRs(2).AddNew
''LocalRs(2).Update
''
'LocalRS(2).MoveLast
''
''LocalRs(2).Delete
'LocalRS(2).MoveFirst
'
''没有当前记录,解决办法
'
'
'
'For i = 1 To LocalRS(2).RecordCount
''
'TvNodes.Add 2, tvwChild, , RTrim(LocalRS(2)(gTableField_VStr(1))), 3
'
'LocalRS(2).MoveNext
''
'Next i
'
'
'
'
'
'SortErr:
'Debug.Print "Err.number is "
'End Sub
Private Sub Chk_Opt_Click(Index As Integer)
Dim LenCode As Long
Select Case Index
Case 0 '自动复制
If Chk_Opt(Index).Value = 1 Then
mAutoCopy = True
Else
mAutoCopy = False
End If
Case 1 '*号
If Chk_Opt(Index).Value = 1 Then
mDisplayXing = True
Call ChangIntoXing
Else
mDisplayXing = False
Form_main.Txt_Code.Text = mTmpTrueCode
End If
End Select
End Sub
Private Sub cmd_addFile_Click()
Dim SelNode As Node
Dim PNode As Node
Dim SimDirPath As String
Dim ItemPath As String
Dim FileFullPath As String
With Form_main.TV_Code
SimDirPath = App.Path + "\" + gMSG_SimDirName
Set SelNode = .SelectedItem
If SelNode.Image = 3 Then
Set PNode = Form_main.TV_Code.SelectedItem.Parent
ItemPath = PNode.FullPath
Else
ItemPath = SelNode.FullPath
End If
FileName = InputBox$(gMSG2 + ItemPath, gMSG1)
If FileName = "" Then Exit Sub
FileFullPath = SimDirPath + "\" + ItemPath + "\" + FileName
Call CreateZeroFile(FileFullPath)
'刷新TreeView
Call RefreshTv
Call ExpandAllNodes
Set .SelectedItem = .Nodes.Item(FileName)
.SetFocus
'Call IsNullShow
mRS.AddNew
mRS(gTableField_VStr(1)) = FileName
mRS(gTableField_VStr(3)) = .Nodes.Item(FileName).FullPath
mRS.Update
'将指针定位在新建的项目上，采用FindFirst方法用于定位
mRS.FindFirst gTableField_VStr(1) + " = " + "'" + .SelectedItem.Key + "'"
Call IsNullShow
End With
End Sub
Private Sub Cmd_AddSub_Click()
Dim SelNode As Node
Dim SubName As String
Dim ItemPath As String
Dim ItemFullPath As String
Set SelNode = Form_main.TV_Code.SelectedItem
ItemPath = CaptureRootItem(SelNode.FullPath)
SubName = InputBox(gMSG4 + ItemPath, gMSG3)
If SubName = "" Then Exit Sub
ItemFullPath = App.Path + "\" + gMSG_SimDirName + "\" + ItemPath + "\" + SubName
MkDir ItemFullPath
Call RefreshTv
Call ExpandAllNodes
With Form_main.TV_Code
Set .SelectedItem = .Nodes.Item(SubName)
End With
End Sub
Private Sub cmd_Delete_Click(Index As Integer)
Dim SelNode As Node
Dim FileFullPath As String
Dim i As Long
Set SelNode = Form_main.TV_Code.SelectedItem
Select Case SelNode.Image
Case 3 '是文件
i = MsgBox(gMSG6 + SelNode.Text, vbOKCancel + vbQuestion, gMSG_AppName)
If i = vbCancel Then Exit Sub
FileFullPath = App.Path + "\" + gMSG_SimDirName + "\" + SelNode.FullPath
Kill FileFullPath
'查找表中选中的项，册除，刷新
mRS.FindFirst gTableField_VStr(1) + " = " + "'" + SelNode.Key + "'"
mRS.Delete
mDB.Recordsets.Refresh
Call RefreshTv
Call ExpandAllNodes
With Form_main
.Txt_Code.Text = ""
.Txt_Desciption.Text = ""
.Lbl_info(0).Caption = gMSG_Info1
.Lbl_info(1).Caption = gMSG_Info2
End With
Case Else '文件包
If SelNode.Index <> 1 And SelNode.Index <> 2 And SelNode.Index <> 3 Then
If SelNode.Children = 0 Then
i = MsgBox(gMSG7 + SelNode.Text, vbOKCancel + vbQuestion, gMSG_AppName)
If i = vbCancel Then Exit Sub
RmDir App.Path + "\" + gMSG_SimDirName + "\" + SelNode.FullPath
Call RefreshTv
Else
MsgBox gMSG9, vbCritical, gMSG_AppName
End If
Else
MsgBox gMSG8, vbInformation, gMSG_AppName
End If
End Select
End Sub
Private Sub cmd_Save_Click()
On Error GoTo SortErr:
Dim txt(2) As String
txt(1) = Txt_Code.Text
txt(2) = Form_main.Txt_Desciption.Text
mRS.Edit
If txt(1) <> vbNullString Then
mRS(gTableField_VStr(2)) = txt(1)
End If
If txt(2) <> vbNullString Then
mRS(gTableField_VStr(4)) = txt(2)
End If
mRS.Update
mDB.Recordsets.Refresh
Call IsNullShow
SortErr:
If Err.Number <> 0 Then
Call MsgBoxErr
End If
End Sub
Private Sub Form_Load()
'On Error GoTo SortErr:
Dim StrDir As String
Call IntVariables
mAutoCopy = True
Chk_Opt(0).Value = 1
gDBCurrent_Vstr = App.Path + "\" + gDBName + ".mdb"
StrDir = Dir(gDBCurrent_Vstr, vbNormal)
If StrDir = vbNullString Then
Call CreateNewCodeAccount
Call InitTVandSimMap
Else
With Form_main.TV_Code.Nodes
.Add , , gTitle_vstr(1), gTitle_vstr(1), 1, 2
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -