frmclient.frm

来自「使用VB仿QQ界面开发的ICQ程序,采用C/S结架,实现简单文字聊天.」· FRM 代码 · 共 1,190 行 · 第 1/3 页

   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuFileLogOut 
         Caption         =   "注消(&L)"
      End
      Begin VB.Menu mnuFileSplit 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileStatus 
         Caption         =   "当前状态&S"
         Begin VB.Menu mnuStatusOnline 
            Caption         =   "在线(&O)"
            Checked         =   -1  'True
         End
         Begin VB.Menu mnuStatusAway 
            Caption         =   "隐身(&A)"
         End
      End
      Begin VB.Menu mnuStatusSplit 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileClose 
         Caption         =   "退出(&E)"
      End
   End
   Begin VB.Menu mnuPeople 
      Caption         =   "工具(&T)"
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuAbout 
         Caption         =   "关于(&A)"
      End
   End
   Begin VB.Menu mnuSystray 
      Caption         =   "&Systray"
      Visible         =   0   'False
      Begin VB.Menu mnuSystraySignOff 
         Caption         =   "注消 (&L)"
      End
      Begin VB.Menu mnuSystrayStatus 
         Caption         =   "状态 (&S)"
         Begin VB.Menu mnuSystrayOnline 
            Caption         =   "在线(&O)"
            Checked         =   -1  'True
         End
         Begin VB.Menu mnuSystrayAway 
            Caption         =   "隐身(&A)"
         End
      End
      Begin VB.Menu mnuSystraySep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuRestore 
         Caption         =   "还原 (&R)"
      End
      Begin VB.Menu mnuSystrayExit 
         Caption         =   "退出 (&E)"
      End
   End
   Begin VB.Menu mnuBuddyList 
      Caption         =   "&BuddyList"
      Visible         =   0   'False
      Begin VB.Menu mnuRemBuddy 
         Caption         =   "&Remove Buddy"
      End
   End
End
Attribute VB_Name = "frmClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'获得鼠标指针在屏幕坐标上的位置
Private Declare Function GetCursorPos Lib "user32" _
    (lpPoint As POINTAPI) As Long
'获得窗口在屏幕坐标中的位置
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, _
    lpRect As RECT) As Long
'判断指定的点是否在指定的巨型内部
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, _
    ByVal ptx As Long, ByVal pty As Long) As Long
'准备用来使窗体始终在最前面
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter _
    As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags _
    As Long) As Long
'用来移动窗体
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, _
    ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long

Const HWND_TOPMOST = -1
 
Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Is_Move_B As Boolean '判断指针是否位于移动栏(本例中移动栏位于窗体的侧一小地方)
Private Is_Movestar_B As Boolean '判断移动是否开始
Private MyRect As RECT
Private MyPoint As POINTAPI
Private Movex As Long, Movey As Long  '记录窗体移动前，窗体左上角与鼠标指针位置间的纵横距离
Private max As Long   '窗口变长以后的尺寸(用户可随意改动)

Dim strIncoming As String
Dim Start As Integer
Dim oldLabel As String
Dim Tic As NOTIFYICONDATA
Dim rc As Long

Sub Get_Windows_Rect()
        Dim dl&
        max = 5700       '默认窗体的高度
        Me.Height = max
        Me.Top = 0       '窗体始终放在屏幕顶部
        dl& = GetWindowRect(Me.hWnd, MyRect)
End Sub

Private Sub Form_Paint()
        '使窗体始终置于最前面
        If PtInRect(MyRect, MyPoint.x, MyPoint.y) = 0 Then
             SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
                  Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
                  Me.Height \ Screen.TwipsPerPixelY, 0
        End If
End Sub

Private Sub Timer1_Timer()
       Dim dl&
       dl& = GetCursorPos(MyPoint)
            If (PtInRect(MyRect, MyPoint.x, MyPoint.y) And _
                     Me.Height = max) Or MyPoint.y <= 3 Then
           '  If MyPoint.Y <= 3 Then
           '     Form1.BackColor = vbBlue     '窗体背景颜色(用户可随意改动)
                Me.Top = 0
                Me.Height = max
                     '判断鼠标指针是否位于窗体拖动区
                If MyPoint.x - MyRect.Left <= 10 Or Is_Movestar_B Then
                   Screen.MousePointer = 15
                   Is_Move_B = True
                Else
                   Screen.MousePointer = 0
                   Is_Move_B = False
                End If
            Else
               If Not Is_Movestar_B Then
                  Me.Height = 30    '窗体变小
                  Me.Top = -500
               End If
            End If
