VBA outlook macro (Przenoszenie wiadomości na podstawie filtra) Exchange Cache OST

Question

Witam

Jestem początkujący jeśli chodzi o VBA makra w outlooku.

Napisałem stosunkowo prosty kod do segregowania poczty w office 365.

Prośba o sprawdzenie czy kod jest wystarczająco zoptymalizowany i czy nie będzie powodował problemów.

Scenariusz:

Mamy Mantis Bug Trakcer który służy za platforme obsługi projektów i wysyła różne maile i powiadomienia na maila.

Chodzi mi o segregowania bieżących oraz istniejących nieodczytanych wiadomości.

filtry w pliku .ini

[słowa_kluczowe]

#instalacje#

#elektrycy#

#wnetrza#

#wszyscy#

#architekt#

obecnie jest obserwowane przez użytkownika Tomasz Bartosz

[wykluczenia]

email_bug_tracker

Option Explicit

Private WithEvents inboxItems As Outlook.ItemsPrivate keywords As VariantPrivate exclusions As Variant ' WykluczeniaPrivate outlookNamespace As Outlook.NameSpacePrivate moveFolder As Outlook.MAPIFolderPrivate trashFolder As Outlook.MAPIFolderPrivate inbox As Outlook.MAPIFolder' ==========[1. INICJALIZACJA APLIKACJI]==========Private Sub Application_Startup()On Error GoTo ErrorHandlerSet outlookNamespace = Application.GetNamespace("MAPI")LoadKeywordsSet inbox = outlookNamespace.GetDefaultFolder(olFolderInbox)Set moveFolder = CreateFolderIfNotExists("kontrakty_POP")Set trashFolder = CreateFolderIfNotExists("smietnik_POP")InitializeInboxExit SubErrorHandler:MsgBox "Wystąpił błąd podczas uruchamiania skryptu: " & Err.Description & " (Kod: " & Err.Number & ")", vbCriticalSet outlookNamespace = NothingSet moveFolder = NothingSet trashFolder = NothingSet inbox = NothingEndEnd Sub' ==========[2. OBSŁUGA NOWYCH MAILI]==========Private Sub inboxItems_ItemAdd(ByVal item As Object)On Error GoTo ErrorHandlerIf TypeOf item Is Outlook.MailItem ThenCall ProcessMail(item)End IfExit SubErrorHandler:MsgBox "Wystąpił błąd podczas przetwarzania nowej wiadomości: " & Err.Description & " (Kod: " & Err.Number & ")", vbCriticalEndEnd Sub' ==========[3. PRZETWARZANIE MAILI]==========Private Sub InitializeInbox()On Error GoTo ErrorHandlerDim filter As StringDim i As LongDim item As Objectfilter = "[Unread] = True AND [SenderName] = 'Platforma Obsługi Projektu'"Set inboxItems = inbox.Items.Restrict(filter)i = 0For Each item In inboxItemsIf TypeOf item Is Outlook.MailItem ThenCall ProcessMail(item)i = i + 1If i Mod 25 = 0 Then ' Co 25 mailiDim waitUntil As DatewaitUntil = Now + TimeValue("00:00:25")Do While Now < waitUntilDoEventsLoopEnd IfEnd IfNext itemExit SubErrorHandler:Set inbox = NothingErr.Raise Err.NumberEnd SubPrivate Sub ProcessMail(mail As Outlook.MailItem)On Error GoTo ErrorHandlerIf MatchPatternOrKeywordsInMail(keywords, mail) Thenmail.Move moveFolderElsemail.Move trashFolderEnd IfExit SubErrorHandler:Exit SubEnd SubPrivate Function CreateFolderIfNotExists(folderName As String) As Outlook.MAPIFolderOn Error GoTo ErrorHandlerDim folder As Outlook.MAPIFolder ' Lokalna zmienna zamiast nadpisywania moveFolderOn Error Resume NextSet folder = inbox.Folders(folderName)On Error GoTo ErrorHandlerIf folder Is Nothing ThenSet folder = inbox.Folders.Add(folderName)End IfSet CreateFolderIfNotExists = folderExit FunctionErrorHandler:Set CreateFolderIfNotExists = NothingErr.Raise Err.NumberEnd Function' ==========[4. Funkcje pomocnicze]==========Private Sub LoadKeywords()On Error GoTo ErrorHandlerDim filePath As StringDim scriptPath As StringscriptPath = GetScriptFolderPath()filePath = scriptPath & "\imie.ini"keywords = ReadKeywordsFromIni(filePath)If UBound(keywords) < 0 Then Err.Raise vbObjectError + 1003, , "Brak słów kluczowych w pliku INI."If UBound(exclusions) < 0 Then ReDim exclusions(-1 To -1) ' Pusta tablica, jeśli brak wykluczeńExit SubErrorHandler:MsgBox "Błąd wczytywania słów kluczowych: " & Err.Description, vbCriticalEnd SubFunction GetScriptFolderPath() As String' Zwraca stałą ścieżkę do folderu C:\skryptGetScriptFolderPath = "C:\skrypt"End FunctionPrivate Function ReadKeywordsFromIni(filePath As String)On Error GoTo ErrorHandlerDim stream As Object, lines() As StringDim keywordsArray() As String, exclusionsArray() As StringDim line As Variant, countKeywords As Integer, countExclusions As IntegerDim isInKeywordsSection As Boolean, isInExclusionsSection As Boolean' Otwieramy plikSet stream = CreateObject("ADODB.Stream")stream.Charset = "utf-8"stream.Openstream.LoadFromFile filePathlines = Split(stream.ReadText(-1), vbCrLf)stream.Close: Set stream = Nothing' InicjalizacjacountKeywords = 0countExclusions = 0isInKeywordsSection = FalseisInExclusionsSection = False' Przetwarzanie liniiFor Each line In linesline = Trim(line)If line = "[słowa_kluczowe]" ThenisInKeywordsSection = TrueisInExclusionsSection = FalseGoTo NextLineElseIf line = "[wykluczenia]" ThenisInKeywordsSection = FalseisInExclusionsSection = TrueGoTo NextLineElseIf line <> "" And Not Left(line, 1) = "[" ThenIf isInKeywordsSection ThenReDim Preserve keywordsArray(countKeywords)keywordsArray(countKeywords) = linecountKeywords = countKeywords + 1ElseIf isInExclusionsSection ThenReDim Preserve exclusionsArray(countExclusions)exclusionsArray(countExclusions) = linecountExclusions = countExclusions + 1End IfEnd IfNextLine:Next line' Ustawienie domyślnych wartości, jeśli sekcje pusteIf countKeywords = 0 Then ReDim keywordsArray(-1 To -1)If countExclusions = 0 Then ReDim exclusionsArray(-1 To -1)keywords = keywordsArrayexclusions = exclusionsArrayExit SubErrorHandler:On Error Resume NextSet stream = NothingReDim keywords(-1 To -1)ReDim exclusions(-1 To -1)Err.Raise Err.NumberEnd SubPrivate Function MatchPatternOrKeywordsInMail(keywords As Variant, mail As Outlook.MailItem) As BooleanOn Error GoTo ErrorHandlerDim regEx As ObjectDim keyword As VariantDim mailBody As StringDim exclusion As VariantmailBody = LCase(mail.Body)For Each exclusion In exclusionsIf InStr(1, mailBody, LCase(exclusion)) > 0 ThenMatchPatternOrKeywordsInMail = FalseExit FunctionEnd IfNext exclusionFor Each keyword In keywordsIf InStr(1, mailBody, LCase(keyword)) > 0 ThenIf regEx Is Nothing Then Set regEx = CreateObject("VBScript.RegExp")regEx.IgnoreCase = TrueregEx.Global = FalseregEx.pattern = keywordIf regEx.Test(mailBody) ThenMatchPatternOrKeywordsInMail = TrueExit FunctionEnd IfEnd IfNext keywordMatchPatternOrKeywordsInMail = FalseExit FunctionErrorHandler:MatchPatternOrKeywordsInMail = FalseSet regEx = NothingErr.Raise Err.NumberEnd FunctionPrivate Sub Application_Quit()Set outlookNamespace = NothingSet inboxItems = NothingSet moveFolder = NothingSet trashFolder = NothingSet inbox = NothingEnd Sub

