编辑框

开发平台：
Visual Basic

Form1.frm：源码内容
							VERSION 5.00
Object = "{62057841-98CC-4E93-90FB-E56975B2CE87}#1.0#0"; "PEOcx.ocx"
Object = "{33576EEB-95E5-47F4-B538-685746D71157}#1.0#0"; "WebR.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{CC888B26-5CB7-4691-9FCA-6AB8BC181E7A}#1.0#0"; "ScreenCap.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6945
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7905
   LinkTopic       =   "Form1"
   ScaleHeight     =   463
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   527
   StartUpPosition =   3  '窗口缺省
   Begin SCREENCAPLib.ScreenCap ScreenCap1 
      Height          =   255
      Left            =   6480
      TabIndex        =   6
      Top             =   4920
      Width           =   255
      _Version        =   65536
      _ExtentX        =   450
      _ExtentY        =   450
      _StockProps     =   0
   End
   Begin VB.CommandButton Command4 
      Caption         =   "截屏"
      Height          =   495
      Left            =   1560
      TabIndex        =   5
      Top             =   4440
      Width           =   735
   End
   Begin MSComDlg.CommonDialog cmdlgDemo 
      Left            =   5760
      Top             =   5040
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command3 
      Caption         =   "字体"
      Height          =   495
      Left            =   840
      TabIndex        =   3
      Top             =   4440
      Width           =   735
   End
   Begin VB.CommandButton Command2 
      Caption         =   "表情"
      Height          =   495
      Left            =   120
      TabIndex        =   2
      Top             =   4440
      Width           =   735
   End
   Begin VB.CommandButton BtnSend 
      Caption         =   "发送"
      Height          =   495
      Left            =   5760
      TabIndex        =   1
      Top             =   6000
      Width           =   1215
   End
   Begin PEOCXLib.PEOcx P2PEdit 
      Height          =   1935
      Left            =   120
      TabIndex        =   0
      Top             =   4920
      Width           =   5295
      _Version        =   65536
      _ExtentX        =   9340
      _ExtentY        =   3413
      _StockProps     =   0
   End
   Begin WEBRLib.WebR WebR1 
      Height          =   4065
      Left            =   120
      TabIndex        =   4
      Top             =   240
      Width           =   5295
      _Version        =   65536
      _ExtentX        =   9340
      _ExtentY        =   7170
      _StockProps     =   0
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''
'PRTX 通讯开发组件   www.webp2p.com
'
'深圳市纵横网络服务有限公司  2006 年 8 月
'本文件演示文字输入，表情输入和显示，以及截屏功能
'使用前，请注册peocx.ocx  webr.ocx  screencap.ocx
'如果没有请联系 www.webp2p.com
'本三个控件可以在您的软件中免费使用，
'
'    *******    *******    **********  **       **
'    ********   ********   **********   **     **
'    **    **   **    **       **        **   **
'    **   **    **   **        **         ** **
'    *****      *** **         **          ***
'    ***        ****           **          ***
'    **         ** **          **         ** **
'    **         **  **         **        **   **
'    **         **   **        **       **     **
'    **         **    **       **      **       **
'本公司开发和销售成套 PRTX 网络通讯开发包，'PRTX 适合任何互联网通讯
'包括文字，P2P内存传输组件，P2P语音，P2P视频，P2P文件传输，P2P远程协助，P2P电子白板开发套件，使用P2P传输，高性能服务器，分布式解决方案
'免安装 WebIM 开发插件，通过 javascript 即可开发网页即时通讯
'如果您为您的软件的通讯功能发愁，请访问 www.webp2p.com 或许您会有收获。
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type MY_FONT
    Size As Integer
    name As String
    bold As Boolean
    italic As Boolean
    underline As Boolean
    strike As Boolean
    nColor As Long
End Type
Private m_Font As MY_FONT
Private Sub Command1_Click()
End Sub
Private Sub SendMsg(sMsg As String)
    RecvMsg (sMsg)
End Sub
Private Sub RecvMsg(sMsg As String)
     AddHtmlText P2PEdit.Txt2Html(sMsg, App.Path & "smiley", 1) & "<br><br>", "PRTX - www.webp2p.com"
    
