form_main.frm

忘不了密码小管家（分类管理各种密码的小工具［包括上网密码

        .Add , , gTitle_vstr(2), gTitle_vstr(2), 1, 2
        .Add , , gTitle_vstr(3), gTitle_vstr(3), 1, 2

        End With
        
        
        Call ReadSimDir(gTitle_vstr(1))
        Call ReadSimDir(gTitle_vstr(2))
        Call ReadSimDir(gTitle_vstr(3))



End If

Call ExpandAllNodes  '展开所有节点

Set mDB = OpenDatabase(gDBCurrent_Vstr)
Set mRS = mDB.OpenRecordset(gTitle_vstr(1), dbOpenDynaset)


'SortErr:
'Select Case Err.Number
'Case 75 '文件路径
'Resume Next
'
'End Select


End Sub

Private Sub CreateNewCodeAccount()
'To create a new Index object
'
'1.  Use the CreateIndex method on a TableDef object.
'2.  Use the CreateField method on the Index object to create a Field object for each field (column) to be included in the Index object.
'3.  Set Index properties as needed.
'4.  Append the Field object to the Fields collection.
'5.  Append the Index object to the Indexes collection.

Dim DB As Database
Dim mytab(2) As TableDef
Dim MyField(4) As Field
Dim Myindex(1 To 3) As Index
Dim i As Long

Set DB = CreateDatabase(gDBCurrent_Vstr, dbLangGeneral)
Set mytab(1) = DB.CreateTableDef(gTitle_vstr(1))

With mytab(1)
Set MyField(1) = .CreateField(gTableField_VStr(1), dbText, 30) '新建一个Field对象在 Index上
Set MyField(2) = .CreateField(gTableField_VStr(2), dbText, 30)
Set MyField(3) = .CreateField(gTableField_VStr(3), dbText, 40)
Set MyField(4) = .CreateField(gTableField_VStr(4), dbText, 60)
For i = 1 To 4
.Fields.Append MyField(i)
Next i
End With

DB.TableDefs.Append mytab(1)



DB.Close


End Sub

Private Sub TV_Code_AfterLabelEdit(Cancel As Integer, NewString As String)

With Form_main.TV_Code.SelectedItem

.Text = NewString
.Key = NewString

mFullPathNew = App.Path + "\" + gMSG_SimDirName + "\" + .FullPath
Kill mFullPathOld
Call CreateZeroFile(mFullPathNew)

mRS.Edit
mRS(gTableField_VStr(1)) = NewString
mRS.Update

mDB.Recordsets.Refresh

Call IsNullShow



End With




End Sub

Private Sub TV_Code_BeforeLabelEdit(Cancel As Integer)
With Form_main.TV_Code.SelectedItem
mFullPathOld = App.Path + "\" + gMSG_SimDirName + "\" + .FullPath




End With

End Sub


Private Sub TV_Code_KeyPress(KeyAscii As Integer)
Dim SelNode As Node
Set SelNode = TV_Code.SelectedItem

If KeyAscii = 13 And SelNode.Index <> 1 And SelNode.Index _
<> 2 And SelNode.Index <> 3 Then



TV_Code.StartLabelEdit

End If
End Sub

Private Sub TV_Code_NodeClick(ByVal Node As ComctlLib.Node)
On Error GoTo SortErr:
If Node.Children <> 0 Then Node.Expanded = True

If Node.Image = 3 Then
    mRS.FindFirst gTableField_VStr(1) + " = " + "'" + Node.Key + "'"
           
            
            
           
Call IsNullShow   '是否在标签上显示 "尚未添加"
    
    
    
    If mAutoCopy = True Then
    Clipboard.SetText Form_main.Txt_Code.Text
    End If
    
    If mDisplayXing = True Then
    Call ChangIntoXing
    End If
    
    
     Form_main.Txt_Code.SetFocus

      
End If



SortErr:

If Err.Number <> 0 Then
Call MsgBoxErr
End If



End Sub
Public Sub ReadSimDir(DirKey As String)  '1 or 2 1--软件，，，  2 --游戏

