分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话

首先本人没有任何vbs和vba基础,只学过c++和java,所以代码大部分来自网络

感谢Demon和天灵狐的攻略:
Demon博文地址
天灵狐博文地址

航母式开头尬聊

记得vbs整人代码很多来着,没想到百度了很久,根本找不到打QQ电话的教程,于是自己琢磨
实现过程中遇到了很多问题,百度辗转于多个作者的博文中,终于实现(为了轰炸沙雕朋友真不容易)

工具

安装了Windows系统、QQ和office的电脑一台
为什么需要office?因为调用了excel宏

实现方法

由于客户端QQ没有提供这方面的API,所以只能用模拟鼠标键盘输入的方式实现
首先模拟输入本身就不靠谱,本人只是为了娱乐,如果要确保稳定性还是请移步WebQQ吧

自动发消息

分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第1张图片
这个需要把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电话的坐标是多少,这里教一个很简单的方法:

  1. 打开QQ截图
  2. 移动鼠标到左上角
    分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第2张图片
  3. 按住鼠标拖动到QQ电话的位置
    分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第3张图片
  4. 坐标就是(1197-1,360-1),也就是(1196,359)啦
    每个人的坐标不一样,还是要自己去测量一下

由于调用了Excel宏,所以需要在Excel中启用宏

  1. 打开Excel选项,开发工具打勾,确定
    分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第4张图片
  2. 点击开发工具,再点宏安全性
    分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第5张图片
  3. 选择启用所有宏,确定
    分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第6张图片

这样代码就可以运行了

如果想要连续打电话(夺命连环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”宏。可能是因为该宏在此工作薄中不可用,或者所有的宏都被禁用
分分钟教你轰炸沙雕朋友——用vbs实现QQ自动发消息,打QQ电话_第7张图片
百度半天无果,看到作者博文下面有人评论说也有相同的问题,但是作者没有回复,想自己研究,奈何又看不懂代码,差点就想放弃
幸好上天眷顾,让我看到了天灵狐的文章,太感动了,和我的问题一毛一样

根据天灵狐的解决方法:在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环境下可以运行,目测低版本系统下也是可以的

你可能感兴趣的:(教程,vbs,笔记)