这个程序是我以前还不是很忙的时候随便搞的一个。主要参考了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 ISPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPublic Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As LongPublic Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As LongPublic Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Any) As LongPublic Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As LongPublic Declare Function EnumChildWindows Lib "user32" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Any) As LongPublic Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As LongPublic Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As LongPublic Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Const WM_COMMAND = &H111Public Const MIIM_TYPE = &H10Public Const MFT_STRING = &H0&'Public Const WM_SETFOCUS = &H7 Messages for:Public Const WM_SETTEXT = &HC 'Setting text of child windowPublic Const WM_GETTEXT = &HD 'Getting text of child windowPublic Const WM_GETTEXTLENGTH = &HEPublic Const BM_CLICK = &HF5 'Clicking a buttonPublic Const SW_MAXIMIZE = 3Public Const SW_MINIMIZE = 6Public Const SW_HIDE = 0Public Const SW_RESTORE = 9Public Const WM_MDICASCADE = &H227 'Cascading windowsPublic Const MDITILE_HORIZONTAL = &H1Public Const MDITILE_SKIPDISABLED = &H2Public Const WM_MDITILE = &H226Public g_hnum As LongPublic VCount As Integer, ICount As IntegerPublic SpyHwnd As LongPublic g_ReceiveHwnd As LongPublic g_DilogHwnd As Long, g_editHwnd As Long, g_sendButtonHwnd As LongDim b_editflag As BooleanPublic 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 = 1End FunctionPublic 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 = 1End FunctionFunction 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 ExplicitPrivate 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 LongPrivate 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 LongPrivate Const SW_RESTORE = 9Private 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 SubPrivate Sub Command1_Click() Dim myLong As Long myLong = EnumWindows(AddressOf WndEnumProc, Text1) Dim myLong2 As Long myLong2 = EnumChildWindows(g_DilogHwnd, AddressOf WndEnumChildProc, Text2)End SubPrivate Sub Command2_Click() EndEnd SubPrivate Sub Command4_Click()On Error Resume Next Dim bgFileName As Stringcdlbg.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 + cdlOFNHideReadOnlycdlbg.ShowOpenIf Err = cdlCancel Then Exit SubSet Picture1.Picture = LoadPicture(cdlbg.FileName)End SubPrivate Sub Form_Load() Dim myLong As Long myLong = EnumWindows(AddressOf WndEnumProc, Text1) Dim myLong2 As Long myLong2 = EnumChildWindows(g_DilogHwnd, AddressOf WndEnumChildProc, Text2)End SubPrivate Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then CmdSend_Click Text1.Text = "" End IfEnd Sub'Private Sub Text2_Change() ' Text1.SelStart = Len(Text1.Text)'End SubPrivate Sub Timer1_Timer() Form1.Text2.Text = "" Form1.Text2.SelText = Right(GetText(g_ReceiveHwnd), 100)End SubPrivate Sub PressSendButton() SendMessage g_sendButtonHwnd, BM_CLICK, 0, 0 ShowWindow Val(g_DilogHwnd), SW_MINIMIZEEnd SubPrivate 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