Dim StrPath As String  '完整路径
Dim i As Long, j As Long '计数器变量
Dim IndexFst As Long, IndexLast As Long
Dim Lnode As Node

StrPath = App.Path + "\" + gMSG_SimDirName + "\" + DirKey


Call ExpandFilesFromDir(StrPath, DirKey) '列出目录下的文件


Call ExpandSubFromPreSub(StrPath, DirKey, IndexFst, IndexLast) '
'由于根目录下的子目录都是依次添加，所以索引号是连续的

If IndexFst <> 0 And IndexLast <> 0 Then '若根目录下无文件则不执行以下过程
    For i = IndexFst To IndexLast  '列出子目录下的文件 最后一级
    Set Lnode = Form_main.TV_Code.Nodes.Item(i)
    
    Call ExpandFilesFromDir(StrPath + "\" + Lnode.Text, Lnode.Text)
    Next i

End If


'GetAttr函数说明 ：
'若要判断是否设置了某个属性，在 GetAttr 函数与想要得知的属性值之间使用 And 运算符与逐位比较。如果所得的结果不为零，则表示设置了这个属性值。例如，在下面的 And 表达式中，
'如果档案 (Archive) 属性没有设置，则返回值为零：
'Result = GetAttr(FName) And vbArchive
'如果文件的档案属性已设置，则返回非零的数值。





















End Sub

Public Sub ExpandFilesFromDir(DirName As String, ItemKey As String)
Attribute ExpandFilesFromDir.VB_Description = "将指定目录（DirName）下的文件展开，并添加到TreeView控件中指定Key的Node对象作为它的子项目,同时为每个新添加的子项目写入与名字相同的Key索引索引值 ."
'将指定目录（DirName）下的文件展开，并添加到TreeView控件中指定Key的
'Node对象作为它的子项目,同时为每个新添加的子项目写入与名字相同的Key索引值 .


'目录名   ItemKey is a key string
'******************************************
'返回 指定目录下的文件
On Error GoTo SortErr:


Dim StrFiles(30) As String
Dim ItemName As String
StrFiles(1) = StripOffAddon(Dir(DirName + "\*.*", vbNormal))
If StrFiles(1) = vbNullString Then Exit Sub
'Problem?
i = 2
Do
StrFiles(i) = Dir
    If StrFiles(i) = vbNullString Then
    
    Exit Do
    
    End If
i = i + 1
Loop

With Form_main.TV_Code

For j = 1 To i - 1
ItemName = StripOffAddon(StrFiles(j))
.Nodes.Add ItemKey, tvwChild, ItemName, ItemName, 3
Debug.Print ItemName
Next j

Debug.Print .Nodes.Item(ItemName).Text
End With

'Node.Item(Index)用法
'Index Can be a Index with long DataType and Also can be a key With String Data Type
'Attached to a Node Item.
SortErr:
If Err.Number <> 0 Then

MsgBox "错误号：" & Err.Number & Chr(13) & "描述：" & Err.Description, vbCritical, "发生运行时错误，请与作者联系"
Exit Sub
End If



End Sub

Public Sub ExpandSubFromPreSub(DirName As String, ItemKey As String, IndexFst As Long, IndexLast As Long)
'???用Dir如何返回目录名
'On Error GoTo SortErr:

Dim MyName As String  '为目录名
Dim i As Long
Dim Lnode As Node

MyName = Dir(DirName + "\", vbDirectory) ' 找寻第一项。


Do While MyName <> ""   ' 开始循环。
    ' 跳过当前的目录及上层目录。
    If MyName <> "." And MyName <> ".." Then
        ' 使用位比较来确定 MyName 代表一目录。
        If (GetAttr(DirName & "\" + MyName) And vbDirectory) = vbDirectory Then
        i = i + 1
        Set Lnode = Form_main.TV_Code.Nodes.Add(ItemKey, tvwChild, MyName, MyName, 1, 2)
       
        '如果是第一个目录项目，返回值
        If i = 1 Then IndexFst = Lnode.Index
        
       
        Debug.Print Lnode.Index
        
        'Call ExpandFilesFromDir(DirPath, MyName)  '将MyName目录下的文件添加到TV 最后一级
      
        End If
    End If
   
    MyName = Dir    ' 查找下一个目录。
Loop

If i <> 0 Then
IndexLast = Lnode.Index '最后一个项目的索引
ElseIf i = 0 Then

IndexFst = 0   '表示无目录
IndexLast = 0  '表示无目录

End If
'GetAttr函数说明 ：
'若要判断是否设置了某个属性，在 GetAttr 函数与想要得知的属性值之间使用 And 运算符与逐位比较。如果所得的结果不为零，则表示设置了这个属性值。例如，在下面的 And 表达式中，
'如果档案 (Archive) 属性没有设置，则返回值为零：
'Result = GetAttr(FName) And vbArchive
'如果文件的档案属性已设置，则返回非零的数值。













End Sub

Public Function StripOffAddon(StrFileName As String) As String   '将文件名剥去后缀
Dim Position As Long
Position = InStr(1, StrFileName, ".")
Select Case Position
Case 0  '若原字符串中无 .则原样返回
StripOffAddon = StrFileName

Case Else
'Instr(,STR1,str2) Search str2 in str1

StripOffAddon = Mid$(StrFileName, 1, Position - 1)

End Select

End Function

Public Sub CreateZeroFile(PathwithFileName As String)
Open PathwithFileName For Output As #1

Close #1
End Sub

Public Sub RefreshTv()

With Form_main.TV_Code.Nodes
.Clear
.Add , , gTitle_vstr(1), gTitle_vstr(1), 1, 2
.Add , , gTitle_vstr(2), gTitle_vstr(2), 1, 2
.Add , , gTitle_vstr(3), gTitle_vstr(3), 1, 2

End With


Call ReadSimDir(gTitle_vstr(1))
Call ReadSimDir(gTitle_vstr(2))
Call ReadSimDir(gTitle_vstr(3))
End Sub
 

Public Sub CreateIndex()
'To create a new Index object
'
'1.  Use the CreateIndex method on a TableDef object.
'2.  Use the CreateField method on the Index object to create a Field object for each field (column) to be included in the Index object.
'3.  Set Index properties as needed.
'4.  Append the Field object to the Fields collection.
'5.  Append the Index object to the Indexes collection.

Dim DB As Database
Dim mytab(2) As TableDef
Dim MyField(3) As Field
Dim Myindex(1 To 3) As Index
Dim i As Long

Set DB = CreateDatabase(gDBCurrent_Vstr, dbLangGeneral)
Set mytab(1) = DB.CreateTableDef(gTitle_vstr(1))

Set Myindex(1) = mytab(1).CreateIndex("idxName") '新建一个Index对象在TableDef上
Set MyField(1) = Myindex(1).CreateField(gTableField_VStr(1), dbText, 30) '新建一个Field对象在 Index上


Set Myindex(2) = mytab(1).CreateIndex("idxTrueCode")
Set MyField(2) = Myindex(1).CreateField(gTableField_VStr(2), dbText, 30)

Set Myindex(3) = mytab(1).CreateIndex("idxDescription")
Set MyField(3) = Myindex(1).CreateField(gTableField_VStr(3), dbText, 50)


For i = 1 To 3
Myindex(i).Fields.Append MyField(i)
Next i

For i = 1 To 3
mytab(1).Indexes.Append Myindex(i)
Next i

mytab(1).Indexes.Refresh


DB.TableDefs.Append mytab(1)

'???


Set mytab(2) = DB.CreateTableDef(gTitle_vstr(1))

Set Myindex(1) = mytab(2).CreateIndex("idxName")
Set MyField(1) = Myindex(1).CreateField(gTableField_VStr(1), dbText, 30)

Set Myindex(2) = mytab(2).CreateIndex("idxTrueCode")
Set MyField(2) = Myindex(1).CreateField(gTableField_VStr(2), dbText, 30)

Set Myindex(3) = mytab(2).CreateIndex("idxDescription")
Set MyField(3) = Myindex(1).CreateField(gTableField_VStr(3), dbText, 50)


For i = 1 To 3   '添加字段
Myindex(i).Fields.Append MyField(i)
Next i

For i = 1 To 3  '添加索引
mytab(1).Indexes.Append Myindex(i)

Next i

'添加表
DB.TableDefs.Append mytab(2)










End Sub


Public Function CaptureRootItem(NodeFullPath) '将FullPath第一项截取
Dim Position As Long

Position = InStr(1, NodeFullPath, "\")
If Position <> 0 Then
CaptureRootItem = Mid$(NodeFullPath, 1, Position - 1)
Else
CaptureRootItem = NodeFullPath
End If
End Function


Private Sub VSSplitter_EndMoving()
On Error GoTo SortErr:
TV_Code.Width = VSSplitter.Left - TV_Code.Left - 20
Frame_Large.Left = VSSplitter.Left + 20
Form_main.Width = Frame_Large.Left + Frame_Large.Width + 250


SortErr:
If Err.Number <> 0 Then

    Call MsgBoxErr

    Exit Sub

End If

End Sub

Public Sub MakeUpWin()
Form_main.TV_Code.Width = VSSplitter.Left - gMSG_CrackLen
Form_main.Frame_Large.Left = VSSplitter.Left + gMSG_CrackLen
Form_main.Width = Frame_Large.Width + TV_Code.Width + 2 * gMSG_CrackLen + 50
End Sub

Public Sub MsgBoxErr()
MsgBox "错误号：" & Err.Number & Chr(13) & "描述：" & Err.Description, vbCritical, "发生运行时错误，请与作者联系"

End Sub

Public Sub ExpandAllNodes()
Dim i As Long

With Form_main.TV_Code
    For i = 1 To .Nodes.Count
    
        If .Nodes.Item(i).Children <> 0 And .Nodes.Item(i).Expanded = False Then
        
        .Nodes.Item(i).Expanded = True
        End If
    Next i
End With


End Sub

Public Sub ChangIntoXing()
'将密码显示窗口的文本转换成 * 并将真密码文本储存至临时变量
'mTmpTrueCode
    Dim LenCode As Long
    mTmpTrueCode = Txt_Code.Text
    LenCode = Len(Txt_Code.Text)
    Form_main.Txt_Code.Text = String(LenCode, "*")

End Sub

Public Sub IsNullShow()

 If IsNull(mRS(gTableField_VStr(2))) = False Then

    Lbl_info(0) = gMSG_Info1 + ":" + mRS(gTableField_VStr(1))
    Form_main.Txt_Code.Text = mRS(gTableField_VStr(2))
    
    Else  '尚未添加
    Lbl_info(0) = gMSG_Info1 + ":" + mRS(gTableField_VStr(1)) + _
    "(" + gMSG_UnWritten + ")"
    Form_main.Txt_Code.Text = ""
    
    End If
    
    If IsNull(mRS(gTableField_VStr(4))) = False Then
    Lbl_info(1) = gMSG_Info2
    Form_main.Txt_Desciption.Text = mRS(gTableField_VStr(4))
    
    Else '尚未添加
    Lbl_info(1) = gMSG_Info2 + "(" + gMSG_UnWritten + ")"
    Form_main.Txt_Desciption.Text = ""
    
    End If
End Sub

Public Sub InitTVandSimMap()
 MkDir App.Path + "\" + gMSG_SimDirName
        MkDir App.Path + "\" + gMSG_SimDirName + "\" + gTitle_vstr(1)
        MkDir App.Path + "\" + gMSG_SimDirName + "\" + gTitle_vstr(2)
        MkDir App.Path + "\" + gMSG_SimDirName + "\" + gTitle_vstr(3)
           
        With Form_main.TV_Code.Nodes
        .Add , , gTitle_vstr(1), gTitle_vstr(1), 1, 2
        .Add , , gTitle_vstr(2), gTitle_vstr(2), 1, 2
        .Add , , gTitle_vstr(3), gTitle_vstr(3), 1, 2
        End With
End Sub