Save folderpath for emails

[Ericds]

I can't find the answer to this question on the internet so I guess it's probably a weird one:

Basically I want my macro to link my archive folders in outlook to a folder on a hard drive, every week I save my new e-mails in the folder and I don't want to have to put in the folder path every time. For the moment I put in the folderpath directly in the vba code. I would like to make it more userfriendly and have a userform ask for a folderpath if the macro doesn't "know" it yet. Then the folderpath has to be saved somewhere so that when I open and close outlook the macro can still acces it. How and where can I save it?

for the moment my (ugly and I know it) code looks like this:





Sub SaveEmailFOLDER_ProcessAllSubFolders()
Dim st As Currency, et As Currency
st = myTimer

Dim Employees As Collection

Set Employees = New Collection

Dim i As Long
Dim j As Long
Dim n As Long
Dim StrSubject As String
Dim StrName As String
Dim StrFile As String
Dim StrReceived As String
Dim StrSavePath As String
Dim StrFolder As String
Dim StrFolderPath As String
Dim StrSaveFolder As String
Dim Prompt As String
Dim Title As String
Dim StrSender As String
Dim iNameSpace As NameSpace
Dim myOlApp As Outlook.Application
Dim SubFolder As MAPIFolder
Dim mItem As MailItem
Dim FSO As Object
Dim ChosenFolder As Object
Dim Folders As New Collection
Dim EntryID As New Collection
Dim StoreID As New Collection
Dim myObject As Object
Dim mySource As Object
Dim myFile As Object
Dim p As Long
Dim NameList() As String 'pre-assigning variable, I assume a files of less than 15000 e-mails
Dim Count As Long
Dim MailsAdded As Long


Dim fld As Outlook.MAPIFolder
Set fld = Application.ActiveExplorer.CurrentFolder

'MsgBox fld.Name


p = 0

'Set myObject = CreateObject("Scripting.FileSystemObject")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
'Set ChosenFolder = iNameSpace.PickFolder
Set ChosenFolder = fld

If ChosenFolder Is Nothing Then
MsgBox "Tu n'as pas sélectionné de dossier espèce d'imbécile!"
GoTo ExitSub:


ElseIf ChosenFolder.Name = "BATANGAS" Then
StrSavePath = "\\D10.tes.local\te\INFRA\Data\DGP\P_005475_BATANGAS_LNG\Emails"
ElseIf ChosenFolder.Name = "BNP" Then
StrSavePath = "\\D10.tes.local\te\INFRA\Data\DGP\P_005304_BNPPARIBAS\Mails"
Else
MsgBox "Please assign folder!"
GoTo ExitSub:
End If

Prompt = "Please enter the path to save all the emails to."
Title = "Folder Specification"

If StrSavePath = "" Then
GoTo ExitSub:
ElseIf Not FileFolderExists(StrSavePath) Then
MsgBox StrSavePath & " fichier n'existe pas ou mauvaise adresse dans vba!"
GoTo ExitSub:
End If

If Not Right(StrSavePath, 1) = "\" Then
StrSavePath = StrSavePath & "\"
End If

Call GetFolder(Folders, EntryID, StoreID, ChosenFolder) ' All subfolders of outlook and the main folder are checked for e-mails





For i = 1 To Folders.Count

StrFolder = StripIllegalChar(Folders(i))
'MsgBox i & " " & StrFolder
n = InStr(3, StrFolder, "\") + 1
StrFolder = Mid(StrFolder, n, 256)
StrFolderPath = StrSavePath '& StrFolder & "\" ' I do not use strfolder, all subfolders in outlook are saved in the same folder on the hard drive
'MsgBox StrFolderPath
'MsgBox StrFolder
'MsgBox i & " " & StrFolder

StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"

If Not FSO.FolderExists(StrFolderPath) Then
FSO.CreateFolder (StrFolderPath)
End If



Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
Set mySource = FSO.GetFolder(StrSaveFolder)
On Error Resume Next
On Error Resume Next

If NameList(0) = "" Then ' the list is only made once for each subfolder in outlook
'MsgBox "ok"

ReDim NameList(0 To mySource.Files.Count)
For Each myFile In mySource.Files
'MsgBox Employees.Item(1)
NameList(Count) = myFile.Name
Count = Count + 1
Next
End If



For j = 1 To SubFolder.Items.Count

Set mItem = SubFolder.Items(j)
StrReceived = StripIllegalChar(Left(mItem.ReceivedTime, 10))
StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmm")
StrSender = Left(mItem.SenderName, 15)
StrSubject = mItem.Subject
StrName = StripIllegalChar(StrSubject)
StrFile = StrSaveFolder & StrReceived & "-" & StrSender & "_" & StrName & ".msg"
'MsgBox StrFile

StrFile = Left(StrFile, 256)


'MsgBox mySource.Name




For p = 0 To Count
'If Employees.Item(p) = StrReceived & "-" & StrSender & "_" & StrName & ".msg" Then

'MsgBox "trouvé"
'Employees.Remove (p)
'GoTo SaveTime
'End If

If NameList(p) = StrReceived & "-" & StrSender & "_" & StrName & ".msg" Then
GoTo SaveTime
End If




Next p



MailsAdded = MailsAdded + 1
mItem.SaveAs StrFile, 3
SaveTime:
Next j
On Error GoTo 0
Next i
et = myTimer
'MsgBox Format(myElapsedTime(et - st), "0.000000") & " seconds"
If MailsAdded = 0 Then
MsgBox "Folder was already up to date you dumb ****! Stop wasting my time!"
Else
MsgBox MailsAdded & "/" & Count & " mails added to folder in " & Format(myElapsedTime(et - st), "0.000") & " seconds (way faster than you bitch)! " & vbNewLine & " Folder is up to date!"
End If

ExitSub:




End Sub

[Ericds]

Solved this all by myself, I can put the hard-drive path in the description of the archive folder (right-click properties) and acces it with chosenfolder.description.

[cristina]

Is there a utility that would allow an entire folder or selection of emails to be batch printed? -- John

[gmayor]

Is there a utility that would allow an entire folder or selection of emails to be batch printed? -- JohnYou should have created a new thread for this unrelated question, however the following Outlook macro will print the selected messages:



Sub PrintMessages()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
For Each olItem In Application.ActiveExplorer.Selection
'If olItem.UnRead = True Then
olItem.PrintOut
'End If
Next olItem
Set olItem = Nothing
Set olItems = Nothing
lbl_Exit:
Exit Sub
End Sub