使用VBA实现微信群发信息（支持发文件）

E风卍行H

网上很多关于使用VBA实现微信群发信息的内容，但试了一圈，总是或多或少有点问题，要不然就是要安装其他插件（效果也不理想）。因此就把找到的资料整理下搞了一个简单的，在此分享一下，希望对后来者有所帮助。


第2版主要更新内容：消息内容太多的时候，用 Sendkeys 方法太慢，改用 剪贴板

E风卍行H

Private Declare PtrSafe Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)

Sub test()
    Dim arr
    Dim name As String
    Dim msg As String
    Dim k As Long, j As Long
    Dim n As Long
   
    Rem 判断微信是否已打开
    If 判断微信是否打开() = False Then
        MsgBox "请先打开微信！"
        Exit Sub
    End If
   
    Rem 选择文件夹
    Dim folderPath As String
    folderPath = SelectFolder()
    If folderPath = "" Then Exit Sub
    folderPath = folderPath & "\"
   
    Rem 遍历文件
    Dim arrFile() As String
    Dim trr
    trr = GetFileName(folderPath)
    If Not IsArray(trr) Then
        MsgBox "未找到文件！"
        Exit Sub
    End If
    ReDim arrFile(1 To UBound(trr))
    For k = 1 To UBound(trr)
        arrFile(k) = trr(k)
    Next
   
   
    Rem 根据路径打开微信程序
'    Shell "D:\SoftInstall\WeChat\WeChat.exe"
   
    n = Range("A" & Rows.Count).End(xlUp).Row
    arr = Range("A1").Resize(n, 2).Value
   
    Rem Ctrl + Alt + W 打开微信界面
    SendKeys "^%w"
   
    For k = 1 To n
        name = arr(k, 1)    '微信名
        msg = arr(k, 2)     '信息
        
        Rem 微信名写入剪贴板（测试发现有些微信息使用 Sendkeys 发送不成功，改用剪贴板）
        Call 文本写入剪贴板(name)
        Sleep 500   '延时等待
        
        Rem 在微信中按 Ctrl + F 搜索
        SendKeys "^f"
        Sleep 500
        
        SendKeys "^A"
        Sleep 50
        
        Rem Ctrl + V 粘贴微信名
        SendKeys "^v"
        Sleep 500
        
        Rem 回车，打开对话框
        SendKeys "{Enter}"
        Sleep 500
        
        Rem 输入信息
        SendKeys msg
        Sleep 500
        
        Rem 发送信息
        SendKeys "{Enter}"
        Sleep 500
        
        Rem 调用API，一次性复制多个文件
        CutOrCopyFiles arrFile
        Sleep 500
        
        Rem 粘贴文件
        SendKeys "^v"
        Sleep 500
        
        Rem 发送文件
        SendKeys "{Enter}"
        Sleep 500
        
        Rem 调用API，逐个复制文件
'        For j = 1 To UBound(arrFile)
'            Rem 复制文件到剪贴板
'            clipCopyFile (folderPath & arrFile(j))
'            Sleep 500
'
'            Rem 粘贴文件
'            SendKeys "^v"
'            Sleep 500
'
'            Rem 发送文件
'            SendKeys "{Enter}"
'            Sleep 500
'        Next
    Next
   
    Rem 以上代码执行结束后，NUM 键熄灭，再按一次
    SendKeys "{NUMLOCK}"    '按下数字锁定键
    SendKeys "%{Tab}"       'Alt + Tab 返回 Excel 界面
   
End Sub

ykcbf1100

只能选择文件夹，不能选择文件

autohotey

如果做成通过C列文件名去找对应文件，就更好了

E风卍行H

ykcbf1100 发表于 2024-11-11 11:02
只能选择文件夹，不能选择文件

是的，做的时候就想着选一个文件夹，里面所有的文件都可以发送

perfect131

用ws sendkeys 不然数字键会失效

E风卍行H

autohotey 发表于 2024-11-11 11:43
如果做成通过C列文件名去找对应文件，就更好了

嗯，这个只是最基础的，实际应用一般不会这么简单，于少会有公共文本和特珠称谓这些

E风卍行H

perfect131 发表于 2024-11-11 13:57
用ws sendkeys 不然数字键会失效

这个方法也试了，测试过程中不是很理想(好像是执行完毕后键盘打不了字、鼠标不能双击打开文件还是什么情况来着，忘了），就用了现在的方法在最后再加了一句 SendKeys "{NUMLOCK}"

weiqigreen

我使用影刀和UIbot来实现的，感觉更稳定、可靠。

hcunicom

weiqigreen 发表于 2024-11-12 08:42
我使用影刀和UIbot来实现的，感觉更稳定、可靠。

大家说稳定可靠才真的稳定可靠
我的也很稳定很可靠，因为我直接手工操作微信
而楼主的东西   是经过大家直接拿来测试了滴