我需要为Outlook创建一个宏，使用户能够选择某些电子邮件，然后将这些电子邮件中的附件提取到硬盘驱动器上的文件夹中，该文件夹将使用电子邮件的主题和日期自动创建和命名电子邮件使用以下格式接收：（ddmmyyyy-SUBJECT），文件夹内有附件。
我尝试使用C＃进行制作，但是我完成的效率不是很高。
VBA对于我正在尝试做的事情似乎更实用，而我现在拥有的代码几乎可以完全满足我的需要。但是，它将整个电子邮件作为邮件而不是附件保存为我的目录。
Option Explicit
'This macro not required for Rule script
Sub Save_Messages()
Dim olItem As MailItem
Dim fPath As String
fPath = BrowseForFolder(CStr(Environ("USERPROFILE")) & "\desktop\") & Chr(92)
For Each olItem In Application.ActiveExplorer.Selection
If olItem.Class = OlObjectClass.olMail Then
SaveMessage olItem, fPath
DoEvents
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub SaveMessage(olItem As MailItem, fPath As String)
'Sub SaveMessage(olItem As MailItem) 'Alternative for rule script
'Const fPath As String = "C:\Path\" 'Set Path - required for rule script
Dim Fname As String
Dim dtDate As Date
dtDate = olItem.ReceivedTime
Fname = olItem.Subject
Fname = Fname & " - " & "[" & olItem.SenderName + "]"
Fname = Format(dtDate, "yymmddKT", vbUseSystemDayOfWeek, _
vbUseSystem) & " - " & Fname & " - {" & _
Format(dtDate, "hh.mm", _
vbUseSystemDayOfWeek, _
vbUseSystem) & "}"
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), "-")
SaveUnique olItem, fPath, Fname
lbl_Exit:
Exit Sub
End Sub
Private Function SaveUnique(oItem As Object, _
strPath As String, _
strFileName 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"
lbl_Exit:
Exit Function
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
'Following function not required for Rule script
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function
我希望能够单击我选择的电子邮件，然后单击宏，这将依次打开一个弹出目录，我可以选择文件夹的位置并将其保存到带有附件的附件中。命名的文件夹。
答案 0 :(得分：0)
这是因为您正在保存邮件，而不仅仅是附件。将以下行添加到您的DIM部分：
Dim objAttachments As Outlook.Attachments, i as Integer, lngCount as Integer
然后在您的For Each部分中，删除这（2）行sName = sName + ".msg"; msg.SaveAs sName, olMsg并替换为以下内容：
Set objAttachments = msg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
objAttachments.Item(i).SaveAsFile sName & lngCount
Next i
End If
答案 1 :(得分：0)
我确定我们可以做得更好，但是在这里尝试一下.....
Option Explicit
'This macro not required for Rule script
Dim FldrName As String
Sub Save_Messages()
Dim olItem As MailItem
Dim fPath As String
Dim Atmt As Outlook.Attachment
fPath = BrowseForFolder(CStr(Environ("USERPROFILE")) & "\desktop\") & Chr(92)
For Each olItem In Application.ActiveExplorer.selection
If olItem.Class = OlObjectClass.olMail Then
For Each Atmt In olItem.Attachments
DoEvents
SaveMessage olItem, fPath
Atmt.SaveAsFile FldrName & "\" & Atmt.DisplayName
Next
End If
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub SaveMessage(olItem As MailItem, fPath As String)
'Sub SaveMessage(olItem As MailItem) 'Alternative for rule script
'Const fPath As String = "C:\Path\" 'Set Path - required for rule script
Dim Fname As String
Dim dtDate As Date
dtDate = olItem.ReceivedTime
Fname = olItem.Subject
Fname = Fname
Fname = Format(dtDate, "yymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & " - " & Fname
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), "-")
Debug.Print fPath, Fname
FldrName = fPath & Fname
Debug.Print FldrName
CreateDir FldrName
lbl_Exit:
Exit Sub
End Sub
'Following function not required for Rule script
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function
Private Function CreateDir(FldrPath As String)
Dim Elm As Variant
Dim CheckPath As String
CheckPath = ""
For Each Elm In Split(FldrPath, "\")
CheckPath = CheckPath & Elm & "\"
If Len(Dir(CheckPath, vbDirectory)) = 0 Then
MkDir CheckPath
Debug.Print CheckPath & " Folder Created"
End If
Debug.Print CheckPath & " Folder Exist"
Next
End Function