Сохранение всех входящих и исходящих писем из Outlook в папку

[evgeniygeo]

Добрый день!  
Мне необходимо сохранять все входящие и исходящие сообщения в папку в формате ".msg".
На просторах интернета я нашел и слегка поправил код ниже. Но он работает только с входящими сообщениями, не просматривает подпапки и заменяет сообщения с одинаковой темой.
Возможно кто-то сталкивался с подобным и может подсказать, как поправить код под данную задачку?

Код: (vb)

Private WithEvents InboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub
  
Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMSG
End If
Exit Sub
End Sub

[Дмитрий Щербаков(The_Prist)]

Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
вот здесь задана жестко папка "Входящие" (olFolderInbox).
Добавьте olFolderOutbox:

Код: (vb)

Private WithEvents InboxItems As Outlook.Items
....
Set OutboxItems = xNameSpace.GetDefaultFolder(olFolderOutbox).Items

Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)

[evgeniygeo]

В итоге сделал вот так и работает   Только я не понимаю, как их можно совместить?

Код: (vb)

Private WithEvents OutboxItems As Outlook.Items
Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set OutboxItems = xNameSpace.GetDefaultFolder(olFolderSentMail).Items
End Sub
      
Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If
Exit Sub
End Sub

[evgeniygeo]

У меня получилось их совместить вот так. Осталась только проблема с глубиной. Сейчас он не просматривает подпапки, что очень важно.

Код: (vb)

Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items

Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Set xNameSpace = Outlook.Application.Session
Set OutboxItems = xNameSpace.GetDefaultFolder(olFolderSentMail).Items
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If
Exit Sub
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If
Exit Sub
End Sub

[evgeniygeo]

Пытался поправить по Вашему примеру в статье: https://www.excel-vba.ru/chto-umeet-excel/soxranit-vlozheniya-iz-outlook-v-papku/
Но видимо что-то делаю не так

Код: (vb)

Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Dim oIncomingOut As Object
Dim oIncomingIn As Object
Set xNameSpace = Outlook.Application.Session

Set oIncomingOut = xNameSpace.GetDefaultFolder(5)
Set oIncomingIn = xNameSpace.GetDefaultFolder(6)

Set OutboxItems = oIncomingOut.Items
Set InboxItems = oIncomingIn.Items
End Sub

[Дмитрий Щербаков(The_Prist)]

С подпапками, конечно, более проблемно использовать именно этот код. Может стоит присмотреться к событию Private Sub Application_NewMail()? Оно реагирует на все входящие письма, независимо от того, в какую папку они попали или подпадут в результате срабатывания правил. Это для всех входящих.
А для исходящих, наверное, ItemSend.
Останется лишь проверять тип объекта - чтобы был "MailItem"

[evgeniygeo]

