![](/img/trans.png)
[英]Save Excel attachment as .txt - opened with a vba macro from Outlook 2010
[英]Outlook 2010 VBA How to save message including attachment
您好,我正在使用以下代码将消息保存到文件夹中,但是如果消息带有附件,则它不起作用。
我知道如果我手动将消息移动到硬盘驱动器,附件仍在 *.msg 文件中。
我认为这就是我在此特定部分中保存消息的方式
oMail.SaveAs sPath & sName, olMSG
如何更改以下代码以通过 VBA 执行此操作。
Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim sndName As String
Dim enviro As String
enviro = "c:\emails"
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sndName = oMail.Sender
ReplaceCharsForFileName sndName, "-"
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "-hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & "-" & sndName & "-" & sName & ".msg"
sPath = enviro
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
提前致谢
更新自己解决了
我现在已经自己解决了这些问题,您需要小心,因为这取决于收到的电子邮件的创建方式。
如果电子邮件和主题特别是使用 excel 创建的,它将在其中包含制表符分隔符,可以将上述代码关闭。 要解决此问题,请使用以下代码:
Public Sub SaveMessageAsMsg()
Dim oMail As Outlook.MailItem
Dim objItem As Object
Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim SndName As String
Dim enviro As String
enviro = "c:\emails\" 'sets folder to save messgaes to
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
SndName = oMail.SenderName
dtDate = oMail.ReceivedTime
ReplaceCharsForFileName sName, "-"
sName = Right(sName, 100)
'formats the file name as "Sender name - Date - Time - Subject"
sName = SndName & " - " & Format(dtDate, "dd-mm-yy", vbUseSystemDayOfWeek, _
vbUseSystem) & " - " & Format(dtDate, "hhnnss", _
vbUseSystemDayOfWeek, vbUseSystem) & " - " & sName & ".msg"
sPath = enviro
Debug.Print sPath & sName
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
'Replaces the invalid characters you could use RegX with vbscript instead
sName = Replace(sName, "´", "'")
sName = Replace(sName, "`", "'")
sName = Replace(sName, "{", "(")
sName = Replace(sName, "[", "(")
sName = Replace(sName, "]", ")")
sName = Replace(sName, "}", ")")
sName = Replace(sName, " ", " ") 'Replace two spaces with one space
sName = Replace(sName, " ", " ") 'Replace three spaces with one space
sName = Replace(sName, " ", " ") 'Replace four spaces with one space
sName = Replace(sName, " ", " ") 'Replace five spaces with one space
sName = Replace(sName, " ", " ") 'Replace six spaces with one space
'Cut out invalid signs.
sName = Replace(sName, ": ", "_") 'Colan followded by a space
sName = Replace(sName, ":", "_") 'Colan with no space
sName = Replace(sName, "/", "_")
sName = Replace(sName, "\", "_")
sName = Replace(sName, "*", "_")
sName = Replace(sName, "?", "_")
sName = Replace(sName, """", "'")
sName = Replace(sName, "<", "_")
sName = Replace(sName, ">", "_")
sName = Replace(sName, "|", "_")
sName = Replace(sName, "%", "pc")
sName = Replace(sName, vbTab, " ") 'Replaces vbTab as this is sometimes a delimiter if copied from excel
End Sub
您需要使用Attachment 类的SaveAsFile方法将附件保存到指定路径。 例如:
Sub SaveAttachment()
Dim myInspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set myItem = myInspector.CurrentItem
Set myAttachments = myItem.Attachments
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the first attachment in the current item to the Documents folder? If a file with the same name already exists in the destination folder, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
myAttachments.Item(1).SaveAsFile Environ("HOMEPATH") & "\My Documents\" & _
myAttachments.Item(1).DisplayName
End If
Else
MsgBox "The item is of the wrong type."
End If
End If
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.