frmfriends.frm

用VB6.0编写的QQ聊天软件

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmFriends 
   Caption         =   "好友信息"
   ClientHeight    =   5895
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   9045
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmFriends.frx":0000
   LockControls    =   -1  'True
   ScaleHeight     =   393
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   603
   StartUpPosition =   2  'CenterScreen
   Begin MSComctlLib.ListView lvUsers 
      CausesValidation=   0   'False
      Height          =   3855
      Left            =   2580
      TabIndex        =   0
      Top             =   0
      Width           =   5055
      _ExtentX        =   8916
      _ExtentY        =   6800
      Arrange         =   2
      LabelEdit       =   1
      LabelWrap       =   0   'False
      HideSelection   =   0   'False
      OLEDragMode     =   1
      FullRowSelect   =   -1  'True
      GridLines       =   -1  'True
      PictureAlignment=   2
      TextBackground  =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483630
      BackColor       =   -2147483643
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      OLEDragMode     =   1
      NumItems        =   0
   End
   Begin MSComctlLib.TreeView tvUsers 
      CausesValidation=   0   'False
      Height          =   3855
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   2535
      _ExtentX        =   4471
      _ExtentY        =   6800
      _Version        =   393217
      HideSelection   =   0   'False
      LabelEdit       =   1
      Style           =   7
      FullRowSelect   =   -1  'True
      HotTracking     =   -1  'True
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      OLEDragMode     =   1
   End
   Begin MSComctlLib.ProgressBar pbStatus 
      Align           =   2  'Align Bottom
      Height          =   285
      Left            =   0
      TabIndex        =   2
      Top             =   5610
      Width           =   9045
      _ExtentX        =   15954
      _ExtentY        =   503
      _Version        =   393216
      BorderStyle     =   1
      Appearance      =   1
      Enabled         =   0   'False
      Max             =   1
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuFileClose 
         Caption         =   "关闭(&C)"
      End
   End
   Begin VB.Menu mnuLook 
      Caption         =   "查看(&L)"
      Begin VB.Menu mnuLookSingle 
         Caption         =   "个人资料(&S)"
      End
      Begin VB.Menu mnuLook0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuLookRefresh 
         Caption         =   "刷新(&R)"
         Shortcut        =   {F5}
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpTheme 
         Caption         =   "主题(&T)"
         Shortcut        =   {F1}
      End
      Begin VB.Menu mnuHelp0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A)..."
      End
   End
End
Attribute VB_Name = "frmFriends"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub tkRefreshFriends()
    On Error Resume Next
    While tvUsers.Nodes.Count > 0
        tvUsers.Nodes.Remove 1
        tvUsers.Nodes.Clear
    Wend
    While lvUsers.ListItems.Count > 0
        lvUsers.ListItems.Clear
    Wend
    tvUsers.Nodes.Add , , "用户", "用户", frmMain.imgLstFaces.ListImages.Count
    tvAddList
End Sub

Private Sub Form_Load()
    tkNoPopup = True
    tkViewFriend = True
    Me.Icon = frmMain.imgLstTools.ListImages(3).Picture
    tvUsers.ImageList = frmMain.imgLstFaces
    With lvUsers
        .Icons = frmMain.imgLstFaces
        .SmallIcons = frmMain.imgLstFaces
    End With
End Sub

Private Sub tvAddList()
    On Error Resume Next
    Dim strID As String
    
    If rst.State = adStateOpen Then rst.Close
    rst.Open "SELECT 标识,昵称,头像 FROM 用户", cnn, adOpenKeyset, adLockReadOnly
    
    If rstTemp.State = adStateOpen Then rstTemp.Close
    rstTemp.Open "SELECT 标识,昵称,头像 FROM 用户", cnn, adOpenKeyset, adLockReadOnly
    If rst.RecordCount = 0 Then
        pbStatus.Max = rst.RecordCount + 1
    Else
        pbStatus.Max = rst.RecordCount
    End If
    While Not rst.EOF
        strID = "用户" & rst!标识
        tvUsers.Nodes.Add "用户", tvwChild, strID, rst!昵称, Val(rst!头像)
        pbStatus.Value = pbStatus.Value + 1
        
        If rstFriends.State = adStateOpen Then rstFriends.Close
        rstFriends.Open "SELECT 好友 FROM 用户好友 WHERE 标识='" & rst!标识 & "'", cnn, adOpenKeyset, adLockReadOnly
        If rstFriends.RecordCount > 0 Then
            While Not rstFriends.EOF
                If rstTemp.State = adStateOpen Then rstTemp.Close
                rstTemp.Open "SELECT 昵称,头像 FROM 用户 WHERE 标识='" & rstFriends!好友 & "'", cnn, adOpenKeyset, adLockReadOnly
                
                tvUsers.Nodes.Add strID, tvwChild, strID & "好友" & rstFriends!好友, rstTemp!昵称, Val(rstTemp!头像)
                rstFriends.MoveNext
            Wend
        End If
        
        rst.MoveNext
    Wend
    pbStatus.Value = 0
    If tvUsers.Nodes.Count > 1 Then
        tvUsers.Nodes(2).EnsureVisible
    End If
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    With tvUsers
        .Move .Left, .Top, .Width, Me.ScaleHeight - pbStatus.Height
    End With
    With lvUsers
        .Move .Left, .Top, Me.ScaleWidth - tvUsers.Width - 4, Me.ScaleHeight - pbStatus.Height
    End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If pbStatus.Value = 0 Then
        tkNoPopup = False
        tkViewFriend = False
    Else
        Cancel = 1
    End If
