frmimessage.frm

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

      EndProperty
      Height          =   195
      Left            =   5040
      TabIndex        =   6
      Top             =   3120
      Width           =   600
   End
   Begin VB.Line Line2 
      BorderColor     =   &H00FFFFFF&
      X1              =   0
      X2              =   5880
      Y1              =   10
      Y2              =   10
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00808080&
      X1              =   0
      X2              =   5880
      Y1              =   0
      Y2              =   0
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&F)"
      Begin VB.Menu mnuOpen 
         Caption         =   "打开(&O)"
      End
      Begin VB.Menu mnuFileSave 
         Caption         =   "保存(&S)"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuFileSaveAs 
         Caption         =   "另存为(&A)..."
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuEditBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFilePageSetup 
         Caption         =   "页面设置(&U)"
      End
      Begin VB.Menu mnuFilePrint 
         Caption         =   "打印(&P)"
      End
      Begin VB.Menu mnuEditBar3 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出(&E)"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "编辑(&E)"
      Begin VB.Menu mnuEditUndo 
         Caption         =   "撤消(&U)"
      End
      Begin VB.Menu mnuEditBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuEditCut 
         Caption         =   "剪切(&T)"
         Shortcut        =   ^X
      End
      Begin VB.Menu mnuEditCopy 
         Caption         =   "复制(&C)"
         Shortcut        =   ^C
      End
      Begin VB.Menu mnuEditPaste 
         Caption         =   "粘贴(&P)"
         Shortcut        =   ^V
      End
      Begin VB.Menu mnuEditBar2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFont 
         Caption         =   "文字格式(&F)"
         Begin VB.Menu mnuFontBold 
            Caption         =   "加粗(&B)"
            Shortcut        =   ^B
         End
         Begin VB.Menu mnuFontItalic 
            Caption         =   "斜体(&I)"
            Shortcut        =   ^I
         End
         Begin VB.Menu mnuFontUnderline 
            Caption         =   "下划线(&U)"
            Shortcut        =   ^U
         End
      End
      Begin VB.Menu mnuFontSplit 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFontSize 
         Caption         =   "字体大小(&F)"
         Begin VB.Menu mnuFontPT 
            Caption         =   "8 pt"
            Index           =   0
         End
         Begin VB.Menu mnuFontPT 
            Caption         =   "10 pt"
            Index           =   1
         End
         Begin VB.Menu mnuFontPT 
            Caption         =   "12 pt"
            Index           =   2
         End
         Begin VB.Menu mnuFontPT 
            Caption         =   "14 pt"
            Index           =   3
         End
      End
   End
   Begin VB.Menu mnuUser 
      Caption         =   "其它(&Z)"
      Begin VB.Menu mnuSendFile 
         Caption         =   "发送文件(&S)"
      End
      Begin VB.Menu mnuSetting 
         Caption         =   "个人设置(&P)"
      End
   End
End
Attribute VB_Name = "frmIMessage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim dWord As String

Private Sub cmbFonts_Click()
    TypeMsg.SelFontName = cmbFonts.Text
    TypeMsg.SetFocus
End Sub

Private Sub CmdClose_Click()
  Unload Me
End Sub

Private Sub cmdSend_Click()
 TypeMsg.Text = Replace(TypeMsg.Text, vbCrLf, "")
If TypeMsg.Text <> "" And Len(TypeMsg) > 0 Then
    ShowMsg.SelStart = Len(ShowMsg.Text)
    ShowMsg.SelBold = True
    ShowMsg.SelColor = vbRed
    ShowMsg.SelText = YourSN & ": "
        
    ShowMsg.SelStart = Len(ShowMsg.Text)
    ShowMsg.SelBold = False
    ShowMsg.SelColor = vbBlack
    ShowMsg.SelText = TypeMsg.Text & vbCrLf
  
    sndPlaySound App.Path + "\sounds\imsend.wav", 1
    frmClient.Winsock1.SendData ".msg " & YourSN & " " & Word(Me.Caption, 1) & " ..//.. " & TypeMsg.Text
    frmClient.WaitFor (".msgOK")
    TypeMsg.Text = ""
