mainfrm.frm

电话本信息 基本上实现电话功能 自己下载侃侃吧

  Form1.Caption = "将联系人" & IIf(Left(Node1.Key, 1) = "L", " ", "组 ") & Node1.Text & " 移动到..."
  Set Form1.MoveR = IIf(Left(Node1.Key, 1) = "R", Node1, Node1.Parent)
  Form1.Text1.Locked = True
  Form1.Show 1
  Set Form1 = Nothing
  If HasChange <> -100 Then
    '开始设置移动前的父节点图标
    If Node1.Parent.Children = 1 Then
      Node1.Parent.ForeColor = NoHaveChindColor
      If Node1.Parent.Key = "R-1" Then Node1.Parent.Image = ImageIndex6
      Node1.Parent.Image = ImageIndex3
      Node1.Parent.ExpandedImage = ImageIndex3
    ElseIf Node1.Parent.Key <> "R-1" Then
      If GetCRoot(Node1.Parent) - GetCRoot(Node1) = 1 Then
        Node1.Parent.Image = ImageIndex3
        Node1.Parent.ExpandedImage = ImageIndex3
      End If
    End If
    '开始设置移动后的父节点图标
    Set Node1.Parent = TV1.Nodes("R" & HasChange)
    Node1.Parent.ForeColor = HaveChindColor
    If Left(Node1.Key, 1) = "R" Then
      If Node1.Parent.Key = "R-1" Then
        Node1.Parent.Image = ImageIndex5
      Else
        Node1.Parent.Image = ImageIndex1
        Node1.Parent.ExpandedImage = ImageIndex2
      End If
    End If
    '将TreeView的焦点设置到被移动的节点
    Node1.Selected = True
  End If
  HasChange = -100
End Sub

'Private Sub StatusBar1_PanelClick(ByVal Panel As MSComctlLib.Panel)
'  If Panel.Index = 4 Then
'    Panel.Text = IIf(Panel.Text = "状态：查询", "State: Edit", "状态：查询")
'  End If
'End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
  Debug.Print Button.Key
End Sub

Private Sub T1_GotFocus(Index As Integer)
  On Error Resume Next
  
  If Frame3.Visible Then
     SelCombo.Width = SelCombo.Width + 650
     Frame3.Visible = False
     SelCombo.SelLength = 0
     Set SelCombo = Nothing
  End If
End Sub

Private Sub TA_Change(Index As Integer)
  If EditIndex Then TB1.Buttons("tSave").Enabled = True
End Sub

Private Sub TA_GotFocus(Index As Integer)
  On Error Resume Next
  
  If Frame3.Visible Then
     SelCombo.Width = SelCombo.Width + 650
     Frame3.Visible = False
     SelCombo.SelLength = 0
     Set SelCombo = Nothing
  End If
End Sub

Private Sub TB1_ButtonClick(ByVal Button As MSComctlLib.Button)
  Dim i As Long
  Select Case UCase(Button.Key)
    Case "TOPEN":
      m_Open_Click
    Case "TCLOSE":
      m_Close_Click
    Case "TNEWR":
      M_NewR_Click
    Case "TEDITR":
      m_NameR_Click
    Case "TDEL":
      m_Del_Click
    Case "TFIND":
      m_Find_Click
    Case "TEDIT":
      If EditIndex Then
        If TB1.Buttons("tSave").Enabled Then                '如果用户信息被修改，询问是否保存已修改的信息
          MsgBox "你已修改了当前用户的信息，是否保存？", vbYesNo Or vbQuestion Or vbDefaultButton1, "编辑用户信息"
        End If
        EditIndex = 0                                       '取消编辑状态
        StatusBar1.Panels(4).Text = sBar(0)
        TB1.Buttons("tSave").Enabled = False
        ClearALL
      Else
        M_Edit_Click
      End If
    Case "TSAVE":
      StatusBar1.Panels(4).Text = sBar(2)
      i = EditIndex
      If EditIndex = -1 Or EditIndex > 0 Then
        If Not SaveUserInfo(EditIndex, Val(Mid(TV1.Nodes("L" & EditIndex).Parent.Key, 2, Len(TV1.Nodes("L" & EditIndex).Parent.Key)))) Then
          If EditIndex > 0 Then
            
          End If
        Else
            TV1.Nodes("L" & i).Image = IC1.SelectedItem + 20
            TV1.Nodes("L" & i).Text = Trim(T1(0).Text)
            TV1.Nodes("L" & i).Key = "L" & EditIndex
            TB1.Buttons("tSave").Enabled = False
            StatusBar1.Panels(4).Text = sBar(1)
        End If
      End If
    Case "TNEW":
      M_New_Click
    Case Else:
    
  End Select
End Sub

Private Sub TV1_AfterLabelEdit(Cancel As Integer, NewString As String)
  Dim SQL As String, k As Long
  Dim RT As ADODB.Recordset
  
  On Error Resume Next
  StatusBar1.Panels(4).Text = sBar(0)
  k = Right(TV1.SelectedItem.Key, Len(TV1.SelectedItem.Key) - 1)
  If k < 0 Then Exit Sub
  Set RT = New ADODB.Recordset
  SQL = "Select * from " & RootName & " where ID=" & k
  RT.Open SQL, DataCON, adOpenKeyset, adLockOptimistic
  If RT.RecordCount > 0 Then
    RT.Fields("Name_" & LangSTR) = NewString
    RT.Update
  End If
  RT.Close: Set RT = Nothing
End Sub

Private Sub TV1_BeforeLabelEdit(Cancel As Integer)
  StatusBar1.Panels(4).Text = sBar(1)
End Sub

Private Sub TV1_DragDrop(Source As Control, x As Single, y As Single)
  Dim Node1 As Node
  Dim k As Long, i As Long, Int1 As Integer
  Dim SQL As String, RT As ADODB.Recordset
  
  On Error Resume Next
  Set Node1 = TV1.DropHighlight
  Set TV1.DropHighlight = Nothing
  
  If Not (Node1 Is Nothing) Then
    If Left(Node1.Key, 1) <> "R" Or Node1.Key = MoveNode.Key Then
        Set Node1 = Nothing
    Else
        k = Right(Node1.Key, Len(Node1.Key) - 1)
        i = Right(MoveNode.Key, Len(MoveNode.Key) - 1)
        If Left(MoveNode.Key, 1) = "L" Then
            SQL = "select * from JBXX where ID=" & i
        Else
            SQL = "select * from ZBXX where ID=" & i
        End If
        Set RT = New ADODB.Recordset
        RT.Open SQL, DataCON, adOpenKeyset, adLockOptimistic
        If RT.RecordCount > 0 Then
            RT.Fields("ZB") = k
            RT.Update
        End If
        RT.Close
        Set RT = Nothing
        With MoveNode.Parent    '设置原父节点的图标
            If .Key = "R-1" Then
                If .Children = 1 Then .Image = ImageIndex6
            ElseIf .Key <> "R0" And Left(MoveNode.Key, 1) = "R" Then
                If GetCRoot(MoveNode.Parent) - GetCRoot(MoveNode) = 1 Then
                    .Image = ImageIndex3
                    .ExpandedImage = ImageIndex3
                End If
            End If
            If GetCRoot(MoveNode.Parent, "RL") = 1 Then .ForeColor = NoHaveChindColor
        End With
        Set MoveNode.Parent = Node1
        Node1.ForeColor = HaveChindColor
        
        If Left(MoveNode.Key, 1) = "R" And k <> -1 Then
          Node1.Image = ImageIndex1
          Node1.ExpandedImage = ImageIndex2
        ElseIf k = -1 Then
          Node1.Image = ImageIndex5
        End If
    End If
  End If
  TV1.Drag vbEndDrag
  MoveNode.Expanded = MoveExpanded
  Set MoveNode = Nothing
  MoveFlag = False
  x = -100: y = -100
  TV1_DragOver Source, x, y, Int1
End Sub

Private Sub TV1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
    Static NoMove As Boolean
    Dim Node1 As Node
    
    On Error Resume Next
    
    If x <= -100 Or y <= -100 Then NoMove = False: Exit Sub
    If y > TV1.Height - 400 Then
      SCROLLMOVE TV1.hwnd, Vertical, SB_PAGEDOWN
    ElseIf y < 5 Then
      SCROLLMOVE TV1.hwnd, Vertical, SB_PAGEUP
    End If
    If x < 50 Then
      SCROLLMOVE TV1.hwnd, Horizontal, SB_PAGELEFT
    ElseIf x > TV1.Width - 500 Then
      SCROLLMOVE TV1.hwnd, Horizontal, SB_LINERIGHT
    End If
    If State = 1 Then GoTo NoMoveLOOP
    Set Node1 = TV1.HitTest(x, y)
    If Node1 Is Nothing Then GoTo NoMoveLOOP
    If Left(Node1.Key, 1) = "L" Or Node1.Key = MoveNode.Key Or Node1.Key = MoveNode.Parent.Key Then
NoMoveLOOP:
        If Not NoMove Then TV1.DragIcon = IList1.ListImages(ImageIndex4).ExtractIcon
        NoMove = True
        Set TV1.DropHighlight = Nothing
    Else
        If NoMove Then TV1.DragIcon = MoveNode.CreateDragImage
        NoMove = False
        If Not Node1.Expanded Then Node1.Expanded = True
        Set TV1.DropHighlight = Node1
    End If
End Sub

Private Sub TV1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim Node1 As Node
  
  On Error Resume Next
  
  If Button = vbLeftButton And Not MoveFlag Then
    Set MoveNode = TV1.HitTest(x, y)
    MoveFlag = Not (MoveNode Is Nothing)
    If MoveFlag Then
        MoveFlag = (MoveNode.Key = TV1.SelectedItem.Key) And MoveNode.Key <> "R0" And MoveNode.Key <> "R-1"
        If Not MoveFlag Then Set MoveNode = Nothing: Exit Sub
        MoveExpanded = MoveNode.Expanded
        Set TV1.SelectedItem = Nothing
        MoveNode.Expanded = False
        TV1.DragIcon = MoveNode.CreateDragImage
        TV1.Drag vbBeginDrag
    End If
  End If
