一个QQ隐蔽聊天的软件，用于你在办公室QQ聊天又不想让其他人知道

　　这个程序是我以前还不是很忙的时候随便搞的一个。主要参考了Enumeration源代码，用于查找句柄。由于QQ里的RichEdit并不是一般的RichEdit，不可以直接发送消息给它，所以废了一些周折。不过后来找到了解决问题的折中方法：利用模拟键盘将要发送的消息进行复制粘贴，然后再发送出去。
　    form1上的控件包含一个commonDialog:cdlbg用于打开文件的通用对话框,一个timer控件:timer1用于检查是否有新消息;两个Text控件text2用于接收和text1发送消息的文本框;两个picturebox：picture1用于载入背景。pictemp用于临时存储剪贴板上的图象。 里面有一点小BUG，由于没有时间也就没有去管它。如果谁有兴趣研究句柄，或发送和接受消息机理，值得看一看。
  　  忘了说用途了，这个软件可以用于你在办公室QQ聊天又不想让其他人知道。载入你平时工作的屏幕，没准老板一直认为你在专心工作呢。
 　  使用这个小软件的前提是要打开和一个人聊天的对话框（没办法，找不到不需要打开聊天框的方法，如果你有，麻烦你告诉我，我一定会感激你的。：），目前只能支持同时和一个人聊天。呵呵，虽然功能不是很全，但还是有一点点的小实用，不信你试试看。

　　'*************************************************************************
'**模 块 名：Module1
'**文 件 名：Module1.bas
'**创 建 人：蒹葭
'**日    期：2005-03-18
'**描    述：QQ辅助聊天工具
'**说    明：运行此程序需打开一个QQ聊天对话框。
'**版    本：V1.0.0
'*************************************************************************

Option Explicit
'APIs : WHERE THE REAL POWER IS
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Any) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function EnumChildWindows Lib "user32" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Any) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const WM_COMMAND = &H111
Public Const MIIM_TYPE = &H10
Public Const MFT_STRING = &H0&

'Public Const WM_SETFOCUS = &H7     Messages for:

Public Const WM_SETTEXT = &HC                   'Setting text of child window
Public Const WM_GETTEXT = &HD                   'Getting text of child window
Public Const WM_GETTEXTLENGTH = &HE
Public Const BM_CLICK = &HF5                    'Clicking a button
Public Const SW_MAXIMIZE = 3
Public Const SW_MINIMIZE = 6
Public Const SW_HIDE = 0
Public Const SW_RESTORE = 9
Public Const WM_MDICASCADE = &H227              'Cascading windows
Public Const MDITILE_HORIZONTAL = &H1
Public Const MDITILE_SKIPDISABLED = &H2
Public Const WM_MDITILE = &H226
Public g_hnum  As Long
Public VCount As Integer, ICount As Integer
Public SpyHwnd As Long
Public g_ReceiveHwnd As Long
Public g_DilogHwnd As Long, g_editHwnd As Long, g_sendButtonHwnd As Long
Dim b_editflag As Boolean
Public Function WndEnumProc(ByVal hWnd As Long, ByVal lParam As TextBox) As Long
    Dim WText As String * 512
    Dim bRet As Long, WLen As Long
    Dim WClass As String * 50

    WLen = GetWindowTextLength(hWnd)
    bRet = GetWindowText(hWnd, WText, WLen + 1)
    GetClassName hWnd, WClass, 50

    If (WLen <> 0 And Left(WClass, 6) = Trim("#32770") And (Left(WText, 2) = "与 " Or Left(WText, 1) = "群")) Then
        g_DilogHwnd = hWnd
        'Debug.Print hwnd, Left(WText, 15); ";", WClass
        Form1.Frame1.Caption = Left(WText, 12)
    End If
   
   
    WndEnumProc = 1
End Function

Public Function WndEnumChildProc(ByVal hWnd As Long, ByVal lParam As TextBox) As Long
    Dim bRet As Long
    Dim myStr As String * 50
    bRet = GetClassName(hWnd, myStr, 50)
    If (Left(myStr, 11) = "RichEdit20A") Then
       ' Debug.Print hwnd; myStr; GetText(hwnd)
       g_ReceiveHwnd = hWnd
       b_editflag = True
    End If
    If b_editflag = True And (Left(myStr, 8) = "RICHEDIT") And (Left(myStr, 11) <> "RichEdit20A") Then
        g_editHwnd = hWnd
       ' Debug.Print g_editHwnd
        b_editflag = False
    End If
    If Left(Trim(GetText(hWnd)), 6) = "发送(&S)" Then
       ' Debug.Print GetText(Hwnd); ":"; Len(GetText(Hwnd))
       g_sendButtonHwnd = hWnd
    End If
    ICount = ICount + 1
   
    WndEnumChildProc = 1

End Function