End If
 TypeMsg.Text = Replace(TypeMsg.Text, vbCrLf, "")
 TypeMsg.SetFocus
 TypeMsg.Text = Replace(TypeMsg.Text, vbCrLf, "")
End Sub

Private Sub Form_Initialize()
    InitCommonControls
End Sub

Private Sub Form_Load()
Dim i As Integer
    'bAllowScroll = True
    'Call SetHook(showmsg.hwnd, True)
    For i = 1 To Screen.FontCount
        cmbFonts.AddItem Screen.Fonts(i)
    Next i
    cmbFonts.RemoveItem (0)
    cmbFonts.SelText = "PMingLiU"
    
    wsListen.LocalPort = FT_USE_PORT
    wsListen.Listen
  
End Sub


'Private Sub Form_Unload(Cancel As Integer)
    'Call SetHook(showmsg.hwnd, False)
'End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.ShowMsg.SelRTF
End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.ShowMsg.SelRTF
    ActiveForm.rtfText.SelText = vbNullString
End Sub

Private Sub mnuEditPaste_Click()
    On Error Resume Next
    ActiveForm.ShowMsg.SelRTF = Clipboard.GetText
End Sub

Private Sub mnuEditUndo_Click()
 On Error Resume Next
 '
End Sub

Private Sub mnuFilePageSetup_Click()
   On Error Resume Next
    With dlgCommonDialog
        .DialogTitle = "页面设置"
        .CancelError = True
        .ShowPrinter
    End With
End Sub

