outlook : 自动下载链接文件

Question

服务器向我发送电子邮件，每封电子邮件中都有一个链接文件。 你知道它是否存在一个打开每封电子邮件的 VBA 代码，在本地目录中下载每个链接文件，然后将电子邮件移动到另一个目录中（如已完成）？ 非常感谢您的回复。 克里斯托夫

Answer 1

如果你想从 Outlook 下载电子邮件，你可以试试这个脚本。

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

现在，假设您要下载电子邮件并保存每个单独的文本文件，请运行此脚本。

Public Sub ProcessInbox()

    Dim oOutlook As Outlook.Application
    Dim oNs As Outlook.NameSpace
    Dim oFldr As Outlook.MAPIFolder
    Dim oAttachments As Outlook.Attachments
    Dim oAttachment As Outlook.Attachment
    Dim iMsgCount As Integer

    Dim oMessage As Outlook.MailItem

    Dim iCtr As Long, iAttachCnt As Long

    Dim sFileNames As String
    Dim aFileNames() As String

'get reference to inbox
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Debug.Print "Total Items: "; oFldr.Items.Count
Debug.Print "Total Unread items = " & oFldr.UnReadItemCount

For Each oMessage In oFldr.Items

        With oMessage
            'basic info about message
            Debug.Print.To
            Debug.Print.CC
            Debug.Print.Subject
            Debug.Print.Body
            If .UnRead Then
                Debug.Print "Message has not been read"
            Else
                Debug.Print "Message has been read"
            End If
            iMsgCount = iMsgCount + 1
            'save message as text file
            .SaveAs "C:\message" & iMsgCount & ".txt", olTXT

            'reference and save all attachments
            With oMessage.Attachments
                iAttachCnt = .Count
                If iAttachCnt > 0 Then
                    For iCtr = 1 To iAttachCnt

                        .Item(iCtr).SaveAsFile "C:\Users\your_path_here\" & .Item(iCtr).FileName

                    Next iCtr
                End If
            End With
        End With
        DoEvents

    Next oMessage

    Set oAttachment = Nothing
    Set oAttachments = Nothing
    Set oMessage = Nothing
    Set oFldr = Nothing
    Set oNs = Nothing
    Set oOutlook = Nothing

End Sub

您可以在我的书中阅读有关这些技术的所有内容，以及许多、许多、更多的内容。

https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC/ref=sr_1_1?ie=UTF8&qid=1468466759&sr=8-1&keywords=ryan+shuell