首先本人没有任何vbs和vba基础,只学过c++和java,所以代码大部分来自网络
感谢Demon和天灵狐的攻略:
Demon博文地址
天灵狐博文地址
记得vbs整人代码很多来着,没想到百度了很久,根本找不到打QQ电话的教程,于是自己琢磨
实现过程中遇到了很多问题,百度辗转于多个作者的博文中,终于实现(为了轰炸沙雕朋友真不容易)
安装了Windows系统、QQ和office的电脑一台
为什么需要office?因为调用了excel宏
由于客户端QQ没有提供这方面的API,所以只能用模拟鼠标键盘输入的方式实现
首先模拟输入本身就不靠谱,本人只是为了娱乐,如果要确保稳定性还是请移步WebQQ吧
这个需要把QQ聊天窗口开着,可以最小化,但是不能关掉
代码如下
Dim wsh
set wsh=createobject("wscript.shell")
Clipboard="MsHta vbscript:ClipBoardData.setData(""Text"","""&"你要发送的内容"&""")(Window.Close)"
wsh.Run(Clipboard) '设置剪贴板内容
wscript.sleep 1000 '等待剪贴板设置完成,如果没有设置好可以增加sleep的时间
wsh.AppActivate("QQ聊天窗口名") '激活聊天窗口(使聊天窗口获得键盘焦点)
wsh.sendKeys "{ENTER}" '当聊天窗口最小化时,需要加这句才能激活
wsh.sendKeys "^v" '模拟键盘输入ctrl+v(粘贴)
wsh.sendKeys "%s" '模拟键盘输入enter,也就是把对话框内的信息发送出去
如果需要连续发送消息(轰炸),则加一个for next语句就可以
代码如下
for i = 1 to 5 '循环5次,可以自己更改次数
wsh.AppActivate("QQ聊天窗口名") '激活聊天窗口(使聊天窗口获得键盘焦点)
wsh.sendKeys "{ENTER}" '当聊天窗口最小化时,需要加这句才能激活
wsh.sendKeys "^v" '模拟键盘输入ctrl+v(粘贴)
wsh.sendKeys "%s" '模拟键盘输入enter,也就是把对话框内的信息发送出去
next
如果需要间隔一段时间发送消息(定时QQ闹钟),则在循环中加入wscript.sleep语句
wscript.sleep 3600000 '间隔一小时发一次
还可以加以下语句实现发送完消息后自动最小化窗口
wsh.sendKeys "% "
wscript.sleep 200 '如果没有最小化可以增加sleep的时间
wsh.sendKeys "n"
记住一定不能关闭聊天窗口,否则无法发送
还有vbs文件一定要是ANSI编码,否则无法激活QQ窗口
由于QQ电话没有快捷键,所以模拟键盘输入是不能打电话了,只能模拟鼠标点击了
代码如下
Dim WshShell
Dim oExcel, oBook, oModule
Dim strRegKey, strCode
Set oExcel = CreateObject("Excel.Application") '创建 Excel 对象
set WshShell = CreateObject("wscript.Shell")
strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\$\Excel\Security\AccessVBOM"
strRegKey = Replace(strRegKey, "$", oExcel.Version)
WshShell.RegWrite strRegKey, 1, "REG_DWORD"
Set oBook = oExcel.Workbooks.Add '添加工作簿
Set oModule = obook.VBProject.VBComponents.Add(1) '添加模块
strCode = _
"Private Type POINTAPI : X As Long : Y As Long : End Type" & vbCrLf & _
"Private Declare PtrSafe Function SetCursorPos Lib ""user32"" (ByVal x As Long, ByVal y As Long) As Long" & vbCrLf & _
"Private Declare PtrSafe Function GetCursorPos Lib ""user32"" (lpPoint As POINTAPI) As Long" & vbCrLf & _
"Private Declare PtrSafe Sub mouse_event Lib ""user32"" Alias ""mouse_event"" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)" & vbCrLf & _
"Public Function GetXCursorPos() As Long" & vbCrLf & _
"Dim pt As POINTAPI : GetCursorPos pt : GetXCursorPos = pt.X" & vbCrLf & _
"End Function" & vbCrLf & _
"Public Function GetYCursorPos() As Long" & vbCrLf & _
"Dim pt As POINTAPI: GetCursorPos pt : GetYCursorPos = pt.Y" & vbCrLf & _
"End Function" & vbCrLf & _
"Private Sub SetCursor(x,y)" & vbCrLf & _
"SetCursorPos x, y" & vbCrLf & _
"End Sub" & vbCrLf & _
"sub click(s,a,b,c,d)" & vbCrLf & _
"mouse_event s, a, b, c, d " & vbCrLf & _
"end sub"
oModule.CodeModule.AddFromString strCode '在模块中添加 VBA 代码
'Author: Demon
'Website: http://demon.tw
'Date: 2011/5/10
Const MOUSEEVENTF_MOVE = &H1
Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4
Const MOUSEEVENTF_RIGHTDOWN = &H8
Const MOUSEEVENTF_RIGHTUP = &H10
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Const MOUSEEVENTF_MIDDLEUP = &H40
Const MOUSEEVENTF_ABSOLUTE = &H8000
WshShell.AppActivate("QQ聊天窗口名")
WshShell.sendKeys "{ENTER}"
oExcel.Run "SetCursor", 1199, 359 '设置QQ电话的坐标
ol.Run "click", MOUSEEVENTF_LEFTDOWN + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 '模拟鼠标左键单击
oExcel.DisplayAlerts = False '关闭 Excel
oBook.Close
oExcel.Quit
以上代码参考自Demon的博文和天灵狐的博文
其实就是控制鼠标去点击QQ电话的图标,相当于一个鼠标控制器,只要自己设置好QQ电话的坐标就行
肯定会有人问QQ电话的坐标是多少,这里教一个很简单的方法:
由于调用了Excel宏,所以需要在Excel中启用宏
这样代码就可以运行了
如果想要连续打电话(夺命连环call),结合前面自动发消息的代码改一改就可以了
代码如下
for i = 1 to 5 '循环5次,可以自己设置次数
WshShell.AppActivate("QQ聊天窗口名")
WshShell.sendKeys "{ENTER}"
oExcel.Run "SetCursor", 1199, 359 '设置QQ电话的坐标
ol.Run "click", MOUSEEVENTF_LEFTDOWN + MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 '模拟鼠标左键单击
Wscript.sleep 5000 '5秒打一次(考虑到对方挂电话也要一定时间),可以自己设置时间
next
和上面一样,聊天窗口不能关闭,并且vbs文件要保存为ANSI编码
女孩纸再也不怕男朋友不接电话了
对于没有学过vbs的我来说,为了实现这个功能真的是困难重重啊啊啊啊啊~
首先是激活QQ窗口遇到了问题: 使用AppActivate
方法时,只能激活打开的窗口,最小化的窗口无法激活,找遍各大论坛,最后终于在贴吧一位老哥的评论中找到了答案,原来只要在AppActivate
方法后加sendKeys "{ENTER}"
就行
具体原因我研究了一下:最小化窗口状态下,AppActivate
方法把键盘焦点定位在聊天窗口的图标上
如图所示
这时候再按一下回车,也就是sendKeys "{ENTER}"
语句,就会打开聊天窗口,此时键盘焦点就到了聊天窗口的输入框内了
设置剪贴板内容失败: vbs程序不等剪贴板设置完成就执行下一条语句,后加Wscript.sleep
语句解决
除了这里,还有许多地方都有这个问题,都用此语句解决
设置鼠标坐标报错: 运行Demon的代码,显示如下问题
无法运行“SetCursorPos”
宏。可能是因为该宏在此工作薄中不可用,或者所有的宏都被禁用
百度半天无果,看到作者博文下面有人评论说也有相同的问题,但是作者没有回复,想自己研究,奈何又看不懂代码,差点就想放弃
幸好上天眷顾,让我看到了天灵狐的文章,太感动了,和我的问题一毛一样
根据天灵狐的解决方法:在Declare
后加PtrSafe
,定义SetCursor
函数,成功设置鼠标坐标!
但是又出现了新的问题,为毛鼠标无法点击啊~
鼠标无法点击: 既不报错,也没有任何反应,又是一波搜索,无果,只能自己琢磨了
突然灵感一现,在vba代码中定义一个函数click
,就像之前定义的SetCursor
一样
"sub click(s,a,b,c,d)" & vbCrLf & _
"mouse_event s, a, b, c, d " & vbCrLf & _
"end sub"
执行!
竟然成功了!(具体原因未知)
我完全不会vbs啊哈哈哈ヾ(≧▽≦*)o
设置好QQ电话的坐标,设置鼠标单击,完成
激活窗口又出问题: 明明自动发消息的程序都能激活最小化窗口,到这里突然不行了,虽然不影响使用,但是秉着精益求精的精神,我还是找到了解决办法。果然又是编码问题,我的文件编码是UTF-8,改成ANSI即刻解决,感觉只要和中文有关的错误,99%都是编码问题(记重点)
个人猜测原因:ANSI代表系统编码,QQ聊天窗口名的编码应该也是系统编码,所以要设置成ANSI才能匹配
想要轰炸沙雕朋友的拿去吧,亲测Win10系统、Ofiice2019环境下可以运行,目测低版本系统下也是可以的