vb QQ消息辅助连发软件代码(vb)

vb QQ消息辅助连发软件代码(vb)
2009年12月27日
　　用到了一些API，但都是简单的
　　原理是找到qq聊天句柄，然后不停想起发送信息
　　QQ2009hook了findwindow
　　所以者只有2008 才能用了
　　代码如下：
　　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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
　　Private Const WM_GETTEXT = &HD
　　Private Const EM_REPLACESEL = &HC2
　　Private Const BM_CLICK = &HF5
　　Private 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 Long
　　Private Function GetWinText(ByVal WinHwnd As Long) As String
　　Dim lLen As Long
　　GetWinText = String(255, Chr(0))
　　lLen = SendMessage(WinHwnd, WM_GETTEXT, Len(GetWinText), ByVal GetWinText)
　　GetWinText = Left(GetWinText, lLen)
　　End Function
　　Private Sub Command1_Click()
　　ShellExecute 0, "open", "tencent://message/?uin=" + Text1.Text, "", "", 1
　　End Sub
　　Private Sub Command2_Click()
　　List1.Clear
　　Me.Caption = "正在获取发送列表，请稍候..."
　　HFindWnd = FindWindowEx(0, 0, "#32770", vbNullString)
　　Do While HFindWnd  0
　　If InStr(GetWinText(HFindWnd), "聊天中") > 0 Or InStr(GetWinText(HFindWnd), " － ") > 0 Or InStr(GetWinText(HFindWnd), "群") > 0 Or InStr(GetWinText(HFindWnd), "交谈中") > 0 Or InStr(GetWinText(HFindWnd), "正在输入") > 0 Or InStr(GetWinText(HFindWnd), " － ") > 0 Then
　　List1.AddItem GetWinText(HFindWnd)
　　End If
　　HFindWnd = FindWindowEx(0, HFindWnd, "#32770", vbNullString)
　　DoEvents
　　Loop
　　If List1.ListCount = 0 Then
　　Me.Caption = "无法获取QQ消息窗口列表"
　　Exit Sub
　　End If
　　Me.Caption = "获取发送列表完成"
　　Sleep 1000
　　Me.Caption = "QQ消息发送器（支持QQ2008)"
　　End Sub
　　Private Sub Command3_Click()
　　If Timer1.Interval = 0 Then
　　If Text3.Text <= 100 Then
　　m = MsgBox("发送时间请大于100毫秒！", 64, "提示")
　　Text1.Text = 2000
　　Else
　　a = MsgBox("窗体会被最小化，你可以干别的！", 64, "提示")
　　Me.WindowState = 1
　　Timer1.Interval = Text3.Text
　　Command3.Caption = "暂停"
　　End If
　　Else
　　Me.Caption = "QQ消息发送器（支持QQ2008)"
　　Timer1.Interval = 0
　　Command3.Caption = "开始"
　　End If
　　End Sub
　　Private Sub Command4_Click()
　　Unload Me
　　End Sub
　　Private Sub Timer1_Timer()
　　QQHwnd = FindWindow("#32770", List1.Text)
　　QQHwnd = FindWindow("#32770", List1.Text)
　　Do
　　If QQHwnd = 0 Then
　　QQHwnd = FindWindow("#32770", List1.Text)
　　End If
　　AHwnd = FindWindowEx(QQHwnd, AHwnd, "AfxWnd42", vbNullString)
　　If AHwnd = 0 Then
　　QQHwnd = FindWindowEx(QQHwnd, 0, "#32770", vbNullString)
　　End If
　　THwnd = FindWindowEx(AHwnd, 0, "RichEdit20A", vbNullString)
　　DoEvents
　　Loop While THwnd = 0
　　Me.Caption = "正在发送中......"
　　SendMessage THwnd, EM_REPLACESEL, 0, ByVal Text1.Text
　　RHwnd = FindWindowEx(QQHwnd, 0, "Button", "发送(S)")
　　SendMessage RHwnd, BM_CLICK, 0, 0
　　End Sub