End Sub

'Private Sub Form_Initialize()
'    InitCommonControls
'End Sub

Private Sub Form_Load()
   labDate.Caption = "今天是：" & Format(Date, "yyyy年M月D日")
   Me.Width = 3045
   Me.Height = 5700
   Me.Left = Me.ScaleWidth * 2
   
   Get_Windows_Rect
   
End Sub

Private Sub Form_Terminate()
  Shell_NotifyIcon NIM_DELETE, Tic
End Sub

Private Sub cmdSignOn_Click()
    If Winsock1.State <> sckClosed Then Winsock1.Close
    Winsock1.RemotePort = gPort
    'Winsock1.RemoteHost = "216.77.225.246" 'put your IP here and comment out the one below
    Winsock1.RemoteHost = gHostIP      'to allow people to connect to your IP
    Winsock1.Connect
    
Do Until Winsock1.State = sckConnected
    DoEvents: DoEvents: DoEvents: DoEvents
    If Winsock1.State = sckError Then
        MsgBox "Problem connecting!"
        Exit Sub
    End If
Loop
    Winsock1.SendData (".login" & " " & LCase(cmbUsername.Text) & " " & LCase(txtPassword.Text))
End Sub

Private Sub lblStatus_Click()
    PopupMenu mnuFileStatus
End Sub

Private Sub DoSystrayIcon()
    Tic.cbSize = Len(Tic)
    Tic.hWnd = Me.hWnd
    Tic.uID = vbNull
    Tic.uFlags = NIF_DOALL
    Tic.uCallbackMessage = WM_MOUSEMOVE
    Tic.hIcon = Me.Icon
    Tic.sTip = "Kaotix Instant Messenger (" & YourSN & ")" & vbNullChar
    rc = Shell_NotifyIcon(NIM_ADD, Tic)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
        Dim msg As Long
        Dim sFilter As String
        msg = x / Screen.TwipsPerPixelX
        Select Case msg
            Case WM_RBUTTONUP
                PopupMenu mnuSystray
            Case WM_LBUTTONDBLCLK
                Me.Show
                'Me.WindowState = vbNormal
        End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Winsock1.State <> sckClosed Then Winsock1.Close
    End
End Sub

Private Sub Form_Resize()
 On Error Resume Next
'    If Me.Height < 5700 Then
'        Me.Height = 5700 '4000
'        Exit Sub
'    End If
'    If Me.Width < 3045 Then
'        Me.Width = 3045
'        Exit Sub
'    End If
    
    MainFrame.Width = Me.ScaleWidth
    MainFrame.Height = Me.ScaleHeight
    tbsOptions.Width = Me.ScaleWidth - 120
    tbsOptions.Height = Me.ScaleHeight - 560
    
    picOptions(0).Width = tbsOptions.Width - 100
    picOptions(0).Height = tbsOptions.Height - 400
    picOptions(1).Width = picOptions(0).Width
    picOptions(1).Height = picOptions(0).Height
    picOptions(2).Width = picOptions(0).Width
    picOptions(2).Height = picOptions(0).Height
    
    TreeView1.Width = picOptions(0).Width - 100 'tbsOptions.Width - 260
    TreeView1.Height = tbsOptions.Height - 1000
    TreeView2.Width = TreeView1.Width
    TreeView2.Height = tbsOptions.Height - 1000
    
    runlog.Width = TreeView1.Width - 100
    runlog.Top = tbsOptions.Height - 1400 ' TreeView1.Top + TreeView1.Height ' + 25
    
    cmdNewBuddy.Top = tbsOptions.Height - 900 '625
    cmdDelBuddy.Top = cmdNewBuddy.Top 'tbsOptions.Height - 625
    
    Shape1.Width = Me.ScaleWidth
    
    lblStatus.Left = Shape1.Width / 2 'Me.ScaleWidth - lblStatus.Width - 120
    labDate.Left = 120 '
    labDate.Top = picOptions(0).Height - 250
