上一篇
下一篇
QQ群发器
作者:JiaJia 日期:2008-02-28
引用内容这个东西难度不大,调用了QQ自带的timwp.exe程序,实现起来就很容易了,下面是代码部分
建立一个模块
Option Explicit
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Const WM_CLOSE = &H10
'注册表操作
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'-------------------------------------------------
Declare Function SendMessageA Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) 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 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
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 GetWindow Lib "user32" (ByVal Hwnd As Long, ByVal wCmd As Long) 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 SendMessage Lib "user32" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const GW_HWNDFIRST = 0 '第一个
Public Const GW_HWNDNEXT = 2 '下一个
Public Const DVASPECT_CONTENT = 1
Public Const WM_USER = &H400
Public Const EM_PASTESPECIAL = WM_USER + 64
Public Const CF_TEXT = 1
Const EM_REPLACESEL = &HC2
Const BM_CLICK = &HF5
Public Type QQWindowHwnd
WindowHwnd As Long
TxtHwnd As Long
SendButtonHwnd As Long
CloseButtonHwnd As Long
End Type
Public Type repastespecial
dwAspect As Long
dwParam As Long
End Type
Private QQpath As String
Public QQExePath As String
Public Sub main()
QQpath = getQqPath
If QQpath = "" Then
QQpath = InputBox("请填写QQ的安装路径", "QQ路径", "N")
End If
If QQpath = "N" Then End
QQExePath = QQpath & "timwp.exe " + "Tencent://Message/?Menu=YES&Exe=&Uin="
FrmMain.Show
End Sub
Private Function getQqPath() As String '获取QQ注册表路径
Dim ret, lenData, hKey As Long
Dim sValue As String
Dim name As String
sValue = Space(255)
Const REG_SZ = 1&
lenData = 255
name = "Install"
ret = 1
ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Tencent\QQ", hKey)
If ret = 0 Then '正确返回0，不正确返回错误编号
ret = RegQueryValueEx(hKey, name, 0, REG_SZ, ByVal sValue, lenData)
ret = InStr(1, sValue, "QQ\")
getQqPath = Left(sValue, ret + 2)
End If
ret = RegCloseKey(hKey)
End Function
Public Function FindQQ(ByVal Hwnd As Long) As Long
Dim strName As String * 255
Dim className As String * 255
Dim Q_hwnd As Long
Q_hwnd = GetWindow(Hwnd, GW_HWNDFIRST)
Do While Q_hwnd <> 0
GetWindowText Q_hwnd, strName, 255
GetClassName Q_hwnd, className, 255
If ((InStr(strName, "聊天中") > 0) or (InStr(strName, "会话中") > 0)) And (InStr(className, "#32770") > 0) Then
FindQQ = Q_hwnd
Exit Function
End If
Q_hwnd = GetWindow(Q_hwnd, GW_HWNDNEXT)
Loop
End Function
Public Function getQQHwnd(ByVal Hwnd As Long) As QQWindowHwnd
Dim tmphwnd As Long
getQQHwnd.WindowHwnd = FindWindowEx(Hwnd, 0, "#32770", vbNullString)
tmphwnd = FindWindowEx(getQQHwnd.WindowHwnd, 0, "Afxwnd42", vbNullString)
tmphwnd = FindWindowEx(getQQHwnd.WindowHwnd, tmphwnd, "afxwnd42", "")
getQQHwnd.TxtHwnd = FindWindowEx(tmphwnd, 0, "richedit20A", vbNullString)
getQQHwnd.SendButtonHwnd = FindWindowEx(getQQHwnd.WindowHwnd, 0, "button", "发送(&S)")
getQQHwnd.CloseButtonHwnd = FindWindowEx(getQQHwnd.WindowHwnd, 0, "button", "关闭(&C)")
End Function
Public Sub SendQQMessage(ByRef QQhwnd As QQWindowHwnd, ByVal sTText As String)
SendMessageA QQhwnd.TxtHwnd, EM_REPLACESEL, 0, ByVal sTText
SendMessageA QQhwnd.SendButtonHwnd, BM_CLICK, 0, ByVal 0
SendMessageA QQhwnd.CloseButtonHwnd, BM_CLICK, 0, ByVal 0
End Sub
'再建立一个窗体
'窗体上放2个文本框,text1和text2,再放一个按钮,text1用于填写QQ号码,text2用于填写想要发送的内容
Option Explicit
Private delayNum As Long
Private Sub Command1_Click()
Shell QQExePath & Text1.Text
Call delay(10)
Dim QQhwnd As Long
QQhwnd = FindQQ(Me.Hwnd)
Dim x As QQWindowHwnd
x = ModConst.getQQHwnd(QQhwnd)
SendQQMessage x, Text2.Text
End Sub
Private Sub delay(ByVal sTime As Long)
delayNum = sTime
Timer1.Enabled = True
Do
DoEvents
Loop While Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Static I As Integer
I = I + 1
If I > delayNum Then
I = 0
Timer1.Enabled = False
End If
End Sub
'好了,运行试试
文章来自: 
引用通告: 
Tags: 评论: 0 | 引用: 0 | 查看次数: -
发表评论