由于以前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
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
解决方案 »
- Webbrowser获取的源码 不是完整的!
- 如何让VB动态加载控件 以及如何实现WORD文挡?
- 求从一个库追加记录到另一个库的方法
- 用adodc、rdc连接远程ACCESS数据库问题
- 怎样在msflexgrid最后一行加入合计
- 怎样做自动保存的程序?(在线等待)
- 有没有选择年月日小时分钟的时间控件?
- 急诊!用select查询时,必须在窗体中有DATA控件并邦定到数据源吗?
- 如何使用VB编译成像阿api函数那样的动态连接库,急!!!!!!!!!
- 如何在VB中使用汉字点阵来显示汉字!
- 如何用vb将图片插入/提取access数据库中ole字段?
- 版主们请进!讨论一下关于CSDN用户可用分与专家分取得途径问题
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
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