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? -- John

You 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