我开发了下面的宏来扫描 Outlook 并粘贴到 Excel 中，在 Excel 工作簿中运行代码。但是，我需要它每天晚上 8:30 自动运行，所以我认为它需要从 Outlook 中运行，而不是使用某种预约调度程序在 excel 中运行。最终，一旦宏完成，我希望将 3 个附件标题电子邮件移动到 Outlook 中指定的存档文件夹。
Option Explicit
Sub ExtractDataFromOutlookEmail()
' Late binding. Outlook variables declared as Object.
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim OutlookFolder As Object
Dim OutlookItem As Object
Dim Attachment As Object
Dim ExcelWorkbook As Workbook
Dim ExcelWorksheet As Worksheet
Dim TempFilePath As String
Dim RangeToExtract As Range
Dim RangeToCopy As Range
' Set the path where you want to save the extracted data
TempFilePath = Environ$("temp")
' Set the range where you want to paste the extracted data
' **** ThisWorkbook is used - code must be in Excel ****
Set RangeToExtract = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1) ' Change to your desired range
' Create a new Outlook application
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Specify the Outlook folder where the email is located
'Set OutlookFolder = OutlookNamespace.GetDefaultFolder(olFolderInbox) ' Change to the appropriate folder
' With late binding
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6) ' Change to the appropriate folder
'Set OutlookFolder = OutlookNamespace.pickfolder
'Application.ScreenUpdating = False
' Loop through the emails in the folder
For Each OutlookItem In OutlookFolder.Items
'Debug.Print OutlookItem.Subject
If TypeName(OutlookItem) = "MailItem" Then
' Check if the email has the desired attachments
If OutlookItem.Attachments.Count >= 1 Then
' Check if the attachments have specific titles
Dim AttachmentTitles(1 To 3) As String
AttachmentTitles(1) = "Queue Status - Collections.csv" ' Replace with the title of the first attachment
AttachmentTitles(2) = "KPI Collections - Inbound.csv" ' Replace with the title of the second attachment
AttachmentTitles(3) = "KPI Collections - Outbound.csv" ' Replace with the title of the third attachment
Dim AttachmentCount As Long
AttachmentCount = 0
' Loop through the attachments in the email
For Each Attachment In OutlookItem.Attachments
If Attachment.Filename = AttachmentTitles(1) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(1)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(1))
' Copy the data from the Excel attachment
Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("A2:S12") ' Assuming data is in the first sheet
RangeToCopy.Copy Destination:=RangeToExtract.Offset ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next Attachment
For Each Attachment In OutlookItem.Attachments
If Attachment.Filename = AttachmentTitles(2) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(2)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(2))
' Copy the data from the Excel attachment
Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("H2:X12") ' Assuming data is in the first sheet
RangeToCopy.Copy Destination:=RangeToExtract.Offset(, 19) ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next Attachment
For Each Attachment In OutlookItem.Attachments
If Attachment.Filename = AttachmentTitles(3) Then
' Save the attachment to the temporary location
Attachment.SaveAsFile TempFilePath & AttachmentTitles(3)
' Open the saved Excel attachment
Set ExcelWorkbook = Workbooks.Open(TempFilePath & AttachmentTitles(3))
' Copy the data from the Excel attachment
Set RangeToCopy = ExcelWorkbook.Sheets(1).Range("H2:X12") ' Assuming data is in the first sheet
RangeToCopy.Copy Destination:=RangeToExtract.Offset(, 36) ' Offset to paste data in different columns
' Close the Excel attachment
ExcelWorkbook.Close SaveChanges:=False
' Clean up Excel objects
Set ExcelWorksheet = Nothing
Set ExcelWorkbook = Nothing
' Increment the attachment count
AttachmentCount = AttachmentCount + 1
' Exit the loop if all three attachments are processed
If AttachmentCount >= 3 Then Exit For
End If
Next Attachment
End If
End If
Next OutlookItem
' Clean up Outlook objects
Set OutlookItem = Nothing
Set OutlookFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
' Delete the temporary Excel files
If Dir(TempFilePath & AttachmentTitles(1)) <> "" Then
Kill TempFilePath & AttachmentTitles(1)
End If
If Dir(TempFilePath & AttachmentTitles(2)) <> "" Then
Kill TempFilePath & AttachmentTitles(2)
End If
If Dir(TempFilePath & AttachmentTitles(3)) <> "" Then
Kill TempFilePath & AttachmentTitles(3)
End If
Application.ScreenUpdating = True
End Sub
我尝试过各种组合，但没有成功。我想知道除了我已有的模块之外是否还需要添加单独的模块而不是 1 个巨大的代码？
您可以使用
OnTimealertTime = Now + TimeValue("00:30:00")
Application.OnTime alertTime, "EventHandler"
然后只需在工作簿中有一个名为
EventHanderPublic Sub EventHandler()
alertTime = Now + TimeValue("00:30:00")
Application.OnTime alertTime, "EventHandler"
End Sub
Outlook 或 Excel 中的宏只能在主机应用程序运行时运行。当 Excel 和 Outlook 关闭时，您的 VBA 宏无法运行。任务调度程序根本不是为此类事情而设计的。因为 Microsoft 目前不建议也不支持从任何无人值守、非交互式客户端应用程序或组件（包括 ASP、ASP.NET、DCOM 和 NT 服务）实现 Microsoft Office 应用程序的自动化，因为 Office 可能会表现出不稳定的行为，并且/或在这种环境下运行 Office 时出现死锁。
如果您正在构建在服务器端上下文中运行的解决方案，则应尝试使用可安全执行无人值守执行的组件。或者，您应该尝试找到允许至少部分代码在客户端运行的替代方案。如果您使用服务器端解决方案中的 Office 应用程序，该应用程序将缺乏许多成功运行所需的功能。此外，您还将面临整体解决方案稳定性的风险。请阅读Office 服务器端自动化的注意事项 文章了解更多相关信息。