Мне удалось создать сценарий Outlook VBA в Excel, который бы сохранял только вложения "непрочитанных" сообщений в определенной подпапке Outlook в папку в моей сети, а затем помечал сообщение как "Чтение".
Я тоже пытаюсь сохранить электронные письма. У меня возникли проблемы при попытке сохранить сообщение Outlook в моей сети. Самым близким, что я смог получить, было добавление кода, выделенного жирным шрифтом ниже. Хотя я не получаю желаемый результат.
Например, вложения сохраняются в папке H:\Testing\XY\, и я хочу сохранить сообщения Outlook в папке H:\Testing\XY\Emails ". Между тем, я просто хочу сохранить электронные письма с именем субъекта и датой получения электронного письма. Когда я запускаю код VBA, электронные письма сохраняются в папке H:\Testing\XY\, а имена файлов - Emails.msg.
Вложения сохраняются так, как мне бы хотелось. Любая помощь для завершения этого будет принята с благодарностью.
Sub SaveEmailAndAttach()
Dim myOlapp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim myMail As Outlook.MailItem
Dim avDate() As String
Dim vDate As String
Dim i As Long
Dim myEmailPath As String
ReDim Preserve avDate(3)
Set myOlapp = CreateObject("Outlook.Application")
Set myNamespace = myOlapp.GetNamespace("MAPI")
Const myAttachPath As String = "H:\Testing\XY\"
**myEmailPath = enviro & "H:\Testing\XY\Emails"**
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders("Auto").Folders("Manual")
For Each myItem In myFolder.Items
If myItem.UnRead = True Then
avDate = Split(CStr(myItem.ReceivedTime), "/")
vDate = avDate(0) & "-" & avDate(1) & "-" & Mid(avDate(2), 1, 4)
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If UCase(Right(myAttachment.Filename, 4)) = "XLSX" Then
i = i + 1
myAttachment.SaveAsFile (myAttachPath & vDate & " " & myAttachment.Filename)
End If
Next
**myItem.SaveAs myEmailPath & " " & vDate & ".msg"**
myItem.UnRead = False
End If
End If
Next
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub