如何在Outlook宏中运行Excel宏？

Question

我该如何从Outlook宏中运行Excel宏？

- ZHE.ZHAO

---

你可以将它从其他文件中取出并放入你的个人宏工作簿中，这样它就可以在任何 Excel 文件中使用。请参见此链接获取微软文档。 - Automate This

事实上，我的处理过程由两个部分组成。第一个部分在OUTLOOK中启动宏，将邮件附件保存在指定的文件夹中。第二个部分在Excel文件中启动宏。我只想在第一个处理完成后立即启动在Excel中定义的宏，但始终在OUTLOOK的宏中执行。 - ZHE.ZHAO

我认为这个问题的标题有点误导人。阅读实际问题，似乎OP试图从Outlook中的宏运行Excel工作簿中的宏，而不是不同的Excel文件。 - asp8811

抱歉，我写的标题确实有误。 - ZHE.ZHAO

@asp8811 你应该对标题进行建议的编辑。 - Toby Allen

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。

- asp8811

---

嗨，这部分代码出现了问题："Dim ExApp As Excel.Application"。它说这种类型未定义。（我应该将代码放在 OUTLOOK 的宏中） - ZHE.ZHAO

你是否添加了Excel对象库？在添加之前，Outlook将缺少必要的引用来了解Excel应用程序或如何使用它。编辑：我尝试过这段代码，如果你有参考资料，它是可以工作的。如果没有，它将会抛出与您遇到的相同错误。您需要进入“工具”->“参考”。在列表中找到Microsoft Excel 14.0数据对象库，并选中旁边的复选框。单击“确定”，然后再尝试该代码。 - asp8811

太酷了！它运行了！我混合使用了MS office 14.0数据对象库和MS数据对象库。非常感谢！！ - ZHE.ZHAO

Answer 2

我只是想分享一下我是如何做到这一点的。这并不适用于楼主的需求，但标题可能会吸引其他人来了解更多我所分享的内容。这将（可选地按发件人/主题进行过滤）保存/打开/运行从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 = "[e-mail]" 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

- FreeSoftwareServers