Function GetText(iHwnd As Long) As String
    Dim Textlen As Long
    Dim Text As String

    Textlen = SendMessage(iHwnd, WM_GETTEXTLENGTH, 0, 0)
    If Textlen = 0 Then
        GetText = "暂无消息，或者你没有打开聊天对话框！：）"
        Exit Function
    End If
    Textlen = Textlen + 1
    Text = Space(Textlen)
    Textlen = SendMessage(iHwnd, WM_GETTEXT, Textlen, ByVal Text)
    'The 'ByVal' keyword is necessary or you'll get an invalid page fault
    'and the app crashes, and takes VB with it.
    GetText = Left(Text, Textlen)

End Function

＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆＆

'*************************************************************************
'**模 块 名：form1
'**文 件 名：form1.frm
'**创 建 人：蒹葭
'**日    期：2005-03-18
'**描    述：QQ辅助聊天工具
'**版    本：V1.0.0
'*************************************************************************

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As _
    String, ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function PutFocus Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long '由于vb自带一个SetFocus函数，所以改个函数名
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Const SW_RESTORE = 9

Private Sub CmdSend_Click()
'*********************************
'将剪贴板里的东西暂时保存到变量中去
  Dim stempClip As String
  Dim btype As Integer  '识别剪贴板里的内容类型 1----文本;2----图形
  If Clipboard.GetFormat(vbCFText) Then
        stempClip = Clipboard.GetText()
        btype = 1
  ElseIf Clipboard.GetFormat(vbCFBitmap) Then
        Pictemp.Picture = Clipboard.GetData(vbCFBitmap)
        btype = 2
  End If
 
'*********************************
'向剪贴板写内容
  Text1.SetFocus
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1.Text)
  Clipboard.Clear
  Clipboard.SetText Text1.SelText
  '*******************************
  '发送消息，采用模拟键盘Ctrl+V
  Call Sendmes(g_editHwnd)
  '*******************************
  '延时，防止发送点击按钮动作失败
  Do
      DoEvents
  Loop Until Clipboard.GetText() <> ""
  '*******************************
  '发送消息给“发送按钮”
  PressSendButton
  '*******************************
  '将原来剪贴板上的内容再送回去
  If btype = 1 Then
      Clipboard.Clear
      Clipboard.SetText stempClip
  ElseIf btype = 2 Then
      Clipboard.Clear
      Clipboard.SetData Pictemp.Picture
  End If
  btype = 0
  Text1.Text = ""
  Text1.SetFocus
  SendKeys "{Home}+{End}"
End Sub

Private Sub Command1_Click()
    Dim myLong As Long
    myLong = EnumWindows(AddressOf WndEnumProc, Text1)
    Dim myLong2 As Long
    myLong2 = EnumChildWindows(g_DilogHwnd, AddressOf WndEnumChildProc, Text2)
End Sub

Private Sub Command2_Click()
    End
End Sub

Private Sub Command4_Click()
On Error Resume Next
 Dim bgFileName As String
cdlbg.CancelError = True
'属性DialogTitle是要弹出的对话框的标题
cdlbg.DialogTitle = "打开文件"
'缺省的文件名为空
cdlbg.FileName = ""
'属性Filter是文件滤器，返回或设置在对话框的类型列表框中所显示的过滤器。
'语法object.Filter [= 文件类型描述1 |filter1 |文件类型描述2 |filter2...]
cdlbg.Filter = "JPG文件(.jpg)|*.jpg|BMP文件|*.bmp|所有文件|*.*"
'Flags属性的用法依据不同的对话框而变，详细使用需要查找联机帮助手册
cdlbg.Flags = cdlOFNCreatePrompt + cdlOFNHideReadOnly
cdlbg.ShowOpen
If Err = cdlCancel Then Exit Sub
Set Picture1.Picture = LoadPicture(cdlbg.FileName)
End Sub

Private Sub Form_Load()
    Dim myLong As Long
    myLong = EnumWindows(AddressOf WndEnumProc, Text1)
    Dim myLong2 As Long
    myLong2 = EnumChildWindows(g_DilogHwnd, AddressOf WndEnumChildProc, Text2)
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        CmdSend_Click
        Text1.Text = ""
    End If
End Sub
'Private Sub Text2_Change()
  ' Text1.SelStart = Len(Text1.Text)
'End Sub

Private Sub Timer1_Timer()
       Form1.Text2.Text = ""
       Form1.Text2.SelText = Right(GetText(g_ReceiveHwnd), 100)
End Sub

Private Sub PressSendButton()
    SendMessage g_sendButtonHwnd, BM_CLICK, 0, 0
    ShowWindow Val(g_DilogHwnd), SW_MINIMIZE
End Sub
Private Sub Sendmes(ByVal hWnd As Long)
    SetForegroundWindow hWnd
    ShowWindow hWnd, SW_RESTORE
    SendKeys "^v" 'SHIFT+a－－>"+a",Ctl+a--> "^a",alt+a-> "%a"
  '  SendKeys "{ENTER}"
  '  SendKeys "^{ENTER}"
End Sub