Answer 1

Kurka od lat nikt nie zadał pytanie o kod. Super.

Tomek ale nie obraź się, bo coś mi tu źle pachnie.... i coś mi się wydaje że nie rozumiesz tego kodu a że nie działa to szukasz pomocy. Wytłumacz się z tego proszę, tylko bez kręcenia.

Komentarze podobne do AI, nazwy funkcji też, zaawansowane jak na początkującego odwołania też, ale jednak pewne ruchy całkiem nielogiczne jak u człowieka, który coś strasznie popaprał:

Np w funkcji ReadKeywordsFromIni masz odwołania do ukończenia procedury więc już błąd, a skoro funkcja to powinna coś sama zwracać, a nie zwraca nic bo nie ma ReadKeywordsFromIni = coś.

Generalnie polecam taki przycisk jak:

Menu/debug/compile a wyjdą Ci kwiatki. :)

wychwycisz takie błędy składniowe bo ten kod po prostu nie ruszy.

Zdarzenie WithEvents powinno być w klasie głównej, a nie z w module (w module nie może być bo deklaracje są pivate), no chyba że całość kodu dodałeś w klasie, dlaczego?

Przypisanie do zmiennej $ wynik funkcji:

Dim scriptPath As String

scriptPath = GetScriptFolderPath()

