Outlook - макрос за създаване на папки

Проблем

Много често получавам имейли, които имат "дума" в заглавието на имейла във формат на issue-xxxx, където xxxx е 4-цифрен номер. Създал съм папка за пощенска кутия, наречена „проблеми“. Това, което бих искал макросът да направи, е да намери всички имейли с низ от формата issue-xxxx в заглавието и да потърси папка с проблеми със същото име. Ако не се намери, то трябва да се създаде. След това имейлът трябва да бъде преместен в тази подпапка.

Да предположим например, че имейл идва с думата issue-1234. Макросът, когато се изпълнява (надявам се през лентата с инструменти), трябва да открие този имейл и да провери за папка, наречена issue-1234 под папката с проблемите и да я създаде, ако не е намерена. След това имейлът трябва да бъде преместен в тази папка с емисия-1234.

В миналото не съм правил никакво макро програмиране, така че всяка помощ за това как да започнем ще бъде оценена. Ако имате макрос, който вече прави това и искате да споделите кода, това би било още по-добре.

Решение

- Файлови проекти в собствените им подпапки

„Написано от Bryce Pepper ( )

"Търси обект за номер на проект M или Z (трябва да е между 4-6 цифри)

и ги записва в подпапка на проект (създайте папка, ако не съществува)

'добавена подкрепа за P & R проекти 2009-03-03 B.Pepper

'добави поддръжка за #, за да направи Bill Z. щастлив 2009-03-04 B.Pepper

Ето кода:

 Dim WithEvents objInboxItems като Outlook.Items Дим objDestinationFolder Като Outlook.MAPIFolder Под Application_Startup () Dim objNameSpace Като Outlook.NameSpace Dim objInboxFolder Като Outlook.MAPIFolder Настройте objNameSpace.GetDefaultFolder (olFolderInbox) Задайте objDestinationFolder = objInboxFolder.Parent.Folders ("Проекти") End Sub 'Изпълнете този код, за да спрете вашето правило. Sub StopRule () Set objInboxItems = Nothing End Sub 'Този код е действителното правило. Частно подразделение objInboxItems_ItemAdd (ByVal Item as Object) Dim objProjectFolder Като Outlook.MAPIFolder Dim folderName As String set objRegEx = CreateObject ("VBScript.RegExp") objRegEx.Global = False 'Търсене на имейли, които съдържат номер на проекта (M007439, Z6312) .Pattern = "([M, Z, P, R, #] d {4, 6})" Задайте colMatches = objRegEx.Execute (Item.Subject) Ако colMatches.Count> 0 Тогава за всеки myMatch In colMatches Ако наляво $ (myMatch.Value, 1) = "#" Тогава folderName = "M" & Наляво $ ("00" & Mid $ (myMatch.Value, 2), 6) Друго folderName = Ляво $ (myMatch.Value, 1) & Надясно $ ("00" & Mid $ (myMatch.Value, 2), 6) Край Ако If FolderExists (objDestinationFolder, folderName) Тогава настройте objProjectFolder = objDestinationFolder.Folders (folderName) Else Set objProjectFolder = objDestinationFolder.Folders.Add (folderName) Край Ако ItemMove objProjectFolder Следващ Край Ако зададете objProjectFolder = Нищо не завършва Подфункция FolderExists (parentFolder As MAPIFolder, folderName As String) Dim tmpInbox As MAPIFolder On Error GoTo ha ndleError 'Ако папката не съществува, ще има грешка в следващия ред. Тази грешка ще накара обработващия грешка да отиде в: handleError 'и да пропусне верната стойност True Set tmpInbox = parentFolder.Folders (folderName) FolderExists = True Изход от функцията handleError: FolderExists = Функция за грешен край