如何让我的Excel宏在Outlook中运行,而不是

bnlyeluc  于 2023-10-21  发布在  其他
关注(0)|答案(1)|浏览(94)

下面的代码在目标Excel工作簿中运行时效果非常好。我最终想从Outlook中运行宏。当我尝试将路径添加到目标文件时遇到问题:

Dim DestFile as Object 
Set DestFile = Workbooks("T:\3-Lending Systems Analyst\Collections Master Workbook.xlsm")

它说下标超出范围。是因为它在外部驱动器上吗?我需要先激活ExcelApp和/或打开工作簿吗?我能想到的办法都试过了。
谢谢您的帮助!

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(6).Folders("Projects").Folders("Collections").Folders("Daily Reports") ' Change to the appropriate folder
    
    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
bwleehnv

bwleehnv1#

1.当在Excel中运行时,Application内部变量指向Excel.Application对象的示例,并且它以一种使其所有属性和方法全局化的方式公开,即你不必使用Application.Worksheets,你可以使用Worksheets
1.当在Outlook Explorer中运行时,Application指向Outlook.Application对象的示例。
你必须考虑到上面的两点。在我的脑海中,我可能错过了一些东西:

Option Explicit

Sub ExtractDataFromOutlookEmail()
    
    ' Late binding. Outlook variables declared as Object.
    Dim OutlookApp As Object
    Dim ExcelApp As Object
    Dim ThisWorkbook 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")

    'ThisWorkbook must be initialized explicitly
    set ExcelApp = CreateObject("Excel.Application")
    set ThisWorkbook = ExcelApp.Workbooks.Open("c:\temp\some.worksheet.xlsx") 
    
    ' 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 = Application 'Application points to Outlook.Application in Outlook VBA
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' Specify the Outlook folder where the email is located
    Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6).Folders("Projects").Folders("Collections").Folders("Daily Reports") ' Change to the appropriate folder
    
    ExcelApp.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
    
    ExcelApp.ScreenUpdating = True
    
End Sub

相关问题