a potem tylko ścieżka?

Function GetScriptFolderPath() As String

GetScriptFolderPath = "C:\skrypt"

End Function

Nie można było do razu:

Dim scriptPath As String

scriptPath ="C:\skrypt"

albo lepiej do stałej, bo przecież ścieżka się nie zmienia?

Const scriptPath As String  = "C:\skrypt"

Patrząc dalej nie podoba mi się procedura InitializeInbox gdzie używasz pętli oczekując po 25 sekund co mail?

waitUntil = Now + TimeValue("00:00:25")

... generalnie ja bym tak nie robił bo to polecenie z pętlą zabiera 100% procesora.

i to na 25 sekund? aby co przenosić po jednym mailu?

W Excelu jest parametr ontime i tam to jest łatwiej, ale niemniej jednak dlaczego - wytłumaczysz mi, bo może czegoś nie łapie? Co miałeś na myśli przez to czekanie?

Ale swoją drogą jeśli to faktycznie ty i dogrzebałeś się do .Restrict? no szacun.

Używałem tego w 2019 w takim rozwiązaniu: http://vbatools.pl/wyszukaj-w-outlooku/ 

Nie widziałem u nikogo na forach, kto by z tego korzystał. Więc to bardzo rzadka potrzeba. Poza tym w tym poleceniu używa się odwołania do "@SQL=" & Chr(34) & "urn:schemas:httpmail:" & zapytanie & Chr(34)

I nie spotkałem się aby było tak prosto jak u ciebie.

potem widzę:

keywordsArray(-1 To -1)

exclusionsArray(-1 To -1)

a nie można było kolekcji użyć, a nie tablicy i dlaczego takiej dziwnej od -1 do 1...

No i ten regexp - niby jest tam jakiś patern, ale jaki, słowo z ini? przecież to jest miejsce na definicje https://learn.microsoft.com/en-us/dotnet/standard/base-types/the-regular-expression-object-model 

---

Poza tym nie mam ani twojej struktury, ani plików jakie by podchodziły pod te warunki.... więc mogę tylko przypuszczać jakie są błędy i czy proponować jakieś zmiany, ale tego z pewnością nie przetestuje.

Sam na poziomie debugowania musisz to stwierdzić. Krokowo przelecieć cały kod i z lokalsami sprawdzić co się ładuje do tych tablic. A czy optymalne?, no tak jak pow pokazałem można pewnie więcej rzeczy uprościć, a niektórych ruchów nie rozumiem nie mają przykładu.

Niemniej jednak da się odczuć tutaj AI wiec fajnie by było abyś odpowiedział mi rzetelnie jak dochodziłeś do tych linijek

p.s.

