искал возможное решение для чего-то, чего мы пытаемся достичь на работе.
Существует несколько источников, из которых мы получаем конкретные электронные письма, и для нас проще всего их классифицировать по заголовку или даже по почте.исходный адрес электронной почты.
Мы в основном стараемся, чтобы Outlook автоматически сохранял все входящие электронные письма в файл, будь то TXT или PDF в любом случае.Это дает нам доступ к этим файлам независимо от того, есть у нас подключение или нет, и мы можем легко найти файл резервной копии, даже если есть проблема с сетью, электронной почтой или чем-то еще, что работает со сбоями ...
IНапример, я пытался создать макрос из нескольких похожих тем:
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveMailAsFile Item ' call sub
End If
End Sub
Public Sub SaveMailAsFile(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim ItemSubject As String
Dim NewName As String
Dim RevdDate As Date
Dim Path As String
Dim Ext As String
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items.Restrict("[Subject] = 'VVAnalyze Results'")
Path = Environ("USERPROFILE") & "\Desktop\Backup Reports\"
ItemSubject = Item.Subject
RevdDate = Item.ReceivedTime
Ext = "txt"
For i = Items.Count To 1 Step -1
Set Item = Items.Item(i)
DoEvents
If Item.Class = olMail Then
Debug.Print Item.Subject ' Immediate Window
Set SubFolder = Inbox.Folders("Temp") ' <--- Update Fldr Name
ItemSubject = Format(RevdDate, "YYYYMMDD-HHNNSS") _
& " - " & _
Item.Subject & Ext
ItemSubject = FileNameUnique(Path, ItemSubject, Ext)
Item.SaveAs Path & ItemSubject, olTXT
Item.Move SubFolder
End If
Next
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
End Sub
'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FullName) Then
FileExists = True
Else
FileExists = False
End If
Exit Function
End Function
'// If the same file name exist then add (1)
Private Function FileNameUnique(Path As String, _
FileName As String, _
Ext As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(FileName) - (Len(Ext) + 1)
FileName = Left(FileName, lngName)
Do While FileExists(Path & FileName & Chr(46) & Ext) = True
FileName = Left(FileName, lngName) & " (" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = FileName & Chr(46) & Ext
Exit Function
End Function
Это не сработало, или я понятия не имею, как заставить это работать ... хотя это было бы идеальным решением длянас.Поэтому я думал о надстройке Outlook, но сразу застрял на том, как даже заставить это дополнение распознавать, что я пометил определенную почту ... В основном я искал некоторые подсказки или хорошее руководство для n00bs, которые я мог бы использовать длязаставить это работать.
Зачем нам это нужно?Хотя я лично понимаю, что кэш Outlook доступен даже в автономном режиме, некоторые люди на моей работе все еще настаивают на том, чтобы на физическом жестком диске были какие-то резервные копии файлов.
Да, я знаю, что могу вручную выбрать эти файлыи создайте копию простым перетаскиванием ... этого, к сожалению, недостаточно ...
Очень ценю любую помощь от вас, ребята.
Мне известно о существовании, например;https://www.techhit.com/messagesave/screenshots.html
Было бы трудно принять эту идею в моей компании, потому что GDPR бла-бла-бла ...
Будет продолжать исследовать и публиковать мои находки здесь.