outlook：自動ダウンロードのリンク文書

Question

サーバから各メールにリンクファイル付きのメールが届きます。 各電子メールを開き、各リンクファイルをローカルディレクトリにダウンロードし、電子メールを別のディレクトリに移動する（完了した）VBAコードが存在するかどうかを知っていますか？ お返事ありがとうございました。 Christophe

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