[英]export email from outlook
您能否建議如何從excel文件中導出電子郵件? 我有一個excel文件,其列名為emails-這是電子郵件列表。
VBA
腳本如何檢查Outlook中excel文件中的每封電子郵件,並將包含主題,數據,發件人的電子郵件從這些excel文件導出到當前excel中的新excel文件或新工作表。 我有這個腳本:
Const MACRO_NAME = "Export Messages to Excel (Rev 4)"
Sub ExportMessagesToExcelbyDate()
Dim olkLst As Object, _
olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String, _
strDateRange As String, _
arrTemp As Variant, _
datStart As Date, _
datEnd As Date
strFilename = InputBox("Enter a filename to save the exported messages to.", , MICRO_NAME)
If strFilename <> "" Then
strDateRange = InputBox("Enter the date range of the messages to export in the form ""mm/dd/yyyy to mm/dd/yyyy""", MACRO_NAME, Date & " to " & Date)
arrTemp = Split(strDateRange, "to")
datStart = IIf(IsDate(arrTemp(0)), arrTemp(0), Date) & " 12:00am"
datEnd = IIf(IsDate(arrTemp(1)), arrTemp(1), Date) & " 11:59pm"
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
'Write messages to spreadsheet
Set olkLst = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(datStart, "ddddd h:nn AMPM") & "'" & " AND [ReceivedTime] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
For Each olkMsg In olkLst
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set olkLst = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, MICRO_NAME
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function
但是此腳本僅導出Outlook中的選定文件夾。 更重要的是,它應該從對話歷史記錄中導出。 例如,在excel文件中,有郵箱YourMailbox@gmail.com。 腳本應查找與此人的所有對話歷史記錄和電子郵件,並從電子郵件中導出信息。 信息,例如主題,發件人,日期。 另外腳本應該檢查來自excel文件的所有列表電子郵件,而不是一個。
感謝您的建議。
Application.ActiveExplorer.CurrentFolder
將獲取當前選擇文件夾,如果要獲取所有文件夾,可以參考以下代碼:
Option Explicit
Sub repopulate3()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olparentfolder As Outlook.Folder
Dim olMail As Object
Dim eFolder As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long
'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")
Set olparentfolder = olNs.GetDefaultFolder(olFolderInbox)
'wb.Sheets("vlookup").range("A2:C500").ClearContents
'i think you want column E here, not L?
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row
ProcessFolder olparentfolder
ExitRoutine:
Set olparentfolder = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Private Sub ProcessFolder(ByVal oParent As Outlook.Folder)
Dim olFolder As Outlook.Folder
Dim olMail As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long
'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row
For i = oParent.Items.Count To 1 Step -1
Debug.Print oParent
If TypeOf oParent.Items(i) Is MailItem Then
Set olMail = oParent.Items(i)
Debug.Print " " & olMail.Subject
Debug.Print " " & olMail.ReceivedTime
Debug.Print " " & olMail.SenderEmailAddress
Debug.Print
'For iCounter = 2 To lastrow
'If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
'With ws
' lrow = .range("A" & .Rows.count).End(xlUp).Row
' .range("C" & lrow + 1).Value = olMail.body
' .range("B" & lrow + 1).Value = olMail.ReceivedTime
' .range("A" & lrow + 1).Value = olMail.SenderEmailAddress
'End With
'End If
'Next iCounter
End If
Next i
If (oParent.Folders.Count > 0) Then
For Each olFolder In oParent.Folders
ProcessFolder olFolder
Next
End If
End Sub
有關更多信息,請參考以下鏈接:
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.