CODEWITHSUNDEEP
vbaoutlook
Andrew
Andrew

Reputation: 53

Folder location of of the .msg file I have just opened

I have Outlook VBA code which downloads all attached items to a specific folder.

The emails I am looking at are saved as (.msg) files in folder: C:\Users\username\Documents\emails. I put a MsgBox to tell me the folder location of the email file I have just opened.

I expect C:\Users\username\Documents\emails

I tried CurDir(). This gave me C:\Users\username\Documents.

The following code also provides C:\Users\username\Documents.

Sub SaveOlAttachments()
Dim app As Outlook.Application
Dim Msg As Outlook.MailItem
Dim att As Outlook.attachment
Dim strFilePath As String
Dim strAttPath As String
Dim wshell As Object
Set wshell = CreateObject("WScript.Shell")

Set app = New Outlook.Application

'path for creating msgs
strFilePath = wshell.CurrentDirectory & "\emails\"
MsgBox (strFilePath)
'path for saving attachments
strAttPath = strFilePath & "\attachments\"
Do While Len(strFile) > 0
    Set Msg = app.CreateItemFromTemplate(strFilePath & strFile)
    If Msg.Attachments.Count > 0 Then
         For Each att In Msg.Attachments
             att.SaveAsFile strAttPath & att.FileName
         Next
    End If
    strFile = Dir
Loop

End Sub

Why not add to the end?

The emails will be moved to a shared drive.
Emails will be related to a customer and so folders will be created for the relevant emails and attachments to be saved in relation to each.

For example:

Z:\Customer Contact\Customer\JoeBlogs
Z:\Customer Contact\Customer\JoeBlogs\attachments)

Z:\Customer Contact\Customer\JaneDoe
Z:\Customer Contact\Customer\JaneDoe\attachments)

Since the folder and location of the attachments to be saved to will change each time (depending on the email the macro is being fired on) I cannot add to the end.

Upvotes: 0

Views: 124

Answers (1)

niton
niton

Reputation: 9189

You can navigate to the folder with an Excel dialog, then return the path:

Private Sub selectedFileLocation()

Dim olMsg As MailItem
Dim olAtt As Attachment

Dim strPath As String
Dim strFile As String

Dim strAttPath As String

Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")

Dim fd As Office.FileDialog
Set fd = xlApp.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False

Dim selectedItem As Variant
Dim i As Long

If fd.Show = -1 Then

    For Each selectedItem In fd.SelectedItems
        
        ' select one file, any extension
        Debug.Print "selectedItem: " & selectedItem
        
        i = InStrRev(selectedItem, "\")
        If i > 1 Then
            strPath = Left(selectedItem, i)
            ' Note the backslash at the end
            Debug.Print "strPath.....: " & strPath
            
            strAttPath = strPath & "attachments\"
            Debug.Print "strAttPath..: " & strAttPath
        End If

    Next
End If

xlApp.Quit

Set fd = Nothing
Set xlApp = Nothing

End Sub

Upvotes: 0

Related Questions