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