VB宏将Outlook中共享文件夹的内容导出到Excel

时间:2018-07-26 14:46:33

标签: excel-vba

我想将邮件从共享邮箱导出到excel。我正在为其使用VB宏,但是在输出中,我收到的空白Excel文件仅包含列标题。 any1可以帮我解决我的代码吗: 这是一个从我的默认邮箱中导出邮件的工作代码。但是我应该在这里进行哪些修改,以便能够从名为“ PD Services”的共享文件夹中获取电子邮件,并且该文件夹的名称应为“ RetainPermanently”

    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

1 个答案:

答案 0 :(得分:0)

我不确定“共享文件夹”是什么,但是请尝试下面的脚本,看看是否获得所需的结果。

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