如何从 Outlook 宏运行 Excel 宏？

Question

如何从 Outlook 宏运行 Excel 宏？

Answer 1

您需要添加 Microsoft Excel 14.0 数据对象库。转到工具-> 参考。

您还需要先打开工作簿，然后才能从中运行宏。

这应该可行：

 Dim ExApp As Excel.Application
 Dim ExWbk As Workbook
 Set ExApp = New Excel.Application
 Set ExWbk = ExApp.Workbooks.Open("C:\Folder\Folder\File.xls")
 ExApp.Visible = True

 ExWbk.Application.Run "ModuleName.YourMacro"

 ExWbk.Close SaveChanges:=True

如果您想在后台运行此宏而不打开可见的 Excel 实例，请将 ExApp.Visible 设置为 False。

Answer 2

我只是想分享一下我是如何做到这一点的。它不适用于 OP 的需求，但标题可能会导致其他人在这里了解更多我正在分享的内容。这将（可选地按发件人/主题过滤）从 Outlook 中收到的电子表格中保存/打开/运行宏。然后我有时在 excel 中有一个宏，它会发送通知/响应等，但我不会从 Outlook 执行此操作（也许可以！）。

创建一个 VBS 脚本，该脚本将启动 excel 文件并运行宏（可选地，宏可以存储在单独的电子表格中。）

“runmacro.vbs”

Set args = Wscript.Arguments

ws = WScript.Arguments.Item(0)
macro = WScript.Arguments.Item(1)
If wscript.arguments.count > 2 Then
 macrowb = WScript.Arguments.Item(2)
End If

LaunchMacro

Sub LaunchMacro() 
  Dim xl
  Dim xlBook  

  Set xl = CreateObject("Excel.application")
  Set xlBook = xl.Workbooks.Open(ws, 0, True)
  If wscript.arguments.count > 2 Then
   Set macrowb = xl.Workbooks.Open(macrowb, 0, True)
  End If
  'xl.Application.Visible = True ' Show Excel Window
  xl.Application.run macro
  'xl.DisplayAlerts = False  ' suppress prompts and alert messages while a macro is running
  'xlBook.saved = True ' suppresses the Save Changes prompt when you close a workbook
  'xl.activewindow.close
  xl.Quit

End Sub

Outlook VBA 代码（ThisOutlookSession）：

https://www.slipstick.com/outlook/email/save-open-attachment/

Private Declare Function GetShortPathName Lib "kernel32" _
 Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
 ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

 Private Sub objItems_ItemAdd(ByVal Item As Object)
    Dim objMail As Outlook.MailItem
    Dim objWsShell As Object
    Dim strTempFolder As String
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Attachment
    Dim strFileName As String
    Dim Subject As String

    Subject = Item.Subject
    'If Subject Like "*SubTest*" Then

    If Item.Class = olMail Then
       Set objMail = Item
       'Change sender email address
       'If objMail.SenderEmailAddress = "boss@datanumen.com" Then
          Set objWShell = CreateObject("WScript.Shell")
          strTempFolder = Environ("Temp") & "\"

          Set objWsShell = CreateObject("WScript.Shell")
          Set objAttachments = objMail.Attachments
          If objAttachments.Count > 0 Then
             For Each objAttachment In objAttachments
                 strFileName = objAttachment.DisplayName
                 On Error Resume Next
                 Kill strTempFolder & strFileName
                 On Error GoTo 0

                 'Save the attachment
                 objAttachment.SaveAsFile strTempFolder & strFileName

                 'Open the attachment
                 vbs = (Chr(34) & "\\Server\Excel\" & "\runmacro.vbs " & Chr(34))
                 strFileName = GetShortFileName(strTempFolder & strFileName)
                 macro = "MacroName"
                 xlam = Environ("APPDATA") & "\Microsoft\Excel\XLSTART\Add-In.xlam"
                 On Error Resume Next
                 objWsShell.Run vbs & " " & strFileName & " " & macro & " " & xlam
                 objMail.UnRead = False
Next
          'End If
        End If
    End If
    'End If
End Sub

Function GetShortFileName(ByVal FullPath As String) As String
    Dim lAns As Long
    Dim sAns As String
    Dim iLen As Integer

    On Error Resume Next

    If Dir(FullPath) <> "" Then
       sAns = Space(255)
       lAns = GetShortPathName(FullPath, sAns, 255)
       GetShortFileName = Left(sAns, lAns)
    End If
End Function