Poza tym w Outlooku jest coś takiego jak folder wyszukania, gdzie możesz spokojnie, jak mi się wydaje po pobieżnym oblookaniu kodu wykonać. Spróbuj sprawdzić, było by prościej na poziomie filtrowania i nowego widoku, niż przenoszenie danych, no chyba ze chodzi przy okazji o regułę przenoszenia do folderów.

Folder wyszukania działa też po SQLu a więc szybko.

Po zapoznaniu się z treścią tego posta zamknij go zaznaczać prawidłową odpowiedź aby liczyć na moje wsparcie na tym forum w przyszłości lub kontynuuj jeśli masz jakies pytania w tej sprawie. Liczę na to że zrobisz to po uzyskaniu odpowiedzi.

Pozdrawiam.

Answer 2

Dziękuje Panie Oskarze za treściwą odpowiedź myślę ze rozwiązała mój problem ;) ponieważ opcja jak poniżej nie obciąża serwera i można jej bez problemu używać na wielu stanowiskach jednocześnie.

"Poza tym w Outlooku jest coś takiego jak folder wyszukania, gdzie możesz spokojnie, jak mi się wydaje po pobieżnym oblookaniu kodu wykonać. Spróbuj sprawdzić, było by prościej na poziomie filtrowania i nowego widoku, niż przenoszenie danych, no chyba ze chodzi przy okazji o regułę przenoszenia do folderów.

Folder wyszukania działa też po SQLu a więc szybko."

To teraz czas na spowiedź :D

To mój pierwszy skrypt VBA do outlooka. Wcześniej pisałem tylko jakieś pojedyńcze bardzo proste makra do excela.

Kod pisałem bez testowania kompletnie na sucho ponieważ nie mam nawet w domu office 365.

Uzywałem Groka i copilot(chatgp czyli)

Pomocy szukałem ponieważ zależało mi na zobaczeniu czy jest coś czego jako laik nie widzę już pomijając fakt czy to działa czy nie :)

ReadKeywordsFromIni - slusznie tam było kilka błędów składniowych też zamiast exit i end sub powinno byc function ale oprócz tego było tam zepsutych kilka inny rzeczy.

Zdarzenie WithEvents i cały kod zawarłem w klasie thisoutlooksession ponieważ nie rozumiem do w 100% dziedziczenia klas i modułów a już napewno nie w VBA.

Nawet pomimo tego że pisałem w c++ kod i java jakiś czas to miałem z tym problemy zawsze i jakoś tego omijałem. Generalenie nawet nie jestem z branży IT a jestem bardziej hobbysta z branży budowlanej.

LoadKeywords to faktycznie troche **** został :D początkowo operować to miało na shell i special folders czyli dostęp do Desktop nie zależnie od tego na jakim dysku się znajduje. Zapomniałem to potem poprawić.

Const scriptPath As String  = "C:\skrypt" jest najlepszym zdecydowanie rozwiązaniem.

waitUntil = Now + TimeValue("00:00:25")

to dlatego ze mail.move najpierw robi zmiane w OST ale odrazu wysyła żadanie do exchange o aktualizacje statusu w serwerze.

Problem wynika z tego że jak kogoś nie ma pół roku to wpada ponad 6000 maili i nawet zwykłe reguły i filtry powodowały timeout serwera i zawieszenie synchronizacji. Mamy niestety dział IT który wszystkie problemy zamiata pod dywan i nie chcą się niczym zając i przerzucają tylko obowiązki.

Wiem że przy OST i Cached Exchange Mode serwer powinien mieć zabezpieczenie z kolejkowaniem co np 100 maili i chwila odpoczynku. Ale niestety u nas to tak marnie działa przez złe ustawienia że szkoda gadać.

wait untile nawet z doevents zawiesza outlooka i nie sprawdziło się to niestety. Jeśli masz jakieś lepsze rozwiązanie na "wstrzymanie" działania funkcji bez jej terminacji to z chęcią wysłucham. Ponieważ jak słusznie zauważyłeś nie działa to jak powinno.

