frmmain.frm

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

Private Sub 删除_Click()
    If Me.TreeView1.Nodes.Count > 0 Then
        If Me.TreeView1.SelectedItem.Parent Is Nothing Then Exit Sub
        Dim REIndex As Integer
        REIndex = Me.TreeView1.SelectedItem.Index
        Dim SFSC As VbMsgBoxResult '是否删除
        SFSC = MsgBox("是否删除选择的节点及其所有子节点!", vbYesNo)
            If SFSC = vbYes Then
            Me.TreeView1.Nodes.Remove (REIndex)
            End If
    End If
    
    If DqpWData = True Then
        保存.Enabled = True
        保存P.Enabled = True
    End If
    
End Sub



Private Sub 删除P_Click()
    删除_Click
End Sub

Private Sub 刷新_Click()
    Timer1.Enabled = True '启用计时,再次进行XML数据的加载
End Sub


Private Sub 添加_Click()
    Key = GUIDGen
    
    If Me.TreeView1.Nodes.Count = 0 Then
        Me.TreeView1.Nodes.Add , , Key, "wqi", 1, 2
        Key = GUIDGen
        Pkey = Me.TreeView1.Nodes(1).Key
        Me.TreeView1.Nodes.Add Pkey, 4, Key, "wqi", 1, 2
    Else
        If iJD > 255 Then Exit Sub
        Pkey = Me.TreeView1.SelectedItem.Key
        Me.TreeView1.Nodes.Add Pkey, 4, Key, "wqi", 1, 2
    End If
    
    Me.TreeView1.Nodes(Key).Selected = True
    Me.TreeView1.Nodes(Key).EnsureVisible
    '有修改,保存提示
    
    If DqpWData = True Then
        保存.Enabled = True
        保存P.Enabled = True
    End If
    
    TreeView1_Click
    Call 有数据的显示
End Sub



Private Sub 添加P_Click()
    添加_Click
End Sub


Private Sub 退出_Click()
    bSaveYN = 保存.Enabled
    If bSaveYN = True And DqpWData = True Then
        Dim SaveMsg As VbMsgBoxResult
        SaveMsg = MsgBox("数据有修改,是否保存?", vbYesNo)
        If SaveMsg = vbYes Then
            Call 保存_Click
        End If
    End If
    End
End Sub



'读取节点数据
Public Sub XMLLoad(sFileLoad As String, TV As TreeView)
    Dim xmlDoc As DOMDocument30
    Set xmlDoc = New DOMDocument30
        If Not xmlDoc.Load(sFileLoad) Then
            'MsgBox "不能读取XML文件。"
            Exit Sub
        End If
    Call 有数据的显示
    ProgressBar1.value = 0
    Picture1.Visible = True '这是放进度条的
    Me.Picture1.Cls
    Me.Picture1.Print "请稍候"
    TV.Nodes.Clear
    '装配目录树
    Dim iNode As Integer
    Dim newElement As IXMLDOMElement
        For iNode = 0 To xmlDoc.getElementsByTagName("Node").length - 1
        Me.ProgressBar1.Max = xmlDoc.getElementsByTagName("Node").length - 1
        Set newElement = xmlDoc.getElementsByTagName("Node").Item(iNode)
            If newElement.getAttribute("ParentKey") = "" Then
                TV.Nodes.Add , , _
                newElement.getAttribute("Key"), _
                newElement.getAttribute("Caption"), 1, 2
            Else
                TV.Nodes.Add _
                newElement.getAttribute("ParentKey"), _
                tvwChild, newElement.getAttribute("Key"), newElement.getAttribute("Caption"), 1, 2
                Me.Caption = "家谱 - [加载人数:" & iNode & "]"
                Me.ProgressBar1.value = iNode

            End If
        Next iNode
    Picture1.Visible = False '这是放进度条的

End Sub


