mainform.frm

群里的通讯录管理 供参考 学习专用 无其他商业意义 源码较为简单

    trvAll.Nodes.Clear
    IniGroupInTreeView
End Sub

'***********************************************************************
'* 过程名：RefreshGroupInTreeView
'* 功  能：刷新TreeView中的组信息
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub RefreshGroupInTreeView()
    '变量定义
    Dim rs As ADODB.Recordset           '记录集
    Dim currentNode As Node             '当前组节点
    Dim nodeKey As String               '节点KEY
    Dim iLoop As Integer                '循环变量
    Dim existFlag As Boolean            '已存在标志
    Dim nodeindex As Integer            '节点index
    
    '取得组信息记录集
    Set rs = GetGroupRecordset()
    
    '添加组
    If IsObject(rs) Then
        While Not rs.EOF
            '查找节点是否已存在
            nodeKey = GROUPKEYPRE & rs("groupid")
            existFlag = False
            For iLoop = 1 To trvAll.Nodes.Count
                If trvAll.Nodes.Item(iLoop).key = nodeKey Then
                    nodeindex = iLoop
                    existFlag = True
                    Exit For
                End If
            Next
            
            If existFlag Then   '组已存在,刷新组成员
                RefreshPeopleInGroup rs("groupid"), nodeindex
            Else    '组不存在，追加新组
                Set currentNode = trvAll.Nodes.Add(, tvwLast, _
                    GROUPKEYPRE & rs("groupid"), rs("groupname"))
                currentNode.Selected = True
                '添加组成员
                IniPeopleInGroup rs("groupid"), currentNode.index
            End If
            rs.MoveNext
        Wend
        rs.Close
        Set rs = Nothing
    End If
End Sub

'***********************************************************************
'* 过程名：RefreshPeopleInGroup
'* 功  能：初始化组成员信息
'* 参  数：Long                         组ID
'*       ：Integer                      组节点index
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub RefreshPeopleInGroup(ByVal groupkey As Long, _
            ByVal index As Integer)
    '变量定义
    Dim rs As ADODB.Recordset       '记录集
    Dim iLoop As Integer            '循环变量
    Dim existFlag As Boolean        '存在标志
    Dim curNode As Node             '节点
    Dim nodeKey As String           '节点KEY
    
    '取得指定组成员信息
     Set rs = GetGroupMember(groupkey)
     
     '添加组成员
     If IsObject(rs) Then
        While Not rs.EOF
            '查找是否已存在
            nodeKey = PEOPLEKEYPRE & CStr(rs("peopleId"))
            existFlag = False
            If trvAll.Nodes.Item(index).Children Then
                Set curNode = trvAll.Nodes.Item(index).Child
                Do While Not curNode Is Nothing
                    If curNode.key = nodeKey Then
                        existFlag = True
                        Exit Do
                    End If
                    Set curNode = curNode.Next
                Loop
            End If
            
            If Not existFlag Then
                Set curNode = trvAll.Nodes.Add(index, tvwChild, PEOPLEKEYPRE & _
                    CStr(rs("peopleId")), rs("peopleName"))
                curNode.Selected = True
            End If
            rs.MoveNext
        Wend
        rs.Close
        Set rs = Nothing
     End If
End Sub


'***********************************************************************
'* 过程名：RefreshTreeView
'* 功  能：刷新TreeView
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Public Sub RefreshTreeView()
    RefreshGroupInTreeView
    trvAll_Click
End Sub

'***********************************************************************
'* 过程名：RefreshCurPeoplePhoto
'* 功  能：刷新当前联系人像片信息
'* 参  数：
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Public Sub RefreshCurPeoplePhoto()
    '取得选择条目的KEY
    Dim key As String
    
    '有选择条目
    If Not trvAll.SelectedItem Is Nothing Then
        key = trvAll.SelectedItem.key
        
        '判断是组还是人员
        If Left(key, Len(PEOPLEKEYPRE)) = PEOPLEKEYPRE Then
            '取得像片信息
            GetPhotoArray CLng(Mid(key, Len(PEOPLEKEYPRE) + 1))
        End If
    End If
End Sub


'***********************************************************************
'* 过程名：DspPeopleInfo
'* 功  能：显示人员信息
'* 参  数：Long                         联系人ID
'* 版  本：2005.12.15 颜志军 初版
'***********************************************************************
Private Sub DspPeopleInfo(ByVal peopleId As Long)
    '变量定义
    Dim currentPeopleInfo As PeopleInfo '人员信息
    
    '取得信息
    If GetSinglePeopleInfo(peopleId, currentPeopleInfo) Then
        '显示信息
        '基本信息
        lblName.Caption = currentPeopleInfo.peopleName
        lblSex.Caption = currentPeopleInfo.sex
        
        '公司信息
        lblCompanyName.Caption = currentPeopleInfo.companyName
        lblCompanyDepartment.Caption = currentPeopleInfo.companyDepartment
        lblApointMent.Caption = currentPeopleInfo.appointment
        lblCompanyAddress.Caption = currentPeopleInfo.companyAddress
        lblCompanyPostCode.Caption = currentPeopleInfo.companyPostcode
        lblCompanyPhone.Caption = currentPeopleInfo.companyPhone
        lblCompanyFax.Caption = currentPeopleInfo.companyFax
        lblCompanyWebsite.Caption = currentPeopleInfo.compnaywebsite
        
        '家庭信息
        lblFamilyAddress.Caption = currentPeopleInfo.familyAddress
        lblFamilyPostcode.Caption = currentPeopleInfo.familyPostcode
        lblFamilyPhone.Caption = currentPeopleInfo.familyPhone
        
        '人个信息
        lblMobilePhone.Caption = currentPeopleInfo.mobilePhone
        lblHomepage.Caption = currentPeopleInfo.homepage
        lblEmail.Caption = currentPeopleInfo.email
        lblEmailbak.Caption = currentPeopleInfo.emailbak
        lblMSN.Caption = currentPeopleInfo.MSN
        lblQQ.Caption = currentPeopleInfo.QQ
        lblQQbak.Caption = currentPeopleInfo.QQbak
        
        '备注
        txtOtherInfo.Text = currentPeopleInfo.otherInfo
    End If