Private Sub mnuOpen_Click()
  Dim sFile As String
   With dlgCommonDialog
        .DialogTitle = "打开"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有文件 (*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.ShowMsg.LoadFile sFile
    ActiveForm.Caption = sFile
End Sub

Private Sub mnuFilePrint_Click()
   On Error Resume Next
    If ActiveForm Is Nothing Then Exit Sub
     With dlgCommonDialog
        .DialogTitle = "Print"
        .CancelError = True
        .Flags = cdlPDReturnDC + cdlPDNoPageNums
        If ActiveForm.ShowMsg.SelLength = 0 Then
            .Flags = .Flags + cdlPDAllPages
        Else
            .Flags = .Flags + cdlPDSelection
        End If
        .ShowPrinter
        If Err <> MSComDlg.cdlCancel Then
            ActiveForm.ShowMsg.SelPrint .hdc
        End If
    End With
End Sub

Private Sub mnuFileSave_Click()
   Dim sFile As String
    If Left$(ActiveForm.Caption, 8) = "Document" Then
        With dlgCommonDialog
            .DialogTitle = "保存"
            .CancelError = False
            'ToDo: 设置 common dialog 控件的标志和属性
            .Filter = "所有文件 (*.*)|*.*"
            .ShowSave
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            sFile = .FileName
        End With
        ActiveForm.ShowMsg.SaveFile sFile
    Else
        sFile = ActiveForm.Caption
        ActiveForm.ShowMsg.SaveFile sFile
    End If
End Sub

Private Sub mnuFileSaveAs_Click()
    Dim sFile As String
    If ActiveForm Is Nothing Then Exit Sub
    With dlgCommonDialog
        .DialogTitle = "另存为"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有文件 (*.*)|*.*"
        .ShowSave
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.Caption = sFile
    ActiveForm.ShowMsg.SaveFile sFile

End Sub

Private Sub mnuFontBold_Click()
  If TypeMsg.SelBold = True Then
     TypeMsg.SelBold = False
     tbFonts.Buttons(1).Value = tbrUnpressed
   Else
     TypeMsg.SelBold = True
     tbFonts.Buttons(1).Value = tbrPressed
  End If
End Sub

Private Sub mnuFontItalic_Click()
  If TypeMsg.SelItalic = True Then
     TypeMsg.SelItalic = False
     tbFonts.Buttons(2).Value = tbrUnpressed
   Else
     TypeMsg.SelItalic = True
     tbFonts.Buttons(2).Value = tbrPressed
  End If
End Sub

Private Sub mnuFontUnderline_Click()
 If TypeMsg.SelUnderline = True Then
    TypeMsg.SelUnderline = False
    tbFonts.Buttons(3).Value = tbrUnpressed
  Else
    TypeMsg.SelUnderline = True
    tbFonts.Buttons(3).Value = tbrPressed
 End If
End Sub

Private Sub mnuFontPT_Click(Index As Integer)
    TypeMsg.SelFontSize = Word(mnuFontPT(Index).Caption, 1)
End Sub

Private Function is_chars(x As String) As Boolean
Dim i As Integer
Dim flag As Integer
For i = 1 To Len(x)
    If (Asc(UCase(Mid(x, i, 1))) >= vbKeyA And Asc(UCase(Mid(x, i, 1))) <= vbKeyZ) Or Mid(x, i, 1) = " " Then
        flag = 0
    Else
        flag = 1
        Exit For
        is_chars = False
    End If
Next i

If flag = 0 Then
    is_chars = True
End If
   
End Function

Private Sub tbFonts_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Index
     Case 1
        mnuFontBold_Click
     Case 2
        mnuFontItalic_Click
     Case 3
        mnuFontUnderline_Click
     Case 5
        If TypeMsg.SelFontSize > 8 Then
           TypeMsg.SelFontSize = TypeMsg.SelFontSize - 2
        End If
     Case 6
        If TypeMsg.SelFontSize < 14 Then
           TypeMsg.SelFontSize = TypeMsg.SelFontSize + 2
        End If
End Select
End Sub

Private Sub typemsg_Change()
  Label1 = Len(TypeMsg.Text) & "/2048"
End Sub

Private Sub typemsg_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyRight Or KeyCode = vbKeyLeft Or KeyCode = vbKeyDown Or KeyCode = vbKeyUp Then
     typemsg_Click
  End If
End Sub

Private Sub typemsg_KeyPress(KeyAscii As Integer)
  If KeyAscii = vbKeyReturn Then
     Call cmdSend_Click
  End If
End Sub

Private Sub typemsg_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo HandleError
If Button = vbRightButton Then
        If TypeMsg.SelText <> "" And is_chars(Replace(Trim(TypeMsg.SelText), vbCrLf, "")) = True Then
            dWord = Replace(Trim(TypeMsg.SelText), vbCrLf, "")
        Else
            dWord = "- Please highlight a word."
        End If
        mnuSpell.Caption = "Spellcheck " & dWord
        mnuDefine.Caption = "Define " & dWord
    
    If TypeMsg.SelBold = True Then
       mnuFontBold.Checked = True
    Else
       mnuFontBold.Checked = False
    End If
    
    If TypeMsg.SelItalic = True Then
       mnuFontItalic.Checked = True
    Else
       mnuFontItalic.Checked = False
    End If
    
    If TypeMsg.SelUnderline = True Then
       mnuFontUnderline.Checked = True
    Else
       mnuFontUnderline.Checked = False
    End If
    PopupMenu mnuFont
End If

HandleError:
    'MsgBox Err.Number & " - " & Err.Description, vbOKOnly
End Sub

Private Sub typemsg_Click()
If cmbFonts.Text <> TypeMsg.SelFontName Then
    cmbFonts.Text = ""
    cmbFonts.SelText = TypeMsg.SelFontName
End If

    If TypeMsg.SelBold = True Then
       tbFonts.Buttons(1).Value = tbrPressed
    Else
       tbFonts.Buttons(1).Value = tbrUnpressed
       
    End If
    
    If TypeMsg.SelItalic = True Then
       tbFonts.Buttons(2).Value = tbrPressed
    Else
       tbFonts.Buttons(2).Value = tbrUnpressed
    End If
    
    If TypeMsg.SelUnderline = True Then
       tbFonts.Buttons(3).Value = tbrPressed
    Else
       tbFonts.Buttons(3).Value = tbrUnpressed
    End If
End Sub

Private Sub mnuSetting_Click()
  frmOptions.Show 1
End Sub

Private Sub mnuSendFile_Click()
  Dim mIP As String
  mIP = InputBox("Enter His IP Address:", "IP")
  SendFile mIP    '发送文件到对方IP
  
  'SendFile "127.0.0.1" 'change destination
End Sub

Private Sub wsListen_ConnectionRequest(ByVal requestID As Long)
  ConnectReq requestID
End Sub