Сохранить электронные письма на основе ключевых слов в тексте письма - PullRequest
Новая
       35

Сохранить электронные письма на основе ключевых слов в тексте письма

0 голосов
/ 07 декабря 2018

Я хочу, чтобы мои электронные письма сохранялись в разных папках на моем жестком диске в зависимости от их содержания.Это означает, что некоторые электронные письма должны быть сохранены в двух или более папках.У меня есть сценарий VBA, основанный на битах, которые я нашел в Интернете.

Назначенные папки жесткого диска создаются, как они должны, и файлы сохраняются с правильными именами файлов, но все электронные письма сохраняются во всех папках.

Если в теле письма присутствует только одно ключевое слово из одной категории.Похоже, что скрипт каким-то образом «запоминает» ранее найденные ключевые слова, даже в следующих инструкциях If-Then, в результате чего электронное письмо сохраняется во всех папках, а не только в правильных.

ОБНОВЛЕНИЕ: Я редактировалкод, основанный на ваших комментариях, чтобы выглядеть как код ниже.Теперь он продолжает выдавать ошибку 450: Неверное количество аргументов.Я не очень опытный в написании кода, и поэтому понятия не имею, как это исправить.Есть мысли? 

Private WithEvents InboxItems As Outlook.Items
Option Explicit

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)

'Define variables
Dim FSO
Dim xFilePath As String
Dim xFilePathAgro As String
Dim xFilePathGras As String
Dim xFilePathIndustrie As String
Dim xFilePathActief As String
Dim xFilePathOppTech As String
Dim xMailItem As Outlook.MailItem
Dim xRegEx
Dim xFileName As String


'Create directories if not existing
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

xFilePathAgro = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePathAgro = xFilePath & "\WBSO 13-01A Agro-reststromen"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePathAgro) = False Then
FSO.CreateFolder (xFilePathAgro)
End If

xFilePathGras = CreateObject("WScript.Shell").SpecialFolders(16)
xFilePathGras = xFilePath & "\WBSO 13-01B Grassen"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(xFilePathGras) = False Then
FSO.CreateFolder (xFilePathGras)
End If


'Change filenames of emails to save
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?" 'Is vereist om de onderwerptitel op te nemen in bestandsnaam

If objItem.Class = olMail Then
Set xMailItem = objItem

xFileName = xRegEx.Replace(xMailItem.Subject, "")
xFileName = xRegEx.Replace(xMailItem.Subject, ":", "")
xFileName = xRegEx.Replace(xMailItem.Subject, "/", "_")
xFileName = xRegEx.Replace(xMailItem.Subject, "\", "")
xFileName = xRegEx.Replace(xMailItem.Subject, "<", "")
xFileName = xRegEx.Replace(xMailItem.Subject, ">", "")
xFileName = xRegEx.Replace(xMailItem.Subject, ";", "")
xFileName = Format(xMailItem.ReceivedTime, "YYYYMMDD hhmm") & " " & xFileName


'saving emails that contain the searchwords in the right folders
If InStr(1, xMailItem.Body, "Agro", vbTextCompare) > 0 Then
MsgBox "Opgeslagen in Agro"
'xMailItem.SaveAs xFilePathAgro & "\" & xFileName & ".msg"
End If

If InStr(1, xMailItem.Body, "Gras", vbTextCompare) > 0 Then
MsgBox "opgeslagen in Gras"
'xMailItem.SaveAs xFilePathGras & "\" & xFileName & ".msg"
End If

End If
End Sub
...