Generalnie chodzi o to żeby poprostu asynchronicznie wysyłać zapytania z kolejkowaniem jak jest np 300 maili to przrzuca np 25 zatrzymuje realizacje a jak coś w miedzy czasie przyjdzie nowego na pocztę to przerzuca poza kolejką. itd te 25s to tak wstawiłem dla testu czy wogóle działa 10 sekund ostatecznie zostawiłem na chwile obecną.

Co do tego że mail.move odrazu wymusza synchronizacje exchange pomimo zmiany na ost to mam pewność ponieważ w momencie gdy nawet 1 sekunde ustawiłem opóźnienia to przenoszenie maili w ProcessMail modyfikuje tę kolekcję, co prowadzi do niezgodności indeksów lub obiektów. Stworzyłem więc kopie kolekcji i dopiero potem ją obsługiwałem aby uniknąć prób uzyskania dostepu do obiektu który nie istnieje itp.

Co do restrict to grzebałem sobie w dokumentacji jak przefiltrować maile przed pobraniem no i w sumie to znalazłem

https://learn.microsoft.com/en-us/office/vba/api/outlook.items.restrict

początkowo pobierałem całą skrzynkę i dopiero w process mail przetwarzałem Unread i pobierając i porównując adresy smtp. Filtr nie ma możliwości porównania po smtp ale zmieniłem w związku z tym na sendername ponieważ przenalizowałem i tylko 1 stała nazwa jest gdy Mantis wysyła powiadomienia..

co do

keywordsArray(-1 To -1)

exclusionsArray(-1 To -1)

to dlatego że nie wiedziałem jak uniknąć błedów gdy tablica to Nothing. Ponieważ nie ma tutaj vba czegos takiego jak null.

Więc zadeklarowałem pusta tablice bez żadnej wartości i potem sprawdzałem czy wartość jest mniejsza od 0 za pomocą unbound co powodowało to że skrypt dostawał informację że nie ma żadnego słowa kluczowego do przetworzenia ale nie było błędu że tablica nie istnieje.

W VBA tablica o granicach -1 To -1 jest technicznie "pusta", bo nie ma w niej żadnych indeksów, do których można się odwołać (np. 0, 1, 2 itd.).

Wyrażenia regularne mocno obciążają komputer więc użyłem najpierw Lcase InStr do szybkiego przeszukania a przy matchu dopiero wyrażeń regularnych aby się upewnić czy jest dopasowanie. Tu się przyznam bez bicia sugerowałem się Grokiem i jego podpowiedzią. Dzięki za linka zapoznam się z tym :)

Dzięki też za link do autorskiej strony na pewno zapoznam się:)

Answer 3

Ta odpowiedź została przetłumaczona automatycznie. W związku z tym mogą występować błędy gramatyczne lub dziwne sformułowania.

Drogi Tomaszu Bartosz,

Dzień dobry! Dziękujemy za opublikowanie wpisu w witrynie Microsoft Community.

Rozumiem twoje pytanie tutaj, ale ponieważtwoje zapytanie jest związane z kodem makra programu VBA Outlook i ponieważ firma Microsoft ma określony zasób kanału pomocy technicznej dla niektórych różnych zakresów i atrybutów wsparcia, należymy do społeczności Microsoft Forum skoncentrowanej głównie na Micrsoft 365 Exchange online. W związku z tym udostępniamy pewną ograniczoną wiedzę na temat niektórych aspektów scenariuszy związanych z makrami w programie VBA Outlook . W przypadku Twojego zapytania mamy dedykowany zespół ze specjalistyczną wiedzą w zakresie programowania pakietu Office i zapytań związanych z kodem VBA , więc czy mógłbyś połączyć się i umieścić zapytanie w naszym dedykowanym języku Office Visual Basic for Applications — Microsoft Q&A? Dodaj również   tag za pomocą Office Development - Microsoft Q&A.  Wierzymy, że dadzą Ci dokładne i skuteczne rozwiązanie Twojego problemu.

Dziękujemy za cenny czas i zrozumienie. W przypadku innych problemów nie wahaj się dodać swojego wpisu w zespole społeczności firmy Microsoft.  

Bądźcie bezpieczni i zdrowi. Miłego dnia!

Szczerze

Libeamlak | Moderator społeczności Microsoft