End Sub

Private Sub mnuAbout_Click()
frmAbout.Show vbModal
End Sub

Private Sub mnuRestore_Click()
Me.Show
'Me.WindowState = vbNormal
End Sub

Private Sub mnuSystrayAway_Click()
  Call mnuStatusAway_Click
End Sub

Private Sub mnuSystrayExit_Click()
  Call mnuFileClose_Click
End Sub

Private Sub mnuSystrayOnline_Click()
  Call mnuStatusOnline_Click
End Sub

Private Sub mnuSystraySignOff_Click()
  Call mnuFileLogOut_Click
End Sub

Private Sub tbsOptions_Click()
   Dim i As Integer
     '显示并使选项的控件可用
     '并且隐藏使其他被禁用
     For i = 0 To tbsOptions.Tabs.Count - 1
       If i = tbsOptions.SelectedItem.Index - 1 Then
          picOptions(i).Left = 100 '210
          picOptions(i).Enabled = True
        Else
          picOptions(i).Left = -20000
          picOptions(i).Enabled = False
       End If
     Next
End Sub

Private Sub TreeView1_Collapse(ByVal Node As MSComctlLib.Node)
    Node.Bold = False
    Node.Image = "right"
End Sub

Private Sub TreeView1_Expand(ByVal Node As MSComctlLib.Node)
    Node.Bold = True
    Node.Image = "down"
End Sub

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
If Node.Expanded = False Then
    Node.Expanded = True
Else
    Node.Expanded = False
End If
If Not Node.Parent Is Nothing Then
    If Node.Image <> 2 Then
            Dim test As Integer
            FormIsLoaded (TreeView1.SelectedItem)
    End If
End If
End Sub

Private Function FormIsLoaded(frm As String)
Dim FormNbr As Integer
Dim flag As Integer
flag = 0
For FormNbr = 0 To Forms.Count - 1
  If LCase(Word(Forms(FormNbr).Caption, 1)) = LCase(frm) Then
        Forms(FormNbr).SetFocus
        Exit Function
  Else
    flag = 1
  End If
Next FormNbr

If flag = 1 Then
    Dim NewIMessage As New frmIMessage
    NewIMessage.Show ownerform:=Me
'    NewIMessage.Caption = frm & " - Instant Message"
    NewIMessage.Caption = "与" & frm & "聊天" '" - Instant Message"
End If
End Function

Private Function GetFormNumber(frm As String) As Integer
Dim FormNbr As Integer
For FormNbr = 0 To Forms.Count - 1
  If LCase(Word(Forms(FormNbr).Caption, 1)) = LCase(frm) Then
        GetFormNumber = FormNbr
        Exit Function
 End If
Next FormNbr
End Function

Private Sub TreeView2_Collapse(ByVal Node As MSComctlLib.Node)
    Node.Bold = False
    cmdDelBuddy.Enabled = False
End Sub

Private Sub TreeView2_Expand(ByVal Node As MSComctlLib.Node)
    Node.Bold = True
End Sub

Private Sub TreeView2_BeforeLabelEdit(Cancel As Integer)
    oldLabel = TreeView2.SelectedItem.Text
End Sub

Private Sub TreeView2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then PopupMenu mnuBuddyList
End Sub


Private Sub TreeView2_NodeClick(ByVal Node As MSComctlLib.Node)
    If Node.Text <> "Buddies" Then
        cmdDelBuddy.Enabled = True
    Else
        cmdDelBuddy.Enabled = False
    End If
End Sub

Private Sub TreeView2_AfterLabelEdit(Cancel As Integer, NewString As String)
Dim tn As Node
If oldLabel <> "Buddies" Then
    If UCase(NewString) <> UCase(oldLabel) Then
        If Correct_Screenname(NewString) = True Then
            If check_for_duplicate(NewString) = True Then
                TreeView2.SelectedItem.Key = NewString
                For Each tn In TreeView1.Nodes
                    If UCase(tn.Key) = UCase(oldLabel) Then