Outlook - En makro for å lage mapper

Utgave

Jeg mottar e-post veldig ofte som har et "ord" i tittelen på e-posten i formatet issue-xxxx, hvor xxxx er et 4-sifret tall. Jeg har opprettet en postkassemappe som heter problemer. Det jeg vil at makroen skal gjøre er å finne alle e-postmeldinger med en streng av formatproblemet xxxx i tittelen, og se etter en mappe under problemer med samme navn. Hvis en ikke er funnet, skal den opprettes. E-posten skal da flyttes til den undermappen.

Anta for eksempel at en e-post kommer inn med ordet issue-1234. Makroen, når du kjører (forhåpentligvis via verktøylinjen), bør finne den e-posten og se etter en mappe som heter problem-1234 under problemmappen og opprett den hvis den ikke ble funnet. E-posten skal da flyttes til den aktuelle emisjonen-1234-mappen.

Jeg har ikke gjort noe makroprogrammering tidligere, så noen hjelp på hvordan du kommer i gang ville bli verdsatt. Hvis du tilfeldigvis har en makro som gjør dette allerede, og vil dele koden, ville det bli enda bedre.

Løsning

'Filprosjekter i sine egne undermapper

'Skrevet av Bryce Pepper ( )

'Søker underlagt et M- eller Z-prosjektnummer (må være mellom 4-6 siffer)

'og legger dem i en prosjektmappe (opprett mappe hvis en ikke finnes)

'lagt til støtte for P & R-prosjekter 2009-03-03 B.Pepper

'lagt til støtte for # for å gjøre Bill Z. happy 2009-03-04 B.Pepper

Her er koden:

 Dim WithEvents objInboxItems Som Outlook.Items Dim objDestinationFolder Som Outlook.MAPIFolder Sub Application_Startup () Dim objNameSpace Som Outlook.NameSpace Dim objInboxFolder Som Outlook.MAPIFolder Sett objNameSpace = Application.Session Sett objInboxFolder = objNameSpace.GetDefaultFolder (olFolderInbox) Sett objInboxItems = objInboxFolder.Items Angi objDestinationFolder = objInboxFolder.Parent.Folders ("Projects") End Sub "Kjør denne koden for å stoppe regelen. Sub StopRule () Sett objInboxItems = Intet End Sub "Denne koden er den faktiske regelen. Private Sub objInboxItems_ItemAdd (ByVal Item As Object) Dim objProjectFolder Som Outlook.MAPIFolder Dim folderName Som String Set objRegEx = CreateObject ("VBScript.RegExp") objRegEx.Global = False 'Søk etter e-postemner som inneholder prosjektnummer (M007439, Z6312) objRegEx .Pattern = "([M, Z, P, R, #] d {4, 6})" Sett colMatches = objRegEx.Execute (Item.Subject) Hvis colMatches.Count> 0 Then For Each myMatch I colMatches If Left $ (myMatch.Value, 1) = "#" Så folderName = "M" & Right $ ("00" & Mid $ (myMatch.Value, 2), 6) Else folderName = Venstre $ (myMatch.Value, 1) Høyre $ ("00" & Mid $ (myMatch.Value, 2), 6) Slutt Hvis Hvis FolderExists (objDestinationFolder, mappenavn) Sett deretter objProjectFolder = objDestinationFolder.Folders (mappenavn) Else Set objProjectFolder = objDestinationFolder.Folders.Add Avslutt Hvis Item.Move objProjectFolder Next End Hvis Set objProjectFolder = Ingenting Slutt Sub-funksjon FolderExists (parentFolder Som MAPIFolder, mappenavn Som String) Dim tmpInbox Som MAPIFolder På Feil GoTo ha ndleError 'Hvis mappen ikke eksisterer, vil det oppstå en feil i neste linje. Denne feilen vil føre til at feilbehandleren går til: handleError 'og hopper over sannverdig verdi Set tmpInbox = parentFolder.Folders (folderName) FolderExists = True Exit Function handleError: FolderExists = False End Function 

Noter det

Takk til Pepper for dette tipset på forumet.

Forrige Artikkel Neste Artikkel

Beste Tips