Document path

[Tom22]

Hello,

I am working on one code, where I can save attachment in outlook mail directly to my documents.

I have pasted the code, created folders in document and created same in outlook folder under Customize ribbon and I can see same in Macro tab in outlook.

But when I am executing this code neither it is saving anything nor giving any error msg.

I am little confuse, I guess issue is, it is not able to find my documents path.

Can anyone look into this please?

Thanks

Dim strFolder As String
 
Public Sub SaveToFolderBob()
    strFolder = "Income"
    SaveAttachments
End Sub
 
Public Sub SaveToFolderJim()
    strFolder = "Income_2"
    SaveAttachments
End Sub
 
Private Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    Dim strDate As String
    On Error Resume Next
     ' Get the path to your My Documents folder
            strFolderpath = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Documents"
    Debug.Print strFolderpath
On Error Resume Next
    
     ' The attachment folder needs to exist
     ' You can change this to another folder name of your choice
    
     ' Set the Attachment folder.
    
    Set objOL = Outlook.Application
    Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
    
     'format the date the message was sent on
    strDate = Format(objMsg.SentOn, "mmmm yyyy")
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    
    If lngCount > 0 Then
         'Create the folders (if not present)
        CreateFolders strFolderpath
        
         ' Use a count down loop for removing items
         ' from a collection. Otherwise, the loop counter gets
         ' confused and only every other item is removed.
        
        For i = lngCount To 1 Step -1
            
             ' Get the file name.
            strFile = objAttachments.Item(i).FileName
            
             ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile
            
             ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
            
        Next i
    End If
    
ExitSub:
    
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub
 
Private Function CreateFolders(strPath As String)
  
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
    Dim i As Integer
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    If Left(strPath, 2) = "\\" Then
        strPath = "\\" & vPath(2) & "\"
        For lngPath = 3 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    Else
        strPath = vPath(0) & "\"
        For lngPath = 1 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    End If
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

 

[Kenneth Hobson]

You need a trailing backslash character. e.g.

MsgBox CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\"

Your function does not return a result so it should be a Sub.

 

[Tom22]

Thanks Kenneth I tried your suggestion but it is still not working...here is the updated code

Dim strFolder As String
 
Public Sub SaveToFolderBob()
    strFolder = "Price list"
    SaveAttachments
End Sub
 
Public Sub SaveToFolderJim()
    strFolder = "Pricelist_2"
    SaveAttachments
End Sub
 
Private Sub SaveAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem 'Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim MyDir As String, fn As String
    Dim strDeletedFiles As String
    Dim strDate As String
    On Error Resume Next
     ' Get the path to your My Documents folder
     strFolderpath = CreateObject("WScript.Shell").SpecialFolders("My Documents") & "\"
     Debug.Print strFolderpath
    On Error Resume Next

     ' The attachment folder needs to exist
     ' You can change this to another folder name of your choice
    
     ' Set the Attachment folder.
    
    Set objOL = Outlook.Application
    Set objMsg = objOL.ActiveExplorer.Selection.Item(1)
    
     'format the date the message was sent on
    strDate = Format(objMsg.SentOn, "mmmm yyyy")
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    
    If lngCount > 0 Then
         'Create the folders (if not present)
        CreateFolders strFolderpath
        
         ' Use a count down loop for removing items
         ' from a collection. Otherwise, the loop counter gets
         ' confused and only every other item is removed.
        
        For i = lngCount To 1 Step -1
            
             ' Get the file name.
            strFile = objAttachments.Item(i).FileName
            
             ' Combine with the path to the Temp folder.
            strFile = strFolderpath & strFile
            
             ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
            
        Next i
    End If
    
ExitSub:
    
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub
 
Private Function CreateFolders(strPath As String)
  
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
    Dim i As Integer
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    vPath = Split(strPath, "\")
    If Left(strPath, 2) = "\\" Then
        strPath = "\\" & vPath(2) & "\"
        For lngPath = 3 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    Else
        strPath = vPath(0) & "\"
        For lngPath = 1 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    End If
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function

 

[Kenneth Hobson]

Note that my code in #2 has no space character in MyDocuments.

I am not sure why you are doing this in Excel. Seems like Outlook VBA would suffice since there is no Excel interaction.

I modified your code to test that it "works".

Private Sub Test1_SaveAttachments()
  SaveAttachments "Price Lists\Price1"
End Sub


Private Sub SaveAttachments(sSubFolder As String)
  'Tools > References > Microsoft Outlook 16.0 Object Library
  Dim objOL As Outlook.Application, objMsg As Outlook.MailItem, objAttachments As Outlook.Attachments
  Dim objSelection As Outlook.Selection, i As Integer, lngCount As Integer
  Dim strFolderPath As String, strFile As String, strDate As String
  Dim ws As Object: Set ws = CreateObject("WScript.Shell")

  ' Set the path to your My Documents folder and passed subfolder(s)
  strFolderPath = ws.SpecialFolders("MyDocuments") & "\" & sSubFolder & "\"

  Set objOL = Outlook.Application
  Set objMsg = objOL.ActiveExplorer.Selection.Item(1)

  'format the date the message was sent on
  strDate = Format(objMsg.SentOn, "mmmm yyyy")
  Set objAttachments = objMsg.Attachments
  lngCount = objAttachments.Count

  'Exit if no attachments in selected email
  If lngCount = 0 Then GoTo ExitSub

  ' Make subfolder(s) if needed.
  ws.Run "cmd /c md " & """" & strFolderPath & """", 0, True

  ' Use a count down loop for removing items
  ' from a collection. Otherwise, the loop counter gets
  ' confused and only every other item is removed.

  For i = lngCount To 1 Step -1
     ' Get the file name.
    strFile = objAttachments.Item(i).Filename
     ' Combine with the path to the Temp folder.
    strFile = strFolderPath & strFile
     ' Save the attachment as a file.
    objAttachments.Item(i).SaveAsFile strFile
  Next i

ExitSub:
  Set objAttachments = Nothing
  Set objMsg = Nothing
  Set objSelection = Nothing
  Set objOL = Nothing
  Set ws = Nothing
End Sub

 

[Tom22]

Ok may be I was not clear....I was using this is on outlook only...

I tried your one in outlook but now I am not able to see Option to run this when I press Alt+F8 .

Attaching 2 screen shot , if that hepls

 

[Kenneth Hobson]

In the future, you would best be served if you posted full Outlook VBA questions to Outlook forums. Many Excel forums also have an Outlook forum and some have an intergrated forum that marries any Microsoft suite of applications to another. Typically, that marriage is Excel and Outlook but can include Powerpoint in the mix sometimes too. There are others but those are the more common integrated applications.

If I had responded to your thread in an Outlook forum, I would change the code a bit and it would be more concise Howsoever, the code that I posted based on the bulk of your code, works in any VBA application. The method of play would be set in that application.

To run the code in Outlook, to see a routine, it must be Public. As such, call the routine like this:

Public Sub Test1_SaveAttachments()
  SaveAttachments "Price Lists\Price1"
End Sub

Obviously, you can change the subfolder(s) value of "Price Lists\Price1" to be whatever. You would probably want to make several subs to store active email attachments to a subfolder(s). To make the routine more diverse, I would modify the routines so I could just pass the full path so that some other parent folder other than MyDocuments could be used.

Of course running a public sub contained in Outlook does require that macros be enabled. Otherwise, assigning the macro to a ribbon or via Alt+F8 method is done as your pics show.

At some point in the future, you may need to come up with a way to handle the case when an attachment filename already exists in the folder.