Question

我使用了How to Quickly Extract Attachments from All Outlook Message Files in a Windows Folder中的代码，并根据附件的电子邮件主题对其进行了修改，以命名附件。

两个问题

我无法正确定义strSubject以使其引用电子邮件主题。
错误包括缺少对象。如果将strSubject设置为对象，则错误为“找不到方法或数据成员”。
我将拥有相同名称的附件，但它们可能是同一天创建的不同版本。
如何在名称中添加数字，以免出现重复的名称？

我在这些（和其他）线程上花费了很多时间：
VBA Code to save an attachment (excel file) from an Outlook email that was inside another email as an attachment
Extract attachments from saved .msg files using VBA
Save attachments to a folder and rename them

我不知道要包含多少代码，所以我只包含了全部内容。

Dim strAttachmentFolder As String

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder()
Dim objShell, objWindowsFolder As Object

'Select a Windows folder
Set objShell = CreateObject("Shell.Application")
Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "")

If Not objWindowsFolder Is Nothing Then
    'Create a new folder for saving extracted attachments
    strAttachmentFolder = "C:\Users\amy\Desktop\Email tests 2-" & Format(Now, "MMDDHHMMSS") & "\"
    MkDir (strAttachmentFolder)
    Call ProcessFolders(objWindowsFolder.self.Path & "\")
    MsgBox "Completed!", vbInformation + vbOKOnly
End If
End Sub  


Sub ProcessFolders(strFolderPath As String)
Dim objFileSystem As Object
Dim objFolder As Object
Dim objFiles As Object
Dim objFile As Object
Dim objItem As Object
Dim i As Long
Dim objSubFolder As Object
Dim strDate As Object
Dim objMsg As Outlook.MailItem 'Object
Dim strSubject As String
Dim objOL As Outlook.Application

Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strFolderPath)
Set objFiles = objFolder.Files
Set strDate = Format(objItem.CreationTime, "yyyy.mm.dd")
Set strSubject = objMsg.Subject

For Each objFile In objFiles
    If objFileSystem.GetExtensionName(objFile) = "msg" Then
        'Open the Outlook emails stored in Windows folder
        Set objItem = Session.OpenSharedItem(objFile.Path)

        If TypeName(objItem) = "MailItem" Then
            If objItem.Attachments.Count > 0 Then
                'Extract attachments
                For i = objItem.Attachments.Count To 1 Step -1
                    objItem.Attachments(i).SaveAsFile strAttachmentFolder & strDate & strSubject & objItem.Attachments(i).FileName
                Next
            End If
        End If
    End If
Next

'Process all subfolders recursively
If objFolder.SubFolders.Count > 0 Then
    For Each objSubFolder In objFolder.SubFolders
        If ((objSubFolder.Attributes And 2) = 0) And ((objSubFolder.Attributes And 4) = 0) Then
            Call ProcessFolders(objSubFolder.Path)
        End If
    Next
End If
End Sub

使用电子邮件主题和版本号重命名已保存的附件

0 个答案: