向qq聊天窗口的文本框写入字符的方法
由于以前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 Long
Public 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 Function
Function 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 qqsendhwnd
Sub myClickBotton(ByVal fhwnd As Long)
'按下某个按钮
PostMessage fhwnd, BM_CLICK, 0&, 0&
End Sub
差不多就是这样了。有什么问题可以联系我，qq：511795070
[解决办法]
来个简单的
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 = &HF5
Sub 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 Sub
Function 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
[解决办法]
更简单的
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 = &HC2
Private 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
