分分鐘教你轟炸沙雕朋友——用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環境下可以運行，目測低版本系統下也是可以的