根据发件人姓名为附件创建文件夹
Create folders for attachments based on sender name
学生通过电子邮件发送评估答案，我将它们放在与评估编号相关的文件夹中。一个学生在完成评估时可能会收到多封电子邮件，其中包含不同的附件。
我的收件箱下有一个名为 AllNZBAT 的主文件夹。我有评估编号的子文件夹。 112、123、2785 等用于学生的电子邮件。
我需要从多封电子邮件中提取学生的附件，并将它们放在一个文件夹中，该文件夹中的学生姓名（发件人）位于该评估的文件夹中。
所以文件夹“John Smith”保存了他所有的评估 123 的附件。
我正在尝试编写一个执行此操作的宏。它创建文件夹树和带有学生姓名的文件夹。我无法在包含发件人姓名的文件夹中获取附件。
有时我会得到两个同一个学生名字的文件夹，但其中一个文件夹的名字后面也会有（Unicode 编码冲突）。
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim myNewFolder As Outlook.Folder
Dim currentFolder As Outlook.Folder
'https://www.codeproject.com/Questions/5258321/Outlook-VBA-automatically-create-a-folder-based-on
'https://vbatutorialcode.com/save-all-attachments-from-outlook-into-folder-vba/
'
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("All NZBat") 'set the start folder - replace it with selection
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
Dim FoldersArray As Variant
Dim LastFolder As Integer
Dim strParentFolderName As String
'use to create the folders on the drive
Dim fs As Object 'Using late binding to avoid having to include a reference to Microsoft Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
'C:\Dropbox\NZBAT Resources2FebStudetnResults
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
'get all the folders under the All NZBat
For Each Folder In olFolder.Folders
' Debug.Print Folder.FolderPath '\*****@*****.ac.nz\Inbox\All NZBat2
Set currentFolder = Folder
FoldersArray = Split(Folder.FolderPath, "\")
LastFolder = UBound(FoldersArray)
'Debug.Print FoldersArray(LastFolder) '112
'get the last folder in the path string = 112 so we can make a new folder with its name
strParentFolderName = FoldersArray(LastFolder)
'Next
'need to get all the emails in the folder
' Set the Attachment folder with the name of the sender.
strFolderpath = "C:\Dropbox\EmailedAssessments\" & strParentFolderName & "\" ' & objMsg.SenderName & " \ "
'Debug.Print strFolderpath 'C:\Dropbox\NZBAT Resources2\
' strFolderpath = Replace(strFolderpath, " ", "_")
'make the folder
If Not fs.folderexists(strFolderpath) Then
fs.createfolder (strFolderpath)
End If
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
'Set currentFolder = 'Application.ActiveExplorer.currentFolder
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In currentFolder.Items 'objSelection
'Debug.Print objMsg.Subject
strFolderpathFull = strFolderpath & objMsg.SenderName & " \ "
' strFolderpathFull = Replace(strFolderpathFull, " ", "_")
'Debug.Print strFolderpathFull 'C:\Dropbox\NZBAT Resources2\Kathryn Tonks \
' Dim fs As Object 'Using late binding to avoid having to include a reference to Microsoft Scripting Runtime
' Set fs = CreateObject("Scripting.FileSystemObject")
'make the subfolder
If Not fs.folderexists(strFolderpathFull) Then
fs.createfolder (strFolderpathFull)
End If
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.& StudentFolder
strFile = strFolderpathFull & strFile
' strFile = Replace(strFile, "_\_", "\")
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Debug.Print strFile & " Saved attachment"
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
g.Save
End If
Next
Next
End Sub
你的代码真的很接近工作（顺便说一句，它不会以它被复制到问题中的形式编译）......但是我没有完全调试它，而是采取了清理它直到它工作的方法;有很多多余的代码。
下面的代码读取 all assignment folders/student 文件夹和电子邮件...并创建作业子目录，以及其中的学生目录，并保存assignment/student 目录中的附件。它使用对已保存附件的引用更新电子邮件正文。
如果您希望它仅适用于选定的文件夹，您需要稍微调整以下代码。
我怀疑重复目录名称的问题可能是由于将学生电子邮件地址中的不兼容字符放入学生的目录路径名称中...所以我包含了一个非常原始的清理功能（我没有测试太多）希望避免这种情况；它可能需要调整。
顺便说一句，我使用早期绑定，因此如果您还没有 MS 脚本运行时，则需要添加对它的引用。
Option Explicit
Public Sub SaveAttachments()
Const ParentDirectory = "C:\Dropbox\EmailedAssessments\"
Dim fs As New FileSystemObject ' File system object
Dim MAPINamspace As Outlook.NameSpace ' MAPI namespace
Dim InboxFolder As folder ' Inbox
Dim ParentFolder As folder ' Parent folder ... e.g. "ALL NZBAT"
Dim AssignmentSubFolder As folder ' Assignment folders in Parent Folder
Dim OutlookMessage As MailItem ' Outlook message
Dim AssignmentDirectory As String ' Assignment Directory
Dim StudentDirectory As String ' Student Directory (within Assignment Directory)
Dim AttachmentPathFileName As String ' Attachment Path and File Name
Dim DeletedAttachments As String ' A record of all deleted attachments to append to Outlook message
Dim OutlookAttachment As Attachment ' Outlook attachment
Set MAPINamspace = Outlook.Application.GetNamespace("MAPI")
Set InboxFolder = MAPINamspace.GetDefaultFolder(olFolderInbox)
Set ParentFolder = InboxFolder.Folders("ALL NZBAT")
' Get all the Outlook subfolders in the Parent Folder "ALL NZBAT"
For Each AssignmentSubFolder In ParentFolder.Folders
' Setup the directory where each assignment's data will be saved
AssignmentDirectory = ParentDirectory & AssignmentSubFolder.Name & "\"
If Not fs.folderexists(AssignmentDirectory) Then
fs.createfolder (AssignmentDirectory)
End If
' Check each selected item for attachments.
For Each OutlookMessage In AssignmentSubFolder.Items
' Setup the directory where each student's attachments will be saved, cleaning (in a primitive way) the SenderName
StudentDirectory = AssignmentDirectory & CleanName(OutlookMessage.SenderName) & "\"
If Not fs.folderexists(StudentDirectory) Then
fs.createfolder (StudentDirectory)
End If
' Save all the attachments from the message
DeletedAttachments = ""
For Each OutlookAttachment In OutlookMessage.Attachments
' Save the attachment
AttachmentPathFileName = StudentDirectory & OutlookAttachment.FileName
OutlookAttachment.SaveAsFile AttachmentPathFileName
' Keep a record of the all the saved attachments.
If OutlookMessage.BodyFormat <> olFormatHTML Then
DeletedAttachments = DeletedAttachments & vbCrLf & "<file://" & AttachmentPathFileName & ">"
Else
DeletedAttachments = DeletedAttachments & "<br>" & "<a href='file://" & AttachmentPathFileName & "'>" & AttachmentPathFileName & "</a>"
End If
Next
' Append a record of all of the saved attachments to the start of the outlook message
If DeletedAttachments <> "" Then
If OutlookMessage.BodyFormat <> olFormatHTML Then
OutlookMessage.Body = vbCrLf & "The file(s) were saved to " & DeletedAttachments & vbCrLf & OutlookMessage.Body
Else
OutlookMessage.HTMLBody = "<p>" & "The file(s) were saved to " & DeletedAttachments & "</p>" & OutlookMessage.HTMLBody
End If
OutlookMessage.Save
End If
Next
Next
End Sub
Public Function CleanName(InputName As String) As String
Dim Counter As Long
Dim WorkChar As String
' A primitive file name cleaner
For Counter = 1 To Len(InputName)
WorkChar = Mid(InputName, Counter, 1)
If Asc(WorkChar) <= 31 Or InStr(1, "<>:""/|?*", WorkChar) > 0 Then
CleanName = CleanName & "_"
Else
CleanName = CleanName & WorkChar
End If
Next
End Function
学生通过电子邮件发送评估答案，我将它们放在与评估编号相关的文件夹中。一个学生在完成评估时可能会收到多封电子邮件，其中包含不同的附件。
我的收件箱下有一个名为 AllNZBAT 的主文件夹。我有评估编号的子文件夹。 112、123、2785 等用于学生的电子邮件。
我需要从多封电子邮件中提取学生的附件，并将它们放在一个文件夹中，该文件夹中的学生姓名（发件人）位于该评估的文件夹中。
所以文件夹“John Smith”保存了他所有的评估 123 的附件。
我正在尝试编写一个执行此操作的宏。它创建文件夹树和带有学生姓名的文件夹。我无法在包含发件人姓名的文件夹中获取附件。
有时我会得到两个同一个学生名字的文件夹，但其中一个文件夹的名字后面也会有（Unicode 编码冲突）。
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim myNewFolder As Outlook.Folder
Dim currentFolder As Outlook.Folder
'https://www.codeproject.com/Questions/5258321/Outlook-VBA-automatically-create-a-folder-based-on
'https://vbatutorialcode.com/save-all-attachments-from-outlook-into-folder-vba/
'
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("All NZBat") 'set the start folder - replace it with selection
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
Dim FoldersArray As Variant
Dim LastFolder As Integer
Dim strParentFolderName As String
'use to create the folders on the drive
Dim fs As Object 'Using late binding to avoid having to include a reference to Microsoft Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
'C:\Dropbox\NZBAT Resources2FebStudetnResults
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
'get all the folders under the All NZBat
For Each Folder In olFolder.Folders
' Debug.Print Folder.FolderPath '\*****@*****.ac.nz\Inbox\All NZBat2
Set currentFolder = Folder
FoldersArray = Split(Folder.FolderPath, "\")
LastFolder = UBound(FoldersArray)
'Debug.Print FoldersArray(LastFolder) '112
'get the last folder in the path string = 112 so we can make a new folder with its name
strParentFolderName = FoldersArray(LastFolder)
'Next
'need to get all the emails in the folder
' Set the Attachment folder with the name of the sender.
strFolderpath = "C:\Dropbox\EmailedAssessments\" & strParentFolderName & "\" ' & objMsg.SenderName & " \ "
'Debug.Print strFolderpath 'C:\Dropbox\NZBAT Resources2\
' strFolderpath = Replace(strFolderpath, " ", "_")
'make the folder
If Not fs.folderexists(strFolderpath) Then
fs.createfolder (strFolderpath)
End If
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
'Set currentFolder = 'Application.ActiveExplorer.currentFolder
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In currentFolder.Items 'objSelection
'Debug.Print objMsg.Subject
strFolderpathFull = strFolderpath & objMsg.SenderName & " \ "
' strFolderpathFull = Replace(strFolderpathFull, " ", "_")
'Debug.Print strFolderpathFull 'C:\Dropbox\NZBAT Resources2\Kathryn Tonks \
' Dim fs As Object 'Using late binding to avoid having to include a reference to Microsoft Scripting Runtime
' Set fs = CreateObject("Scripting.FileSystemObject")
'make the subfolder
If Not fs.folderexists(strFolderpathFull) Then
fs.createfolder (strFolderpathFull)
End If
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.& StudentFolder
strFile = strFolderpathFull & strFile
' strFile = Replace(strFile, "_\_", "\")
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Debug.Print strFile & " Saved attachment"
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
g.Save
End If
Next
Next
End Sub
你的代码真的很接近工作（顺便说一句，它不会以它被复制到问题中的形式编译）......但是我没有完全调试它，而是采取了清理它直到它工作的方法;有很多多余的代码。
下面的代码读取 all assignment folders/student 文件夹和电子邮件...并创建作业子目录，以及其中的学生目录，并保存assignment/student 目录中的附件。它使用对已保存附件的引用更新电子邮件正文。
如果您希望它仅适用于选定的文件夹，您需要稍微调整以下代码。
我怀疑重复目录名称的问题可能是由于将学生电子邮件地址中的不兼容字符放入学生的目录路径名称中...所以我包含了一个非常原始的清理功能（我没有测试太多）希望避免这种情况；它可能需要调整。
顺便说一句，我使用早期绑定，因此如果您还没有 MS 脚本运行时，则需要添加对它的引用。
Option Explicit
Public Sub SaveAttachments()
Const ParentDirectory = "C:\Dropbox\EmailedAssessments\"
Dim fs As New FileSystemObject ' File system object
Dim MAPINamspace As Outlook.NameSpace ' MAPI namespace
Dim InboxFolder As folder ' Inbox
Dim ParentFolder As folder ' Parent folder ... e.g. "ALL NZBAT"
Dim AssignmentSubFolder As folder ' Assignment folders in Parent Folder
Dim OutlookMessage As MailItem ' Outlook message
Dim AssignmentDirectory As String ' Assignment Directory
Dim StudentDirectory As String ' Student Directory (within Assignment Directory)
Dim AttachmentPathFileName As String ' Attachment Path and File Name
Dim DeletedAttachments As String ' A record of all deleted attachments to append to Outlook message
Dim OutlookAttachment As Attachment ' Outlook attachment
Set MAPINamspace = Outlook.Application.GetNamespace("MAPI")
Set InboxFolder = MAPINamspace.GetDefaultFolder(olFolderInbox)
Set ParentFolder = InboxFolder.Folders("ALL NZBAT")
' Get all the Outlook subfolders in the Parent Folder "ALL NZBAT"
For Each AssignmentSubFolder In ParentFolder.Folders
' Setup the directory where each assignment's data will be saved
AssignmentDirectory = ParentDirectory & AssignmentSubFolder.Name & "\"
If Not fs.folderexists(AssignmentDirectory) Then
fs.createfolder (AssignmentDirectory)
End If
' Check each selected item for attachments.
For Each OutlookMessage In AssignmentSubFolder.Items
' Setup the directory where each student's attachments will be saved, cleaning (in a primitive way) the SenderName
StudentDirectory = AssignmentDirectory & CleanName(OutlookMessage.SenderName) & "\"
If Not fs.folderexists(StudentDirectory) Then
fs.createfolder (StudentDirectory)
End If
' Save all the attachments from the message
DeletedAttachments = ""
For Each OutlookAttachment In OutlookMessage.Attachments
' Save the attachment
AttachmentPathFileName = StudentDirectory & OutlookAttachment.FileName
OutlookAttachment.SaveAsFile AttachmentPathFileName
' Keep a record of the all the saved attachments.
If OutlookMessage.BodyFormat <> olFormatHTML Then
DeletedAttachments = DeletedAttachments & vbCrLf & "<file://" & AttachmentPathFileName & ">"
Else
DeletedAttachments = DeletedAttachments & "<br>" & "<a href='file://" & AttachmentPathFileName & "'>" & AttachmentPathFileName & "</a>"
End If
Next
' Append a record of all of the saved attachments to the start of the outlook message
If DeletedAttachments <> "" Then
If OutlookMessage.BodyFormat <> olFormatHTML Then
OutlookMessage.Body = vbCrLf & "The file(s) were saved to " & DeletedAttachments & vbCrLf & OutlookMessage.Body
Else
OutlookMessage.HTMLBody = "<p>" & "The file(s) were saved to " & DeletedAttachments & "</p>" & OutlookMessage.HTMLBody
End If
OutlookMessage.Save
End If
Next
Next
End Sub
Public Function CleanName(InputName As String) As String
Dim Counter As Long
Dim WorkChar As String
' A primitive file name cleaner
For Counter = 1 To Len(InputName)
WorkChar = Mid(InputName, Counter, 1)
If Asc(WorkChar) <= 31 Or InStr(1, "<>:""/|?*", WorkChar) > 0 Then
CleanName = CleanName & "_"
Else
CleanName = CleanName & WorkChar
End If
Next
End Function