End Sub

'***********************************************************************
'* 过程名：GetPhotoArray
'* 功  能：取得当前联系人像片信息
'* 参  数：Long                         联系人ID
'* 版  本：2005.12.16 颜志军 初版
'***********************************************************************
Private Sub GetPhotoArray(ByVal peopleId As Long)
    '清除此前数组中内容
    Erase photoArray
    '清除显示的像片
    ImagePhoto.Picture = LoadPicture
    photoIndex = -1
    
    '取得当前联系人像片信息
    If GetPeoplePhoto(peopleId, photoArray) Then
        If SafeArrayGetDim(photoArray) > 0 Then
            If UBound(photoArray) > 0 Then
                DspPhoto ImagePhoto, App.Path & _
                    "\photo\" & photoArray(0).photoFile
                photoIndex = 0
            End If
        End If
    End If
    
    '改变按钮可用状态
    SetPhotoButtonEnable
End Sub

'***********************************************************************
'* 过程名：SetPhotoButtonEnable
'* 功  能：像片按钮可用状态设定
'* 参  数：
'* 版  本：2005.12.16 颜志军 初版
'***********************************************************************
Private Sub SetPhotoButtonEnable()
    '变量定义
    Dim photoNum As Integer '像片数量
    '取得像片数量
    If SafeArrayGetDim(photoArray) > 0 Then
        photoNum = UBound(photoArray)
    Else
        photoNum = 0
    End If
    
    '可用状态设定
    If photoNum <= 1 Then
        '上下按钮均不可用
        cmdPre.Enabled = False
        cmdNext.Enabled = False
    Else
        cmdPre.Enabled = True
        cmdNext.Enabled = True
        
        If photoIndex = 0 Then
            cmdPre.Enabled = False
        End If
        
        If photoIndex = photoNum - 1 Then
            cmdNext.Enabled = False
        End If
    End If
End Sub

'***********************************************************************
'* 过程名：cmdPre_Click
'* 功  能：下一张像片按钮事件响应
'* 参  数：
'* 版  本：2005.12.16 颜志军 初版
'***********************************************************************
Private Sub cmdNext_Click()
    '变量定义
    Dim photoNum As Integer '像片数量
    
    '取得像片数量
    If SafeArrayGetDim(photoArray) > 0 Then
        photoNum = UBound(photoArray)
    Else
        photoNum = 0
    End If
    
    '显示像片
    If photoNum > 0 And photoIndex < photoNum - 1 Then
        photoIndex = photoIndex + 1
        DspPhoto ImagePhoto, App.Path & _
                    "\photo\" & photoArray(photoIndex).photoFile
    End If
    
    '改变按钮可用状态
    SetPhotoButtonEnable
End Sub

'***********************************************************************
'* 过程名：cmdPre_Click
'* 功  能：上一张像片按钮事件响应
'* 参  数：
'* 版  本：2005.12.16 颜志军 初版
'***********************************************************************
Private Sub cmdPre_Click()
    '变量定义
    Dim photoNum As Integer '像片数量
    
    '取得像片数量
    If SafeArrayGetDim(photoArray) > 0 Then
        photoNum = UBound(photoArray)
    Else
        photoNum = 0
    End If
    
    '显示像片
    If photoNum > 0 And photoIndex > 0 Then
        photoIndex = photoIndex - 1
        DspPhoto ImagePhoto, App.Path & _
                    "\photo\" & photoArray(photoIndex).photoFile
    End If
    
    '改变按钮可用状态
    SetPhotoButtonEnable
End Sub

'***********************************************************************
'* 过程名：Form_Load
'* 功  能：窗体LOAD事件响应
'* 参  数：
'* 版  本：2005.12.14 颜志军 初版
'***********************************************************************
Private Sub Form_Load()
    '初始化TREEVIEW
    IniTreeView
    '设定像片更换按钮可用状态
    SetPhotoButtonEnable
    '当前像片INDEX
    photoIndex = -1
End Sub

'***********************************************************************
'* 过程名：Form_Unload
'* 功  能：窗体UnLOAD事件响应
'* 参  数：
'* 版  本：2005.12.14 颜志军 初版
'***********************************************************************
Private Sub Form_Unload(Cancel As Integer)
    '关闭数据库连接
    CloseDbConn
End Sub

'***********************************************************************
'* 过程名：ImagePhoto_MouseDown
'* 功  能：图片显示控件鼠标DOWN事件响应
'* 参  数：
'* 版  本：2005.12.14 颜志军 初版
'***********************************************************************
Private Sub ImagePhoto_MouseDown(Button As Integer, Shift As Integer, _
        x As Single, y As Single)
    '鼠标右键按下弹出菜单
    If Button = vbRightButton Then
        PopupMenu PopMenu_Photo
    End If
End Sub

'***********************************************************************
'* 过程名：Menu_AppendNewGroup_Click