End Sub
Private Sub BtnSend_Click()
        Dim sContentTmp() As String
        
         '检查不能只有空字符或者换行符号
          Dim stttt As String
           Dim Str As String
           
           Str = P2PEdit.GetSendText
           sContentTmp = Split(Str, "C")
           If UBound(sContentTmp) > 0 Then
               stttt = sContentTmp(1)
           Else
               Exit Sub
           End If
           stttt = Replace(stttt, Chr(13), "")
          stttt = Replace(stttt, Chr(10), "")
        
         '如果是空内容，就直接退出
           If Len(Trim(stttt)) = 0 Then
               P2PEdit.ClearRTF
               Exit Sub
           End If
If Len(P2PEdit.GetPlanText) > 0 Then
    SendMsg P2PEdit.GetSendText
    P2PEdit.ClearRTF
End If
    P2PEdit.FocusEdit
End Sub
Private Sub Command2_Click()
       Dim pos As POINTAPI
        GetCursorPos pos
        
        With frmIcoPictures
        Dim nBottom As Integer
        nBottom = .ScaleHeight - .Picture1.Height
         ' .Move frmTalkTo.Left + BtnSmiley.Left + PictParent.Left + BtnSmiley.Width + 2 * Screen.TwipsPerPixelX, _
                '  frmTalkTo.Top + PicBox(5).Top + PicBox(4).Height + BtnSmiley.Height,
          .Move pos.x * Screen.TwipsPerPixelX, pos.y * Screen.TwipsPerPixelY - .Height, _
                SMILEY_COLS * .btnFace(0).Width * Screen.TwipsPerPixelX + Screen.TwipsPerPixelX * SMILEY_EDGE * 5
                ', _
                'SMILEY_ROWS * .btnFace(0).Width * Screen.TwipsPerPixelY + Screen.TwipsPerPixelY * 10 + .btnNext.Height
                
             '.Picture1.Move 0, 0, .Width - Screen.TwipsPerPixelX * SMILEY_EDGE * 2, _
                    .Height - .btnNext.Height - Screen.TwipsPerPixelY * 3
            ' .btnNext.Move .ScaleWidth - .btnNext.Width - 3, .ScaleHeight - 3 - .btnNext.Height
            .Show
            Set .m_frm = Me
         '   .Command1.Move 0, .Picture1.Height / Screen.TwipsPerPixelY - 10
            '.Line1.x 0, .Picture1.Height / Screen.TwipsPerPixelY - 10
          '    frmIcoPictures.Line (0, .Picture1.Height / Screen.TwipsPerPixelY - Screen.TwipsPerPixelY) _
           '      -(.Picture1.ScaleWidth, .Picture1.Height / Screen.TwipsPerPixelY - 10)
        End With
End Sub
Private Sub Command3_Click()
   cmdlgDemo.Flags = cdlCFBoth + cdlCFEffects '+ cdlOFNHideReadOnly
      
       With cmdlgDemo
            .FontName = m_Font.name
           .FontSize = m_Font.Size
           .FontBold = m_Font.bold
           .FontItalic = m_Font.italic
           .FontUnderline = m_Font.underline
           .FontStrikethru = m_Font.strike
           .Color = m_Font.nColor
           .ShowFont
          
           P2PEdit.SetRTFFont .FontBold, .FontItalic, .FontUnderline, .Color, _
            .FontName, .FontSize, .FontStrikethru
             m_Font.bold = .FontBold
            m_Font.italic = .FontItalic
            m_Font.name = .FontName
            m_Font.nColor = .Color
            m_Font.Size = .FontSize
            m_Font.strike = .FontStrikethru
            m_Font.underline = .FontUnderline
       End With
End Sub
'这里插入图片 index是图号，nPage是目录nType=1 表示是表情，2表示是其它硬盘上的图片
Public Static Sub InsertPics(Index As Integer, nPage As Integer, nType As Integer)
On Error GoTo ErrHand
  Dim ind As Integer
  
  ind = nPage * 100 + Index
  Dim strP As String
  strP = App.Path & "smiley" & nPage & "" & Index & ".gif"
  P2PEdit.InsertPic strP, ind, "", nType
  Debug.Print "插入图" & strP & "index: "; ind & "nType: " & nType
Exit Sub
ErrHand:
   Debug.Print "InsertPics:::: Error: " & Err.Description
