Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Курилка
Страницы: 1
RSS
Сохранение всех входящих и исходящих писем из Outlook в папку
 
#1
09.02.2021 07:51:42
Добрый день Форумчане!  ;)
Мне необходимо сохранять все входящие и исходящие сообщения в папку в формате ".msg".
На просторах интернета я нашел и слегка поправил код ниже. Но он работает только с входящими сообщениями, не просматривает подпапки и заменяет сообщения с одинаковой темой.
Код
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
Возможно кто-то сталкивался с подобным и может подсказать, как поправить код.

Я понимаю, что форум не про outlook, но надеюсь на поддержку.  :)
Спасибо!
 
 
 
#2
09.02.2021 12:10:20
HELP ME  :cry:  
 
 
 
#3
09.02.2021 13:01:32
Цитата
evgeniygeo написал:
Я понимаю, что форум не про outlook
Так если понимаете, то зачем засоряете основную ветку? Для таких вопросов есть Курилка, и там, даже бывает что и помогают.
Вот горшок пустой, он предмет простой...
 
 
 
#4
09.02.2021 13:16:23
Цитата
PooHkrd написал:
Так если понимаете, то зачем засоряете основную ветку?
я ответил на данный вопрос:
Цитата
evgeniygeo написал:
Возможно кто-то сталкивался с подобным и может подсказать, как поправить код.
Цитата
evgeniygeo написал:
надеюсь на поддержку.  
 
 
 
#5
09.02.2021 13:30:56
надо полазить в объекте xNameSpace,
Цитата
Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
здесь у тебя ссылка на конкретную папку olFolderInbox, скорей всего указывающую на папку Входящие.
залезь в дебаг, глянь остальные объекты, определи остальные папки которые надо.
Ну и далее, перебираешь только необходимые.

А насчет сохранения, тут всё зависит от SaveAs, возможно есть ключ на запрос перезаписи.
 
 
 
#6
09.02.2021 14:11:47
Кросс
 
 
 
#7
09.02.2021 14:54:05
vikttur,
это пункт конечно в ветке: не рекомендуется. Но Вы правы, я не заметил его в правилах. Прошу прощения.
Изменено: evgeniygeo - 10.02.2021 06:01:13
 
 
 
#8
11.02.2021 13:16:25
В итоге у меня получился вот такой код. Единственное, что я не смог решить - это просмотр подпапок. Их приходится указывать вручную, как я это сделал с папкой "Руководитель"
Код
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
Изменено: evgeniygeo - 12.02.2021 07:21:09
 
 
 
Страницы: 1
Наверх