End Sub

Private Sub TV1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Button = 2 Then
    Set MoveNode = TV1.DropHighlight
    If MoveNode Is Nothing Then Set MoveNode = TV1.SelectedItem
    If MoveNode Is Nothing Then Exit Sub
    
    m_Clear.Visible = MoveNode.Key = "R-1"
    m_Line0Z.Visible = m_Clear.Visible
    m_Line02.Visible = MoveNode.Key <> "R0" And MoveNode.Key <> "R-1"
    m_Remove.Visible = m_Line02.Visible
    
    If Left(MoveNode.Key, 1) = "R" Then
      M_New.Visible = MoveNode.Key <> "R-1"
      m_Line01.Visible = M_New.Visible
      m_Del.Visible = False
      M_Edit.Visible = False
      M_NewR.Visible = True
      m_DelR.Visible = MoveNode.Key <> "R0" And MoveNode.Key <> "R-1"
      m_NameR.Visible = True
      m_Find.Visible = True
    Else
      M_New.Visible = False
      m_Del.Visible = True
      M_Edit.Visible = True
      M_NewR.Visible = False
      m_DelR.Visible = False
      m_NameR.Visible = False
      m_Line01.Visible = False
      m_Find.Visible = False
    End If
    Me.PopupMenu mTVMenu, , x + TV1.Left + Frame1.Left + 50, y + TV1.Top + Frame1.Top
  End If
End Sub

Private Sub TV1_NodeClick(ByVal Node As MSComctlLib.Node)
  Dim i As Long, k As Long, STR As String
  Dim RT As ADODB.Recordset
  
  On Error Resume Next
  MoveFlag = False
  If "L" & EditIndex = Node.Key Then Exit Sub
  If TB1.Buttons("tSave").Enabled Or EditIndex = -1 Then              '如果用户信息被修改，询问是否保存已修改的信息
    If MsgBox("提示：" & vbCrLf & "你已经修改了 " & TV1.Nodes("L" & EditIndex).Text & " 用户信息，是否保存当前信息？", vbQuestion Or vbYesNo, Me.Caption) = vbYes Then
      TB1_ButtonClick TB1.Buttons("tSave")
    ElseIf EditIndex < 0 Then
      TV1.Nodes.Remove "L-1"
    End If
  End If
  ClearALL , True
  TB1.Buttons("tSave").Enabled = False
  TB1.Buttons("tEdit").Value = tbrUnpressed
  StatusBar1.Panels(4).Text = sBar(0)
  EditIndex = 0
  With Node
    If Left(.Key, 1) = "L" Then
        TB1.Buttons("tOpen").Enabled = False
        TB1.Buttons("tClose").Enabled = False
        TB1.Buttons("tEdit").Enabled = True
        TB1.Buttons("tEditR").Enabled = False
        TB1.Buttons("tNewR").Enabled = False
        TB1.Buttons("tNew").Enabled = False
        GetUserInfo Val(Right(.Key, Len(.Key) - 1))
    Else
        TB1.Buttons("tNewR").Enabled = True
        TB1.Buttons("tNew").Enabled = True
        TB1.Buttons("tEdit").Enabled = False
        TB1.Buttons("tEditR").Enabled = True
        TB1.Buttons("tOpen").Enabled = True
        TB1.Buttons("tClose").Enabled = True
    End If
    If .Key = "R0" Then
       TB1.Buttons("tDel").Enabled = False
    ElseIf .Key = "R-1" Then
       TB1.Buttons("tDel").Enabled = GetCRoot(Node, "RL") > 0
    Else
      TB1.Buttons("tDel").Enabled = True
    End If
  End With
End Sub

Private Sub ClearALL(Optional ByVal Mode As Boolean = False, Optional ByVal ClearText As Boolean = False)
  Dim k As Long
  
  IC1.Enabled = Mode
  Frame4.Enabled = Mode
  Mode = Not Mode
  
  On Error Resume Next
  
  If Frame3.Visible Then
     SelCombo.Width = SelCombo.Width + 650
     Frame3.Visible = False
     SelCombo.SelLength = 0
     Set SelCombo = Nothing
  End If
  
  If ClearText Then
    IC1.Text = vbNullString
    For k = CImage.LBound To CImage.UBound
      CImage(k).Enabled = False
    Next
    For k = 0 To UBound(ComboListIndex)
      ComboListIndex(k) = -1
    Next k
    PBox.Cls
    DisposeImage
    LT1.Visible = True
  End If
  
  Combo1(0).Locked = Mode
  If ClearText Then Combo1(0).ListIndex = -1
  For k = 0 To 5
    If k < 3 Then
      TA(k).Locked = Mode
      If ClearText Then TA(k).Text = vbNullString
    End If
    If k