End Sub
'加载笑脸 nPage是目录号
Public Sub loadSmiley(nPage As Integer)
On Error GoTo ErrHand
     frmIcoPictures.Hide
     
     Dim W As Integer
     W = frmIcoPictures.btnFace(0).Width
        Dim ii As Integer, i As Integer
        For i = 0 To SMILEY_ROWS - 1
            For ii = 0 To SMILEY_COLS - 1
              If i * 12 + ii > 0 Then Load frmIcoPictures.btnFace(ii + i * SMILEY_COLS)
                    frmIcoPictures.btnFace(ii + i * SMILEY_COLS).bFlat = True
                      frmIcoPictures.btnFace(ii + i * SMILEY_COLS).Move SMILEY_EDGE + W * ii, SMILEY_EDGE + W * i
                      'Debug.Print ii + I * SMILEY_COLS '& " To " & EDGE + w * ii & " , " & EDGE + w * i
 
                      Set frmIcoPictures.btnFace(ii + i * SMILEY_COLS).Image = LoadPicture(App.Path & "smiley" & nPage & "" & Trim(Str(i * SMILEY_COLS + ii)) + ".gif")
                      frmIcoPictures.btnFace(ii + i * SMILEY_COLS).Visible = True
            Next ii
         Next i
  
Exit Sub
ErrHand:
    Debug.Print "loadSmiley:::: Error: " & Err.Description
End Sub
'发送截屏的图片
Public Sub SendCaptureScreen()
 
 
 '如果是群聊
  Dim d     As Date
  Dim lsec     As Long
  d = Now
  lsec = DateDiff("s", #1/1/1970#, d)     '获得当前时间秒数
  
  Dim strPath As String
     strPath = App.Path & "" & lsec & ".bmp"
    '如果截取了屏幕
     If ScreenCap1.StartCap(strPath) Then
        Dim Str As String
        Str = Mid(strPath, 1, Len(strPath) - 4)
        Str = Str & ".gif"
        '显示到输入窗中
        P2PEdit.ConvertBmpTo strPath, Str   '目前只能将bmp转成gif，没有转成jpg
        P2PEdit.InsertPic Str, 0, "", 2     '因为不是表情，所以nNum是2
    End If
End Sub
Private Sub Command4_Click()
    SendCaptureScreen
End Sub
Private Sub Form_Load()
m_Font.Size = 12
m_Font.name = "宋体"
P2PEdit.SetRTFFont False, False, False, 0, m_Font.name, m_Font.Size, False
'加载第一个目录中的表情
 loadSmiley 1
 
 P2PEdit.bCtrlEnter = True  'ctrl+enter触发
 
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unload frmIcoPictures
End Sub
Private Sub P2PEdit_EditKeyDown(ByVal nChar As Long)
 Debug.Print "P2PEdit_EditKeyDown " & nChar
    If nChar = 999999 Then  '如果是999999表示按了
       BtnSend_Click
    End If
    
End Sub
Private Sub P2PEdit_SendFile(ByVal sPath As String, ByVal sStr As String, ByVal nNum As Long)
     Debug.Print sPath & "  str " & sStr & "  num " & nNum
     Dim Str As String
     Str = Mid(sPath, 1, Len(sPath) - 4)
  
     SendPicP2P Str
     
End Sub
Public Sub AddHtmlText(sMsg As String, sNick As String)
    Dim ssH As String
    Dim stime As String
     stime = CStr(Now)
    
    ssH = sMsg & "<BR><font size=1><br></font>"
     
    Dim ss As String
    ss = "<font  size=2 color=red>" & sNick & "</font>" & " " & "<font  size=2>" & stime & "<br>" & "</font>" & ssH
      WebR1.AddHTML ss
 End Sub
Public Sub AddHtmlPic(sPath As String, sNick As String)
 Dim stime As String
     stime = CStr(Now)
   
    WebR1.AddHTML "<font  size=2 color=red>" & sNick & "</font>" & " " & "<font  size=2>" & stime & "<br>" & "</font>"
    WebR1.AddHTML "<p><img border='0' src='" & sPath & "'></p>"
 
End Sub
Private Sub SendPicP2P(sPath As String)
    AddHtmlPic sPath, "www.webp2p.com"
End Sub

						