'将treeview中节点数据保存为嵌套格式XML文档
Public Sub TNodeToXml(trvw As TreeView, XmlFile As String, Optional NodeK As String, Optional Tabs As String = "")
    Dim I As Integer, k As Integer
    Dim NodekT As String
    Dim StrOver As String
    
    If Len(NodeK) = 0 Then
       NodeK = trvw.Nodes(1).Key
       If Dir(XmlFile) <> "" Then Kill XmlFile
       Open XmlFile For Output As #1
       Print #1, "<?xml version=""1.0"" encoding=""GB2312"" ?>"
       Print #1, "<Node Caption=""" & trvw.Nodes(1).Text & """ Key=""" & trvw.Nodes(1).Key & """ ParentKey="""">"
       'Print #1, "< >"
    End If
    
    'NodeK = trvw.Nodes(NodekT).Key
    
    k = trvw.Nodes(NodeK).children
    For I = 1 To k
       If I = 1 Then
          NodekT = trvw.Nodes(NodeK).Child.Key
       Else
          NodekT = trvw.Nodes(NodekT).Next.Key
       End If
       If trvw.Nodes(NodekT).children = 0 Then StrOver = "/" Else StrOver = ""
       Print #1, Tabs & vbTab & "<Node Caption=""" & trvw.Nodes(NodekT).Text & """ Key =""" & trvw.Nodes(NodekT).Key & """ ParentKey =""" & trvw.Nodes(NodekT).Parent.Key & """" & StrOver & ">"
       Call TNodeToXml(trvw, XmlFile, NodekT, Tabs & vbTab)
    Next I
    If k > 0 Then Print #1, Tabs & "</Node>"
    If NodekT = trvw.Nodes(1).Child.LastSibling.Key Then Close #1
End Sub



'将treeview中节点数据保存为扁平格式XML文档
Private Sub SaveBP(bTV As TreeView, bXmlFile As String)
    Dim xmlDoc As DOMDocument30
    Set xmlDoc = New DOMDocument30
    Dim ElementNode As IXMLDOMElement
    Dim RootElementNode As IXMLDOMElement
    Set ElementNode = xmlDoc.createElement("NODES")
    Set RootElementNode = xmlDoc.appendChild(ElementNode)
    Dim TNode As Node
    Dim I As Integer
    
    For I = 1 To bTV.Nodes.Count
        Set TNode = bTV.Nodes(I)
        Set ElementNode = xmlDoc.createElement("NODE")
        ElementNode.setAttribute "Caption", TNode.Text
        ElementNode.setAttribute "Key", TNode.Key
        
        If TNode.Parent Is Nothing Then
            ElementNode.setAttribute "ParentKey", ""
        Else
            ElementNode.setAttribute "ParentKey", TNode.Parent.Key
        End If
        
        RootElementNode.appendChild ElementNode
    Next
    xmlDoc.save (bXmlFile)
End Sub



'节点拖动
Private Sub TreeView1_DragDrop(Source As Control, X As Single, Y As Single)
    If Me.TreeView1.Nodes.Count = 0 Or mbIndrag = False Then Exit Sub

    ' If user didn't move mouse or released it over an invalid area.

    If TreeView1.DropHighlight Is Nothing Then
        'mbIndrag = False
        Exit Sub
    Else
        ' Set dragged Node's parent property to the target Node.
        On Error GoTo checkerror ' To prevent circular errors.
        Set moDragNode.Parent = TreeView1.DropHighlight
        'Cls
        'MsgBox TreeView1.DropHighlight.Text &" 是 " & moDragNode.Text & " 的父节点!"
        ' Release the DropHighlight reference.
        Set TreeView1.DropHighlight = Nothing
        'mbIndrag = False
        Set moDragNode = Nothing
        Exit Sub ' Exit if no errors occured.
    End If
 
