Cách lưu nhiều tệp đính kèm pdf trong Outlook vào ổ cứng bằng cách trích xuất các mục thư

Tôi có 25 thư mà mỗi thư có 25 tệp đính kèm pdf trong đó chỉ trong một email - xếp tầng cho nhau. Nói cách khác, một email chứa 25 mục thư triển vọng có 1 pdf được đính kèm mỗi email. Tôi đã tìm thấy một mã để lưu tất cả các tệp đính kèm nhưng khi tôi làm điều đó, nó sẽ chỉ lưu chúng dưới dạng mục thư triển vọng. Tôi sẽ cần trích xuất pdf từ (các) mục mail. Bất kỳ mã VBA được biết đến cho điều này ??? - Xin lưu ý rằng tôi không thể cài đặt phần mềm yêu cầu quản trị viên vượt qua vì đây là máy tính làm việc. Vì vậy, nếu bạn giới thiệu cho tôi phần mềm của bên thứ ba, tôi sẽ không thể cài đặt chúng trừ khi chúng được nén hoặc cắm vào triển vọng Windows như mã VBA hoặc một cái gì đó.

Hình ảnh ví dụ

Để biết thêm thông tin tham khảo hình ảnh này

Khi bạn đã lưu một mục Outlook, bạn có thể mở nó bằng OpenSharedItem

https://msdn.microsoft.com/EN-US/l Library / office / ff869733.aspx

sau đó lưu tệp đính kèm PDF.

Nếu bạn đã có mã để lưu mailitem thì ngay sau khi mỗi mailitem được lưu, hãy chèn OpenSharedItem và cũng như mã để lưu PDF.

Dưới đây là mã ví dụ minh họa cách đưa thư trở lại từ Windows sang Outlook với OpenSharedItem. https://www.slipstick.com/developer/code-samples/move-messages-file-system-outlook/

Sub ImportMessagesInFolder()
    Dim fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SourceFolderName As String
    Dim FileItem As Scripting.File
    Dim strFile, strFileType As String
    Dim oMsg As Object
    Dim copiedMsg As MailItem
    Dim Savefolder As Outlook.Folder

    Set fso = New Scripting.FileSystemObject
'Source folder
    SourceFolderName = "C:\Users\drcp\Documents\Email\"
    Set SourceFolder = fso.GetFolder(SourceFolderName)

'Set the Outlook folder name
    ' Set Savefolder = Session.GetDefaultFolder(olFolderInbox).Folders("My Subfolder")
    Set Savefolder = Application.ActiveExplorer.CurrentFolder

    For Each FileItem In SourceFolder.Files

    Set oMsg = Session.OpenSharedItem(FileItem.Path)

    ' Do not bypass errors indiscriminately
    'On Error Resume Next

    Set copiedMsg = oMsg.Copy
    copiedMsg.Move Savefolder

    Set copiedMsg = Nothing
    oMsg.Delete
    Set oMsg = Nothing

    Next FileItem

    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set fso = Nothing

End Sub

Bạn có thể làm điều đó bằng cách sử dụng hai tiện ích miễn phí.

Đầu tiên, lưu các mục Outlook đính kèm . Chỉ cần tạo thư mục tạm thời trong Outlook của bạn (giả sử "Đã đính kèm"), chọn 25 thư này trong Outlook và chạy công cụ được đề cập bằng menu ngữ cảnh chỉ định thư mục "Đã đính kèm" làm thư mục đích. Bây giờ bạn có tất cả các email đính kèm (có tệp PDF) trong thư mục "Đã đính kèm" tạm thời.

Cuối cùng, sử dụng tiện ích Lưu tệp đính kèm , chọn thư mục "Đã đính kèm" và chỉ định thư mục đích trên đĩa của bạn. Điều này sẽ lưu tất cả các tệp PDF vào thư mục được chỉ định.

Xin lưu ý rằng tôi khuyên dùng các công cụ này vì tôi là một trong những nhà phát triển, vì vậy, vui lòng hỏi thêm bất kỳ câu hỏi nào.

Ok, tôi đã tìm ra. Đầu tiên bạn cần tạo một thư mục mới trong hộp thư đến của bạn. Sau đó, sao chép tất cả các mục email vào thư mục mới của bạn (25 mục email triển vọng có chứa 25 pdf) được đính kèm. Và sau đó làm nổi bật tất cả các email sau đó chạy bên dưới tập lệnh. Điều này sẽ cho phép bạn lưu tất cả chúng.

Sub ImportMessagesInFolder()
Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SourceFolderName As String
Dim FileItem As Scripting.File
Dim strFile, strFileType As String
Dim oMsg As Object
Dim copiedMsg As MailItem
Dim Savefolder As Outlook.Folder

Set fso = New Scripting.FileSystemObject
'Source folder
SourceFolderName = "C:\Users\drcp\Documents\Email\"
Set SourceFolder = fso.GetFolder(SourceFolderName)

 'Set the Outlook folder name
' Set Savefolder = Session.GetDefaultFolder(olFolderInbox).Folders("My Subfolder")
Set Savefolder = Application.ActiveExplorer.CurrentFolder

For Each FileItem In SourceFolder.Files

Set oMsg = Session.OpenSharedItem(FileItem.Path)

' Do not bypass errors indiscriminately
'On Error Resume Next

Set copiedMsg = oMsg.Copy
copiedMsg.Move Savefolder

Set copiedMsg = Nothing
oMsg.Delete
Set oMsg = Nothing

Next FileItem

Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing

End Sub