![](/img/trans.png)
[英]Method 'ThisWorkbook' of object '_Global' failed - Exporting comments from Word to Excel
[英]Method 'ThisWorkbook' of object '_Global' failed
我正在嘗試將郵件的主題、發件人姓名、電子郵件日期從 PST 郵箱復制到 Excel 工作簿。 這是我到目前為止的代碼:
Option Explicit
Sub Download_Outlook_Mail_To_Excel()
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
MailBoxName = "Backupmailbox"
Pst_Folder_Name = "Inbox1" 'Sample "Inbox" or "Sent Items"
'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If
'Read Through each Mail and export the details to Excel for Email Archival
ThisWorkbook.Sheets(1).Activate
Folder.Items.Sort "Received"
'Insert Column Headers
ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
'Export eMail Data from PST Folder
oRow = 1
For iRow = 1 To Folder.Items.Count
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
oRow = oRow + 1
ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing
End_Lbl1:
End Sub
當我運行代碼時,我得到
“對象范圍方法_全局失敗”
來自語句ThisWorkbook.Sheets(1).Activate
我啟用了 Microsoft Excel 14.0 對象庫參考,因為代碼是從 Outlook 應用程序執行的。
有誰知道這個錯誤是什么意思,我該如何解決?
只需進行一些快速調整,試試這個:
Option Explicit
Sub Download_Outlook_Mail_To_Excel()
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer
Dim oRow As Integer
Dim MailBoxName As String
Dim Pst_Folder_Name As String
Const xlWorkbookName As String = "C:\Users\MacroMan\MyWorkbook.xlsx" '// change as required
'// I'm using late binding in case you don't actually have a reference set.
Dim xlApp As Object
Dim xlWB As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open(xlWorkbookName)
MailBoxName = "Backupmailbox"
Pst_Folder_Name = "Inbox1" 'Sample "Inbox" or "Sent Items"
'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)
'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder
Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If
'Read Through each Mail and export the details to Excel for Email Archival
xlWB.Sheets(1).Activate
Folder.Items.Sort "Received"
'Insert Column Headers
xlWB.Sheets(1).Cells(1, 1) = "Sender"
xlWB.Sheets(1).Cells(1, 2) = "Subject"
xlWB.Sheets(1).Cells(1, 3) = "Date"
xlWB.Sheets(1).Cells(1, 4) = "Size"
xlWB.Sheets(1).Cells(1, 5) = "EmailID"
'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"
'Export eMail Data from PST Folder
oRow = 1
For iRow = 1 To Folder.Items.Count
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
oRow = oRow + 1
xlWB.Sheets(1).Cells(oRow, 1).Select
xlWB.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
xlWB.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
xlWB.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
xlWB.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
xlWB.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing
xlWB.Close False
Set xlWB = Nothing
xlApp.Quit
Set xlApp = Nothing
End_Lbl1:
End Sub
這將為您打開工作簿,因此無需事先這樣做
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.