excel - 将共享 Outlook 文件夹的内容导出到 Excel
问题描述
我想将共享邮箱中的邮件导出到 Excel。
这是从我的默认邮箱导出邮件的代码。
Sub ExportEmailsfromSpecificSender()
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As MAPIFolder
Dim objSubFolder As MAPIFolder
Dim objSubSubFolder As MAPIFolder
Dim EmailCount As Integer
' Dim dateStr As String
Dim myItems As Outlook.Items
Dim myFilterItems As Outlook.Items
' Dim dict As Object
' Dim msg As String
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
' Dim intVersion As Integer
' Dim intMessages As Integer
Dim lngRow As Long
Dim strFilename As String
Dim objCategory As Category
Dim strFilter As String
Dim objEmails, objSpecificEmails As Outlook.Items
Dim objItem As Object
Dim strSpecificSender As String
Dim nRow As Integer
Dim strFilePath As String
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add
On Error Resume Next
'Get the emails from a specific sender
'Set Items = GetFolderPath("PD Services\RetainPermanently\07 July 2018\").Items
Set objEmails = Application.Session.GetDefaultFolder(olFolderInbox).Items
strSpecificSender = InputBox("Input the name of the specific sender:", "Specify Sender")
strFilter = "[From] = '" & strSpecificSender & "'"
Set objSpecificEmails = objEmails.Restrict(strFilter)
Set objExcelApplication = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApplication.Workbooks.Add
'Export the specific emails to worksheet
Set objExcelWorksheet = objExcelWorkbook.Worksheets(1)
With objExcelWorksheet
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Body"
End With
nRow = 2
For Each objItem In objSpecificEmails
With objExcelWorksheet
.Name = "From " & strSpecificSender
.Cells(nRow, 1) = objItem.Subject
.Cells(nRow, 2) = objItem.ReceivedTime
.Cells(nRow, 3) = objItem.Body
End With
nRow = nRow + 1
Next
objExcelWorksheet.Columns("A:E").AutoFit
'Save the Excel workbook
strFilePath = "H:\WINDOWS\system\Mitushi Documents " & strSpecificSender & ".xlsx"
objExcelWorkbook.Close True, strFilePath
'Notify you of the export complete
MsgBox ("Export Complete!")
End Sub
我收到一个只有列标题的空白 Excel 文件。
我应该在这里修改什么以从名为“PD Services”的共享邮箱和名为“RetainPermanently”的文件夹中获取电子邮件?
解决方案
我不确定“共享文件夹”是什么,但请尝试下面的脚本,看看是否能得到想要的结果。
Option Explicit On
Const fPath As String = "C:\Users\your_path_here\" 'The path to save the messages
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err() <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
'.Cells(NextRow, 6) = olItem.Body 'Are you sure?
End If
Next olItem
End With
MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) &
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object,
strPath As String,
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
推荐阅读
- c# - 使用 c# 在 DataGridView 中仅遍历 1 列
- vb.net - 如何在 vb.net 中保存用户输入
- oracle - 如何使用 SQLPLUS 直接连接到 Oracle 数据库链接
- excel - Excel - 从单列中获取年份范围
- ios - 从“数据”强制转换?to 'Data' 只解开可选项;你的意思是使用'!'?
- python - Python 中的通用 3D 体积图
- google-chrome - Chrome 上的 PowerApps 登录问题
- arrays - 如何在swift 4中计算数组的所有模式?
- node.js - 如何使用 nodejs 和 mongoose 从 mongodb 集合中删除数据
- ios - 试图将从 Firebase 加载的 UICollectionView 中的图像传递给另一个 VC