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

首先本人没有任何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电话的座标是多少，这里教一个很简单的方法：

1. 打开QQ截图
2. 移动鼠标到左上角
   
3. 按住鼠标拖动到QQ电话的位置
   
4. 座标就是（1197-1，360-1），也就是（1196，359）啦
   每个人的座标不一样，还是要自己去测量一下

---

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

1. 打开Excel选项，开发工具打勾，确定
   
2. 点击开发工具，再点宏安全性
   
3. 选择启用所有宏，确定
   

这样代码就可以运行了

如果想要连续打电话（夺命连环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环境下可以运行，目测低版本系统下也是可以的