MacBook上通过Excel VBA发送带图片的WhatsApp消息问题求助

现有VBA脚本在Windows上可正常运行，但存在两个问题：

• 每条WhatsApp消息都会打开新标签页
• MacBook上无法完成剪贴板图片粘贴及消息发送操作

原代码如下：

For Each g In Range("rng_temp") ' Temp range set earlier based on number of tour guides needed
  '-- set text string
  sFName = Split(g.Value, " ")
  sFName = Trim(sFName(0)) '--- pull just the guides first name from the list
  
  sText = sFName & sWhatsAppText '-- string together name and WhatsApp text to send
  
  
  '-- extract guides tours
  Range("rng_GuideCrit").Value = g.Value
  GetEMailGuides '-- extract list of tours the current guide (g) is active
  '--- copy guide schedule to clipboard
  Range("rng_ExtractGuideTours").Select
  Range(Selection, Selection.End(xlDown)).CopyPicture , xlBitmap
  '--- get WhatsApp Phone Number
  whatsapp_number = Application.WorksheetFunction.XLookup(g.Value, Range("tbl_Guides[Guide]"), Range("tbl_Guides[Phone Number]"), "N/A")
 
 '-- create whats app text
  ThisWorkbook.FollowHyperlink "https://web.whatsapp.com/send?phone=%2B" & whatsapp_number & "&text=" & sText & "&app_absent=1&send=1"
    
    Application.Wait (Now() + TimeValue("00:00:5"))
    
     #If Mac Then '--- this is the section where I need the help - It needs to be able to paste in a picture that is in the clipboard 
        AppleScript("tell application " & Chr(34) & "System Events" & Chr(34) & "to keystrke ""f"" using (command down)")
        AppleScript("tell application " & Chr(34) & "System Events" & Chr(34) & "to keystrke ""36""")
        
    #Else ' this works well on a Windows based computer
        Call SendKeys("^v") ', True
        Call SendKeys("{Enter}", True)
    #End If

    Application.Wait (Now() + TimeValue("00:00:01"))
    #If Mac Then '-- need to have it send the text
        AppleScript("tell application " & Chr(34) & "System Events" & Chr(34) & "to keystrke ""36""")
    #Else '-- again this works on Windows computer
        Call SendKeys("{Enter}", True)
    #End If
    Range("tbl_Tours[[#Headers],[Whats App Sent]]").Offset(i, 0).Value = "Yes" 'flags main table that WhatsApp message has been sent
    i = i + 1 'increments the counter for the next g loop
Next g

解决方案 #

1. 解决每条消息打开新标签页的问题 #

替换原代码中ThisWorkbook.FollowHyperlink的逻辑，改为控制现有浏览器窗口打开对话链接，避免新标签生成：

' 替换原FollowHyperlink行
#If Mac Then
    ' Mac端激活Safari，在当前标签打开WhatsApp对话
    Dim activateScript As String
    activateScript = "tell application ""Safari"" to activate" & vbCrLf & _
                     "tell application ""Safari"" to set URL of current tab to ""https://web.whatsapp.com/send?phone=%2B" & whatsapp_number & "&text=" & sText & "&app_absent=1&send=1"""
    AppleScriptTask(activateScript) ' 新版Office需用AppleScriptTask替代旧AppleScript方法
#Else
    ' Windows端用Chrome打开（用Edge则替换为msedge.exe），强制在现有窗口打开
    Shell "chrome.exe https://web.whatsapp.com/send?phone=%2B" & whatsapp_number & "&text=" & sText & "&app_absent=1&send=1", vbNormalFocus
#End If

2. 修复Mac端图片粘贴与消息发送功能 #

原Mac代码存在拼写错误（keystrke应为keystroke），且操作逻辑错误，替换为以下AppleScript实现粘贴图片并发送：

#If Mac Then
    Application.Wait (Now() + TimeValue("00:00:4")) ' 等待页面加载
    
    Dim sendScript As String
    sendScript = "tell application ""System Events"" " & vbCrLf & _
                  "    keystroke ""v"" using command down " & vbCrLf & _
                  "    delay 1 " & vbCrLf & _
                  "    keystroke return " & vbCrLf & _
                  "end tell"
    AppleScriptTask(sendScript)
#Else
    Call SendKeys("^v")
    Call SendKeys("{Enter}")
    Application.Wait (Now() + TimeValue("00:00:01"))
    Call SendKeys("{Enter}")
#End If

完整优化后的代码片段 #

For Each g In Range("rng_temp")
    sFName = Split(g.Value, " ")
    sFName = Trim(sFName(0))
    sText = sFName & sWhatsAppText
    
    Range("rng_GuideCrit").Value = g.Value
    GetEMailGuides
    Range("rng_ExtractGuideTours").Select
    Range(Selection, Selection.End(xlDown)).CopyPicture , xlBitmap
    
    whatsapp_number = Application.WorksheetFunction.XLookup(g.Value, Range("tbl_Guides[Guide]"), Range("tbl_Guides[Phone Number]"), "N/A")

    ' 打开WhatsApp对话（避免新标签）
    #If Mac Then
        Dim activateScript As String
        activateScript = "tell application ""Safari"" to activate" & vbCrLf & _
                         "tell application ""Safari"" to set URL of current tab to ""https://web.whatsapp.com/send?phone=%2B" & whatsapp_number & "&text=" & sText & "&app_absent=1&send=1"""
        AppleScriptTask(activateScript)
    #Else
        Shell "chrome.exe https://web.whatsapp.com/send?phone=%2B" & whatsapp_number & "&text=" & sText & "&app_absent=1&send=1", vbNormalFocus
    #End If
    
    Application.Wait (Now() + TimeValue("00:00:5"))

    ' 粘贴图片并发送
    #If Mac Then
        Dim sendScript As String
        sendScript = "tell application ""System Events"" " & vbCrLf & _
                      "    keystroke ""v"" using command down " & vbCrLf & _
                      "    delay 1 " & vbCrLf & _
                      "    keystroke return " & vbCrLf & _
                      "end tell"
        AppleScriptTask(sendScript)
    #Else
        Call SendKeys("^v")
        Call SendKeys("{Enter}")
        Application.Wait (Now() + TimeValue("00:00:01"))
        Call SendKeys("{Enter}")
    #End If

    Range("tbl_Tours[[#Headers],[Whats App Sent]]").Offset(i, 0).Value = "Yes"
    i = i + 1
Next g

额外注意事项 #

• Mac端需在「系统设置-隐私与安全性-自动化」中，允许Excel控制Safari和系统事件。
• 等待时间可根据网络速度调整，确保页面完全加载后再执行粘贴操作。
• Windows端若默认浏览器不是Chrome/Edge，需替换Shell命令中的浏览器可执行文件名。

内容的提问来源于stack exchange，提问作者Rick Fromm