End Sub

Private Sub lvUsers_DblClick()
    On Error Resume Next
    Dim iPos As Integer
    If lvUsers.ListItems.Count > 0 Then
        If InStr(1, lvUsers.SelectedItem.Key, "友") + 1 > 1 Then
            iPos = InStr(1, lvUsers.SelectedItem.Key, "友") + 1
        ElseIf InStr(1, lvUsers.SelectedItem.Key, "户") + 1 > 1 Then
            iPos = InStr(1, lvUsers.SelectedItem.Key, "户") + 1
        End If
    Else
        Exit Sub
    End If
    tkUserID = Mid(lvUsers.SelectedItem.Key, iPos, Len(lvUsers.SelectedItem.Key))
    frmUserInfo.Show vbModal
End Sub

Private Sub lvUsers_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim iMenu As Long
    Dim iPos As POINTAPI
    If pbStatus.Value = 0 Then
        If Button = vbRightButton Then
            iMenu = GetMenu(Me.hwnd)
            iMenu = GetSubMenu(iMenu, 1)
            GetCursorPos iPos
            TrackPopupMenu iMenu, _
                    TPM_LEFTBUTTON Or TPM_RIGHTBUTTON, _
                    iPos.x, iPos.y, _
                    0, Me.hwnd, 0
            'PopupMenu mnuLook, vbPopupMenuLeftButton Or vbPopupMenuRightButton
        End If
    End If
End Sub

Private Sub mnuFileClose_Click()
    Unload Me
End Sub

Private Sub mnuHelpAbout_Click()
    ShellAbout Me.hwnd, _
        Me.Caption, _
        "孙建华" & vbCrLf & "[e-mail]", _
        tkCursor
End Sub

Private Sub mnuLookRefresh_Click()
    If pbStatus.Value = 0 Then
        tkRefreshFriends
    End If
End Sub

Private Sub mnuLookSingle_Click()
    lvUsers_DblClick
End Sub

Private Sub tvUsers_DblClick()
    On Error Resume Next
    If tvUsers.Nodes.Count > 0 Then
        If tvUsers.SelectedItem.Index > 1 Then
            If tvUsers.SelectedItem.Parent <> tvUsers.SelectedItem.Root Then
                lvUsers_DblClick
            End If
        End If
    End If
End Sub

Private Sub tvUsers_NodeClick(ByVal Node As MSComctlLib.Node)
    On Error Resume Next
    Node.Expanded = Not Node.Expanded
    Dim iCount As Long
    pbStatus.Max = tvUsers.Nodes.Count
    If Node.Key = "用户" Or InStr(1, Node.Key, "好友") = 0 Then
        While lvUsers.ListItems.Count > 0
            lvUsers.ListItems.Clear
        Wend
        If Node.Children > 0 Then
            For iCount = Node.Index + 1 To tvUsers.Nodes.Count
                If tvUsers.Nodes(iCount).Parent.Key = Node.Key Then
                    lvUsers.ListItems.Add , tvUsers.Nodes(iCount).Key, tvUsers.Nodes(iCount).Text, tvUsers.Nodes(iCount).Image
                End If
                pbStatus.Value = iCount
            Next iCount
            pbStatus.Value = 0
        End If
    Else
        lvUsers.ListItems(Node.Index - Node.Parent.Index).Selected = True
    End If
End Sub