由于以前qq消息尾巴病毒的流行,腾讯使用了一些技术,使得现在的qq聊天窗口屏蔽了wm_settext消息这样的话,要利用程序自动向qq聊天窗口发送文本就比较难了。不过经过测试发现,wm_char消息没有被qq屏蔽。因此,可以使用这个消息把字符发送到聊天窗口。不过要注意的是,发送中文的话,要发送2次,也就是高低2个字节,不然会乱码的。Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As LongPublic Const WM_CHAR = &H102
Public Const WM_SETTEXT = &HC
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const BM_CLICK = &HF5
Public Const WM_GETTEXT = &HD
Sub setQQText(ByVal fhwnd As Long, ByVal mystr As String)' 向聊天窗口的文本框写入消息。fhwnd 是那个文本框的句柄,mystr 是你要写入的消息
Dim mydata() As Byte, i As Long, tmp_k As Long
i = 0
mydata = StrConv(mystr, vbFromUnicode)
tmp_k = UBound(mydata)
While i <= tmp_k
      If mydata(i) < 128 Then
          PostMessage fhwnd, WM_CHAR, mydata(i), 0&
          i = i + 1
      Else
          PostMessage fhwnd, WM_CHAR, mydata(i), 0&
          PostMessage fhwnd, WM_CHAR, mydata(i + 1), 0&
          i = i + 2
      End If
Wend
End Sub
顺便再附上几段代码,是关于如何找到qq那个文本框的句柄的。Function MyFindWindowEx(wname As String, fhwnd As Long, temphnd As Long) As Long
Dim mystr As String * 255
Do
temphnd = FindWindowEx(fhwnd, temphnd, vbNullString, vbNullString)
GetWindowText temphnd, mystr, Len(mystr) - 1
If InStr(1, mystr, wname) > 0 Then
MyFindWindowEx = temphnd
Exit Function
Else
MyFindWindowEx = 0
End If
Loop Until temphnd = 0
End Function先用上面的函数找到qq消息窗口的句柄,像这样 qqhwnd=MyFindWindowEx("聊天中",0,0)再用下面的函数找到qq文本输入框的句柄,像这样,传入qq消息窗口的句柄  qqtexthwnd=myFindQQchatText(qqhwnd)Function myFindQQchatText(ByVal fhwnd As Long) As Long
'获得qq聊天窗口的文本输入框句柄
Dim tmp_hwnd As Long
tmp_hwnd = MyCheckWindow(fhwnd, 4)
tmp_hwnd = MyCheckWindow(tmp_hwnd, 23)
tmp_hwnd = MyCheckWindow(tmp_hwnd, 1)
myFindQQchatText = tmp_hwnd
End FunctionFunction MyCheckWindow(fhwnd As Long, myno As Long) As Long
Dim MyCheck As Long
MyCheckWindow = 0
For MyCheck = 1 To myno
MyCheckWindow = FindWindowEx(fhwnd, MyCheckWindow, vbNullString, vbNullString)
Next
End Function然后就可以写入消息了。写入消息后,还可以自动按下发送按钮来发送消息找到发送按钮的句柄  qqsendhwnd=myFindQQchatSend(qqhwnd)Function myFindQQchatSend(ByVal fhwnd As Long) As Long
'获得qq聊天窗口的发送按钮句柄
Dim tmp_hwnd As Long
tmp_hwnd = MyCheckWindow(fhwnd, 4)
tmp_hwnd = MyCheckWindow(tmp_hwnd, 17)
myFindQQchatSend = tmp_hwnd
End Function再模拟按下发送键  myClickBotton qqsendhwndSub myClickBotton(ByVal fhwnd As Long)
'按下某个按钮
PostMessage fhwnd, BM_CLICK, 0&, 0&
End Sub差不多就是这样了。有什么问题可以联系我,qq:511795070

解决方案 »

  1.   

    http://community.csdn.net/Expert/topic/5545/5545084.xml?temp=.9980127
      

  2.   

    来个简单的
    Declare Function FindWindowExA Lib "user32" (ByVal Hwnd1 As Long, ByVal Hwnd2 As Long, _
                     ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Declare Function SendMessageA Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, _
                     ByVal wParam As Long, lParam As Any) As Long
    Declare Function GetWindowTextA Lib "user32" (ByVal Hwnd As Long, ByVal lpString As String, _
                     ByVal cch As Long) As Long
    Const EM_REPLACESEL = &HC2
    Const BM_CLICK = &HF5Sub Test()
      Dim Hwnd  As Long
      Dim Title As String
      Hwnd = FindWindowExA(0, 0, "#32770", vbNullString)
      Do While Hwnd > 0
         Hwnd = FindWindowExA(0&, Hwnd, "#32770", vbNullString)
         Title = Space(255)
         GetWindowTextA Hwnd, Title, 256
         If (Title Like "*聊天中*") Or (Title Like "*群*") Or (Title Like "*會話中*") Then
            SendMsg Hwnd, "QQ消息群發"
         End If
       Loop
    End SubFunction SendMsg(Hwnd As Long, Meg As String)
      Dim Hwnd1 As Long
      Dim Hwnd2 As Long
      Hwnd1 = FindWindowExA(Hwnd, 0, "#32770", vbNullString)
      Hwnd2 = FindWindowExA(Hwnd1, 0, "Button", "發送(S)")
      Hwnd1 = FindWindowExA(Hwnd1, Hwnd2, "AfxWnd42", vbNullString)
      Hwnd1 = FindWindowExA(Hwnd1, 0, "RichEdit", vbNullString)  SendMessageA Hwnd1, EM_REPLACESEL, 0, ByVal Meg
      SendMessageA Hwnd2, BM_CLICK, 0, ByVal 0
    End Function
      

  3.   

    更简单的
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Const EM_REPLACESEL = &HC2Private Sub Command1_Click()
    Dim h As Long, h1 As Long, h2 As Long
    h = FindWindow("#32770", "与 *** 聊天中") ''***换成和你聊天人的网名
    h = FindWindowEx(h, 0, "#32770", "")
    h1 = FindWindowEx(h, 0, "AfxWnd42", "")
    h2 = FindWindowEx(h1, 0, "RichEdit20A", "")
    Dim i As Integer
    Do While h2 = 0 And i < 100
        h1 = FindWindowEx(h, h1, "AfxWnd42", "")
        h2 = FindWindowEx(h1, 0, "RichEdit20A", "")
        i = i + 1
    Loop
    SendMessage h2, EM_REPLACESEL, 0, ByVal "哈哈,这个好用,QQ忘记屏备这个了" 
    End sub