学生通过电子邮件将评估答案发送给我，然后将其放在与评估编号相关的文件夹中。在完成评估时，可能会有多封来自该学生的电子邮件，它们带有不同的附件以供评估。
我的收件箱下有一个名为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/
'https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them
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 Resources\112FebStudetnResults
' 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 NZBat\112
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 Resources\112\
' 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 Resources\112\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
答案 0 :(得分：1)
您的代码确实可以工作了（顺便说一句，它不会以被复制到问题中的形式进行编译）...但是我没有完全调试它，而是采取了清理它直到工作的方法。有很多多余的代码。
下面的代码通过所有作业文件夹/学生文件夹和电子邮件信息读取...，创建作业子目录以及其中的学生目录，并将附件保存在作业/学生目录中。它将使用对已保存附件的引用来更新电子邮件正文。
如果您希望它仅适用于选定的文件夹，则需要对以下代码进行一些调整。
我怀疑目录名称重复的问题可能是由于来自学生电子邮件地址的不兼容字符被放入了学生的目录路径名中...所以我已经包含了一个非常原始的清理功能（我没有这样做）进行过多测试），以希望避免这种情况；它可能需要进行调整。
顺便说一句，我使用早期绑定，因此如果您还没有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