frmmain.frm

家谱管理软件,树形控件操作,可保存文本和图片,查找快捷

End Sub

Private Sub Form_Load()

    Call CheckExist(Me) '检查本程序是否重复运行!
    
    DrvType = GetDriveType(Mid(App.Path, 1, 2)) '在什么磁盘上运行?
    
    If DrvType = 3 Then '硬盘可以读写,则进行标记
        DqpWData = True '当前盘写数据=T
        Me.Tag = 1
    Else '非硬盘,包括闪盘,就只有浏览功能了
        DqpWData = False '当前盘写数据=F
        Me.Tag = 0
        添加.Enabled = False
        添加P.Enabled = False
    End If
    
    sQTXmlFileName = App.Path & "\xml\NodesQT.xml" '节点嵌套 XML文件_全名赋值
    sBPXmlFileName = App.Path & "\xml\NodesBP.xml" '节点扁平 XML文件_全名赋值
    
    'Me.Move 2700, 2100, 12000, 10000 '窗体初始大小和位置
    Me.WindowState = 2
    
    节点拖动.Checked = False   '先是不能拖动
    节点删除.Checked = False   '先是不能删除节点
    删除.Enabled = False       '先是不能删除
    清除标识.Enabled = False   '先是不用清除
    清除红标记.Enabled = False '先是不用清除
    
    Call 没有数据的显示        '有些按钮不能用
    Picture1.Visible = False   '没有文件则先不显示
    Picture2.Visible = False
    
    Timer1.Enabled = True      '窗体加载后,再用计时器进行XML数据的加载
    
End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    退出_Click
End Sub

Private Sub Form_Resize()

    TreeView1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight '目录树充满窗体

End Sub



Private Sub List1_Click()
    Dim Li As Integer
    Li = List1.ListIndex
    Me.List2.ListIndex = Li
    Me.TreeView1.Nodes(List2.Text).Selected = True
    TreeView1.SelectedItem.EnsureVisible
    TreeView1_Click
    Me.Label2.Caption = "当前选择" & Li + 1 & "/" & List1.ListCount
End Sub

Private Sub List1_DblClick()
    List1_Click
    清除标识_Click
    Me.Picture2.Visible = False