checkerror:
    ' Define constants to represent Visual Basic errors code.
    Const CircularError = 35614
    'If Err.Number = CircularError Then
    '    Dim Msg As String
    '    Msg = "A Node can't be made a child of its own children."
    ' Display the message box with an exclamation mark icon
        ' and with OK and Cancel buttons.
        'If MsgBox(Msg, vbExclamation & vbOKCancel) = vbOK Then
            ' Release the DropHighlight reference.
        '    mbIndrag = False
        '    Set TreeView1.DropHighlight = Nothing
        '    Exit Sub
        'End If
    'End If
End Sub



Private Sub TreeView1_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
    If Me.TreeView1.Nodes.Count = 0 Or mbIndrag = False Then Exit Sub
    If mbIndrag = True Then
        ' Set DropHighlight to the mouse's coordinates.
        Set TreeView1.DropHighlight = TreeView1.HitTest(X, Y)
    End If
End Sub

Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        Me.PopupMenu MyPop
    End If
    If Me.TreeView1.Nodes.Count = 0 Or mbIndrag = False Then Exit Sub

    Set TreeView1.DropHighlight = TreeView1.HitTest(X, Y)
    'Make sure we are over a Node
    If Not TreeView1.DropHighlight Is Nothing Then
        'Set the Node we are on to be the selected Node
        'if we don't do this it will not be the selected Node
        'until we finish clicking on the Node
        TreeView1.SelectedItem = TreeView1.HitTest(X, Y)
        Set moDragNode = TreeView1.SelectedItem ' Set the item being dragged.
    End If
    Set TreeView1.DropHighlight = Nothing
    

End Sub



Private Sub TreeView1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Me.TreeView1.Nodes.Count = 0 Or mbIndrag = False Then Exit Sub
    If Button = vbLeftButton Then ' Signal a Drag operation.
        mbIndrag = True ' Set the flag to true.
        ' Set the drag icon with the CreateDragImage method.
        'TreeView1.DragIcon = TreeView1.SelectedItem.CreateDragImage
        TreeView1.Drag vbBeginDrag ' Drag operation.
    保存.Enabled = True
    保存P.Enabled = True
    End If
    
End Sub



Private Sub 信息_Click()
    If Me.TreeView1.Nodes.Count = 0 Then Exit Sub
    保存_Click '如此,要输入信息,就先保存节点数据吧!
    FrmInfo.Show 1
End Sub



Private Sub 信息P_Click()
    信息_Click
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.Expanded = True
    Next

    TreeView1_Click
    TreeView1.SelectedItem.EnsureVisible
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.Expanded = False
    Next

    TreeView1_Click
End Sub



'***************************************************************************
'保证程序不重复运行的检查过程
Public Sub CheckExist(fm As Form)
    Dim title As String
    If App.PrevInstance Then
       title = App.title
       Call MsgBox("[家谱]程序已执行!", vbCritical)
       
       '如此才不会Avtivate到自己
       App.title = ""
       fm.Caption = ""
       
       'Activate先前就已行的程序
       AppActivate title
       End
    End If
End Sub

'***************************************************************************
Sub 没有数据的显示()
    保存.Enabled = False
    打印.Enabled = False
    展开.Enabled = False
    收拢.Enabled = False
    查找.Enabled = False
    清除标识.Enabled = False
    信息.Enabled = False
    刷新.Enabled = False
    清理冗余文件.Enabled = False
    选项.Enabled = False
    
    保存P.Enabled = False
    删除P.Enabled = False
    查找P.Enabled = False
    信息P.Enabled = False
    
End Sub

'***************************************************************************
Sub 有数据的显示()

    '打印.Enabled = True
    
    展开.Enabled = True
    收拢.Enabled = True
    查找.Enabled = True
    
    '清除标识.Enabled = True
    
    信息.Enabled = True
    刷新.Enabled = True
    
    If DqpWData = True Then
        清理冗余文件.Enabled = True
    Else
        清理冗余文件.Enabled = False
        添加.Enabled = False
        添加P.Enabled = False
    End If
    
    选项.Enabled = True
    
    '保存P.Enabled = False
    '删除P.Enabled = False
    查找P.Enabled = True
    信息P.Enabled = True
    
End Sub
'***************************************************************************