Goedemorgen,
Ik wil mailings van outlook met een marco opslaan in een bepaalde map in *mijn documenten*.
In *mijn documenten* staan 20 mappen. Mail wil ik archiveren over deze mappen.
Onderstaande macro heb ik gevonden op dit forum en bied een goed vertrekpunt.
Uitvoer van macro geeft onderstaand modal.
Mi zou de oplossing zijn om nu met een select de map te kiezen waarin ik de mail wil opslaan.
Ik wil dus de mappen in *mijn documenten* indexeren en een map kiezen waarin de mail wordt opgeslagen.
Wie kan mij helpen?
Ik wil mailings van outlook met een marco opslaan in een bepaalde map in *mijn documenten*.
In *mijn documenten* staan 20 mappen. Mail wil ik archiveren over deze mappen.
Onderstaande macro heb ik gevonden op dit forum en bied een goed vertrekpunt.
Uitvoer van macro geeft onderstaand modal.
Mi zou de oplossing zijn om nu met een select de map te kiezen waarin ik de mail wil opslaan.
Ik wil dus de mappen in *mijn documenten* indexeren en een map kiezen waarin de mail wordt opgeslagen.
Wie kan mij helpen?
Code:
Sub Mail_opslaan()
Dim Item As Object
Dim Map As String
Dim BestandsNaam As String
Dim Mail As Outlook.MailItem
Set Item = Application.Explorers(1).Selection(1)
If TypeName(Item) <> "MailItem" Then
MsgBox "Selecteer eerst een mailbericht...", vbInformation, "Opdracht niet mogelijk"
Exit Sub
End If
Map = InputBox("Map en bestandsnaam:", "Bericht opslaan in...", "H:\Mijn Documenten")
If CreateObject("Scripting.FileSystemObject").FolderExists(Map) Then
If Right(Map, 1) <> "\" Then
Map = Map + "\"
End If
Set Mail = Item
BestandsNaam = Replace(Mail.Subject, ":", "")
BestandsNaam = Replace(BestandsNaam, "/", "_")
BestandsNaam = Replace(BestandsNaam, "\", "")
BestandsNaam = Replace(BestandsNaam, "<", "")
BestandsNaam = Replace(BestandsNaam, ">", "")
BestandsNaam = Replace(BestandsNaam, ";", "")
If Dir(Map & BestandsNaam & ".msg") = "" Then
BestandsNaam = Format(Mail.ReceivedTime, "YYYYMMDD hhmm") & " " & BestandsNaam
BestandsNaam = Replace(BestandsNaam, ":", "-")
End If
Mail.SaveAs Map & BestandsNaam & ".msg"
Mail.Delete
End If
End Sub