End Sub

Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'移动图片
    Dim wqi As Long
        If Button = 1 Then
            Picture2.MousePointer = 15
            ReleaseCapture
            wqi = SendMessage(Me.Picture2.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
            Picture2.MousePointer = 0
        End If
End Sub

Private Sub Timer1_Timer()
    
    If Dir(sQTXmlFileName, 32) = "" Then Timer1.Enabled = False: Exit Sub
    Picture1.Visible = True
    
    Call XMLLoad(sQTXmlFileName, TreeView1)
    
    If TreeView1.Nodes.Count <> 0 Then
        TreeView1.Nodes(1).Selected = True
        TreeView1_Click
    End If
    
    Picture1.Visible = False '这是放进度条的
    Timer1.Enabled = False '只此一次
    
End Sub



'Private Sub Timer2_Timer()

    'If TreeView1.Nodes.Count = 0 Then Exit Sub
    'TreeView1.SelectedItem.EnsureVisible

'End Sub



Private Sub TreeView1_AfterLabelEdit(Cancel As Integer, NewString As String)
    If DqpWData = True Then
        保存.Enabled = True
        保存P.Enabled = True
    End If
End Sub

Private Sub TreeView1_Click()

    If Me.TreeView1.Nodes.Count = 0 Then Exit Sub '如果没有节点,那么就退出
    
    'TreeView1.SelectedItem.BackColor = -2147483643 '点击的节点背景色复原
    
    iJD = 1 '几代,先是1
    sFullPath = Me.TreeView1.SelectedItem.FullPath '取全路径
    CD = Len(sFullPath) '全路径的长度
    
    For k = 1 To CD '在全路径中逐一查找"\"的个数,所以节点名称中有"\"就不准确
        If Mid(sFullPath, k, 1) = "\" Then iJD = iJD + 1 '找到一个加一
    Next k
    
    ZRS = Me.TreeView1.Nodes.Count '总人数
    
    Me.Caption = "家谱 - 点击世代：" & iJD & " - 总人数：" & ZRS

End Sub



Private Sub TreeView1_NodeCheck(ByVal Node As MSComctlLib.Node)
    TreeView1_Click
End Sub



Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
    TreeView1_Click
End Sub



Private Sub 保存_Click()
    If Me.TreeView1.Nodes.Count < 2 Then Exit Sub
    If Dir(App.Path & "\Xml", vbDirectory) = "" Then MkDir App.Path & "\Xml" '如果没有XML文件夹,就建立
    Call TNodeToXml(TreeView1, sQTXmlFileName) '保存为嵌套的XML文件
    Call SaveBP(TreeView1, sBPXmlFileName) '保存为扁平的XML文件
    保存.Enabled = False
    保存P.Enabled = False
    
End Sub



Private Sub 保存P_Click()
    保存_Click
End Sub


Private Sub 查找_Click()
    If Me.TreeView1.Nodes.Count = 0 Then Exit Sub

    '定位于 sFindName
    sFindName = InputBox("请问您查找“何人”，谢谢！" & Chr(13) & Chr(13) & Chr(10) & "    当然你可以输入一些关键字进行模糊查找，如[汪]、[汪启]、[启]、[汪学]、[华]等，这样就可以提供多方面的查找条件和得到有效查找结果！", , "华")
    If sFindName = "" Then Exit Sub
    
    '节点全部展开
    Dim vNode As Node
    k = 1
    Me.List1.Clear
    Me.List2.Clear
    Me.Label2.Caption = ""
    For Each vNode In TreeView1.Nodes
        If InStr(1, vNode.Text, sFindName) > 0 Then
        vNode.Selected = True
        vNode.BackColor = &H8000000F
        vNode.EnsureVisible
        Me.Picture2.Cls
        Me.Picture2.Visible = True
        Me.Label3.Caption = "找到" & k & "个"
        k = k + 1
        Me.List1.AddItem vNode.Text
        Me.List2.AddItem vNode.Key
        Else
        vNode.BackColor = -2147483643
        End If
    Next
    
    If k > 0 And DqpWData = True Then
    清除标识.Enabled = True
    清除红标记.Enabled = True
    End If
    
    TreeView1_Click

End Sub



Private Sub 查找P_Click()
    查找_Click
End Sub

Private Sub 关于_Click()
    FrmAbout.Show 1
End Sub



Private Sub 节点删除_Click()
    If DqpWData = True Then
        节点删除.Checked = Not 节点删除.Checked
        删除.Enabled = 节点删除.Checked
        删除P.Enabled = 节点删除.Checked
    End If
End Sub



Private Sub 节点拖动_Click()
    If DqpWData = True Then
        节点拖动.Checked = Not 节点拖动.Checked
        mbIndrag = 节点拖动.Checked
    End If
End Sub



Private Sub 内容_Click()
htmlhelp hwnd, "家谱.CHM", 0, 0 '
End Sub

Private Sub 清除标识_Click()
    If Me.TreeView1.Nodes.Count = 0 Then Exit Sub
    
    Dim vNode As Node
    For Each vNode In TreeView1.Nodes
        vNode.BackColor = -2147483643
    Next
    
    清除标识.Enabled = False
    清除红标记.Enabled = False
    
End Sub



Private Sub 清除红标记_Click()
    清除标识_Click
End Sub

Private Sub 清理冗余文件_Click()
    '也就是将三个文件夹中多余的文件删除
    '时间长，
    '速度慢。
    
    If Me.TreeView1.Nodes.Count = 0 Then Exit Sub
    
    If Dir(App.Path & "\Rec", vbDirectory) = "" And Dir(App.Path & "\Res", vbDirectory) = "" And Dir(App.Path & "\Img", vbDirectory) = "" Then Exit Sub
    
    If Dir(App.Path & "\Rec", vbDirectory) <> "" Then
        If AutoListFiles(App.Path & "\Rec", "*.ini") = True Then
            Name App.Path & "\Rec" As App.Path & "\bakRec"
        Else
            RmDir App.Path & "\Rec"
        End If
    End If
     
    If Dir(App.Path & "\Res", vbDirectory) <> "" Then
        If AutoListFiles(App.Path & "\Res", "*.txt") = True Then
            Name App.Path & "\Res" As App.Path & "\bakRes"
            'MkDir App.Path & "\Res"
        Else
            RmDir App.Path & "\Res"
        End If
    End If
    
    If Dir(App.Path & "\Img", vbDirectory) <> "" Then
        If AutoListFiles(App.Path & "\Img", "*.jpg") = True Then
            Name App.Path & "\Img" As App.Path & "\bakImg"
            'MkDir App.Path & "\Img"
        Else
            RmDir App.Path & "\Img"
        End If
    End If

    '先移到根节点
    TreeView1.SelectedItem = TreeView1.Nodes(1)

    '-------------------------------------------------------------------------------
    '总节点数量
    Dim j As Integer
    
    For j = 1 To Me.TreeView1.Nodes.Count

    '取值
    Key = TreeView1.Nodes(j).Key

    If Key = "" Then Exit Sub
    
    '-------------------------------------------------------------------------------
    If Dir(App.Path & "\bakRec\" & Key & ".ini", 32) <> "" Then
    If Dir(App.Path & "\Rec", vbDirectory) = "" Then MkDir App.Path & "\Rec"
    FileCopy App.Path & "\bakRec\" & Key & ".ini", App.Path & "\Rec\" & Key & ".ini"
    End If
    
    If Dir(App.Path & "\bakRes\" & Key & ".txt", 32) <> "" Then
    If Dir(App.Path & "\Res", vbDirectory) = "" Then MkDir App.Path & "\Res"
    FileCopy App.Path & "\bakRes\" & Key & ".txt", App.Path & "\Res\" & Key & ".txt"
    End If
    
    If Dir(App.Path & "\bakImg\" & Key & ".jpg", 32) <> "" Then
    If Dir(App.Path & "\Img", vbDirectory) = "" Then MkDir App.Path & "\Img"
    FileCopy App.Path & "\bakImg\" & Key & ".jpg", App.Path & "\Img\" & Key & ".jpg"
    End If
    
    '-------------------------------------------------------------------------------
    
    Next j
    
    '删除备份
    If Dir(App.Path & "\bakRec", vbDirectory) <> "" Then RecurseTree App.Path & "\bakRec"
    If Dir(App.Path & "\bakRes", vbDirectory) <> "" Then RecurseTree App.Path & "\bakRes"
    If Dir(App.Path & "\bakImg", vbDirectory) <> "" Then RecurseTree App.Path & "\bakImg"
    
    MsgBox "冗余文件清理完成!"
    
End Sub



Function AutoListFiles(ByVal sDirName As String, ByVal FileFilter As String) As Boolean
    
    On Error GoTo RF_ERROR
    
    Dim sName As String, sFile As String, sExt As String
    Dim sDirList() As String, iDirNum As Integer, I As Integer
    
    '首先枚举所有文件
    sFile = Dir(sDirName + FileFilter, vbNormal + vbArchive + vbHidden)
    
    Do While Len(sFile) > 0
        sFile = UCase(Trim(sFile))
        '在此处可以将 sFile 加入到一个 Text 控件...
        sFile = Dir '下一个文件
    Loop
    
    iDirNum = 0
    sName = Dir(sDirName + "*.*", vbDirectory + vbNormal)
    
    Do While Len(sName) > 0
        If sName <> "." And sName <> ".." Then
            iDirNum = iDirNum + 1
            ReDim Preserve sDirList(1 To iDirNum)
            sDirList(iDirNum) = sDirName + sName + " \ "
        End If
        
        sName = Dir '下一个目录
    Loop
    
    For I = 1 To iDirNum
    AutoListFiles sDirList(I), "*.*" '递归调用
    Next
    
RF_EXIT:
    AutoListFiles = True
    Exit Function
RF_ERROR:
    MsgBox Err.Description, vbCritical, ""
    Resume RF_EXIT
End Function