Я отправляю свои письма о перспективах в subfolders. Я хотел бы заархивировать их, сохранив на жестком диске. Я нашел код, который прекрасно работает, но я хотел бы одно изменение, и я не могу понять, как это сделать.
В настоящее время он сохраняет имя сообщения в виде даты и времени, плюс отправителя и темы. Я хотел бы добавить имя subfolder в имя файла при его сохранении.
Мой код указан ниже.
Option Explicit
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 enviro As String
Dim sSender As String
Dim sCategory As String
enviro = CStr(Environ("USERPROFILE"))
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
sSender = oMail.SenderName
sCategory = oMail.Categories
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, _
vbUseSystem) & Format(dtDate, "--hhnn", _
vbUseSystemDayOfWeek, vbUseSystem) & " -- " & sCategory & " -- " & sSender & " -- " & sName & ".msg"
sPath = enviro & "\Documents\Emails\"
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