Попробовал сделать так, но не работает(

Код: (vb)

Private Sub Application_NewMail()

On Error Resume Next

'Get a reference to the first item in the inbox
Dim olObject As Object
Set olObject = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetFirst()

'Exit the sub if there is nothing in the inbox. An error will probably be thrown when using the GetFirst method but check anyway
If olObject Is Nothing Then Exit Sub

'Exit the sub if it's not a mail item or appointment item
If Not TypeOf olObject Is Outlook.MailItem And Not TypeOf olObject Is Outlook.AppointmentItem Then Exit Sub

'Set the path to your desktop folder here
sFolder = "C:\Users\s1200134\Documents\MyEmails\"

'Save the email to some destination
olObject.SaveAs sFolder & Format(Now(), "yyyy-mm-dd hh_NN_ss") & ".msg", olMsg

Set olObject = Nothing

Exit Sub
End Sub

[Дмитрий Щербаков(The_Prist)]

А что Вы этим кодом сделать-то хотели? Вы же получаете первое письмо из папки входящие.
Посмотрите пример с сайта Microsoft: https://docs.microsoft.com/en-us/office/vba/api/outlook.application.newmail

[evgeniygeo]

У меня отлично работает вот этот код https://www.tachytelic.net/2017/10/how-to-run-a-vba-macro-when-new-mail-is-received-in-outlook/
Но я не могу применить его для себя

Код: (vb)

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.NameSpace
  
  Set outlookApp = Outlook.Application
  Set objectNS = outlookApp.GetNamespace("MAPI")
  Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
    MessageInfo = "" & _
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
        "Sent : " & Item.SentOn & vbCrLf & _
        "Received : " & Item.ReceivedTime & vbCrLf & _
        "Subject : " & Item.Subject & vbCrLf & _
        "Size : " & Item.Size & vbCrLf & _
        "Message Body : " & vbCrLf & Item.Body
    Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

[Дмитрий Щербаков(The_Prist)]

Но я не могу применить его для себя

и не сможете, пока не перечислите ВСЕ папки. При этом все вложенные - тоже. Т.е. нужно будет столько переменных, сколько папок надо отследить. Поэтому я и написал про событие Application_NewMail. Но вообще, что по мне, то проще вообще создать правило на все входящие и исходящие письма. В правиле указать - выполнение скрипта - Items_DoSomthing. А в скрипте прописать все, что надо.

Код: (vb)

Sub Items_DoSomthing(Item As MailItem)  
On Error GoTo ErrorHandler  
Dim Msg As Outlook.MailItem  
Dim MessageInfo  
Dim Result  
If TypeName(Item) = "MailItem" Then  
    MessageInfo = "" & _  
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _  
        "Sent : " & Item.SentOn & vbCrLf & _  
        "Received : " & Item.ReceivedTime & vbCrLf & _  
        "Subject : " & Item.Subject & vbCrLf & _  
        "Size : " & Item.Size & vbCrLf & _  
        "Message Body : " & vbCrLf & Item.Body  
    Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")  
End If  
ExitNewItem:  
    Exit Sub  
ErrorHandler:  
    MsgBox Err.Number & " - " & Err.Description  
    Resume ExitNewItem  
End Sub

[evgeniygeo]

Пытаюсь использовать Ваш код, но почему-то не срабатывает или я опять все делаю не так(

Код: (vb)

Private Sub Application_NewMail()
Call Items_DoSomthing
End Sub

Sub Items_DoSomthing(Item As MailItem)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
    MessageInfo = "" & _
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
        "Sent : " & Item.SentOn & vbCrLf & _
        "Received : " & Item.ReceivedTime & vbCrLf & _
        "Subject : " & Item.Subject & vbCrLf & _
        "Size : " & Item.Size & vbCrLf & _
        "Message Body : " & vbCrLf & Item.Body
    Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub

[Дмитрий Щербаков(The_Prist)]

почему-то не срабатывает

а как использовать-то пытаетесь?
Вы правило создали? Указали в правиле использовать скрипт при срабатывании правила? Отсюда вижу, что нет. Application_NewMail в этом случае уже не нужно. От слова совсем.
Итак. Создаете в Outlook код, который я привел выше. Далее стандартно создаете правило, жмете кнопку "Дополнительно". Выбираете по какому признаку отбирать письма для правила(если надо все - ничего не отмечаете). Далее указываете что делать при наступлении выполнения правила. Ищете там пункт "Запустить скрипт". Если этого пункта нет - то идете в реестр в ветку "HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Outlook\Security" и ищете там параметр "EnableUnsafeClientMailRules". Если его нет - создаете(тип DWORD). Устанавливаете значение 1. Закрываете реестр. Перезапускаете Outlook. Возможность назначения скрипта должна появиться. Отмечаете галочкой и ниже в поле надо будет нажать на "скрипт" и выбрать именно ту процедуру.

[evgeniygeo]

Дмитрий,
большое спасибо за потраченное Вами время. К сожалению доступа к реестру у меня нет и вряд ли мне его дадут.

Благодаря Вам, я собрал код, который отлично сохраняет все входящие и отправленные письма в папку и записывает в текстовый документ информацию о сохраненном письме.
Единственное, что я так и не смог решить это просмотр подпапок, поэтому указал одну из подпапок "Руководитель" отдельно

Код: (vb)

Private WithEvents OutboxItems As Outlook.Items
Private WithEvents InboxItems As Outlook.Items
Private WithEvents InboxItems2 As Outlook.Items

Sub Application_Startup()
Dim xNameSpace As Outlook.NameSpace
Dim oIncomingOut As Object
Dim oIncomingIn As Object
Dim oIncomingIn2 As Object
Set xNameSpace = Outlook.Application.Session

Set oIncomingOut = xNameSpace.GetDefaultFolder(5)
Set oIncomingIn = xNameSpace.GetDefaultFolder(6)
Set oIncomingIn2 = xNameSpace.GetDefaultFolder(6).Folders("Руководитель")

Set OutboxItems = oIncomingOut.Items
Set InboxItems = oIncomingIn.Items
Set InboxItems2 = oIncomingIn2.Items
End Sub

Private Sub OutboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Исх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
   x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j

    Dim s As String
    Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
        s = xFilePath & "\" & xFileName & ".msg" & vbTab _
        & xMailItem.SentOn & vbTab _
        & xMailItem.ReceivedTime & vbTab _
        & xMailItem.Sender.Name & vbTab _
        & xMailItem.To & vbTab _
        & xMailItem.CC & vbTab _
        & xMailItem.Subject & vbTab _
        & Replace(x, "image001.png; image002.jpg; ", "") & vbTab _
        & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
        
    ff = FreeFile
    'Открываем текстовый файл
    'если файла нет - он будет создан
    Open xFilePath & "\Архив.txt" For Append As #ff
    'записываем значение строки в файл
    Print #ff, s
    Close #ff ' Закрываем файл
    
Exit Sub
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Вх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
   x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j

    Dim s As String
    Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
        s = xFilePath & "\" & xFileName & ".msg" & vbTab _
        & xMailItem.SentOn & vbTab _
        & xMailItem.ReceivedTime & vbTab _
        & xMailItem.Sender.Name & vbTab _
        & xMailItem.To & vbTab _
        & xMailItem.CC & vbTab _
        & xMailItem.Subject & vbTab _
        & Replace(x, "image001.png; image002.jpg; ", "") & vbTab _
        & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
        
    ff = FreeFile
    'Открываем текстовый файл
    'если файла нет - он будет создан
    Open xFilePath & "\Архив.txt" For Append As #ff
    'записываем значение строки в файл
    Print #ff, s
    Close #ff ' Закрываем файл
    
Exit Sub
End Sub

Private Sub InboxItems2_ItemAdd(ByVal objItem As Object)
Dim FSO
Dim xMailItem As Outlook.MailItem
Dim xFilePath As String
Dim xRegEx
Dim xFileName As String
On Error Resume Next
xFilePath = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePath = xFilePath & "\MyEmails"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePath) = False Then
FSO.CreateFolder (xFilePath)
End If
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
If objItem.Class = olMail Then
Set xMailItem = objItem
xFileName = "Вх " & Format(Now(), "yyyy-mm-dd hh_NN_ss") 'xRegEx.Replace(xMailItem.Subject, "") 'xFileName
xMailItem.SaveAs xFilePath & "\" & xFileName & ".msg", olMsg
End If

For j = 1 To xMailItem.Attachments.Count
   x = x & xMailItem.Attachments.Item(j).DisplayName & "; " ' or .Filename
Next j

    Dim s As String
    Dim ff
'Путь; Отправлено; Получено; От кого; Кому; Копия; Тема; Вложение; Сообщение
        s = xFilePath & "\" & xFileName & ".msg" & vbTab _
        & xMailItem.SentOn & vbTab _
        & xMailItem.ReceivedTime & vbTab _
        & xMailItem.Sender.Name & vbTab _
        & xMailItem.To & vbTab _
        & xMailItem.CC & vbTab _
        & xMailItem.Subject & vbTab _
        & Replace(x, "image001.png; image002.jpg; ", "") & vbTab _
        & Replace(xMailItem.Body, Chr(13) + Chr(10), " ")
        
    ff = FreeFile
    'Открываем текстовый файл
    'если файла нет - он будет создан
    Open xFilePath & "\Архив.txt" For Append As #ff
    'записываем значение строки в файл
    Print #ff, s
    Close #ff ' Закрываем файл
    
Exit Sub
End Sub