Attachment receiving from Specific User and Save Attachment base on Attachment Name

Hi Genius,

i am looking for outlook VBA which save attachment from specific User and save on hard drive(outlook event) ,But save location base on attachment name eg:-300-4567834 attachment should save under folder name 300 . There are more than 50 customers.So do i need to create if function 50 times? or any other method? i have found many example but i unable find suitable code eventually. :crying:


Could you help ?:yes

Thanks................:friends:

Any one can help?:think:

Assuming that all the required filenames are in a similar format of 3 digits hyphen 7 digits, then it is fairly simple. Create a rule to identify messages from the specific sender and associate the following script with that rule. The attachment will be saved to the folder named from the first three digits, which will be created if not present. I have included a test macro so that you can test it on an existing message.

Code:

---

Option Explicit

Sub SaveAttachment(Item As Outlook.MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Jul 2019
Dim olAtt As Attachment
Dim strFileName As String
Dim strName As String
Dim strFolder As String
    strFolder = Environ("USERPROFILE") & "\Documents\"
    If Item.Attachments.Count > 0 Then
        For Each olAtt In Item.Attachments
            strName = Left(olAtt.fileName, InStrRev(olAtt.fileName, ".") - 1)
            If strName Like "???-???????" Then
                strFolder = strFolder & Split(strName, "-")(0) & Chr(92)
                CreateFolders strFolder
                olAtt.SaveAsFile strFolder & olAtt.fileName
                Exit For
            End If
        Next olAtt
    End If
lbl_Exit:
    Set olAtt = Nothing
    Exit Sub
End Sub


Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lng_PathSep = InStr(3, strPath, "\")
    If lng_PathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        If lng_PathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lng_PathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
            oFSO.CreateFolder Left(strPath, lng_PathSep)
        End If
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub


Sub TestMacro()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachment olMsg
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

---

Today, 09:25 AM

#3

gmayor Thanks Lot
:thumb i will check and update

If any mail has more than one attachment how to change code ? (currently tested but not save other attachment )

Also following code "CreateFolders strFolder" dosent work

Therefore i have created folder and run rule.

Thanks:yes

If it is another attachment with the same name format then remote the line Exit For so the loop doesn't stop at the first one.

Did you include the CreateFolders function in the module? If so, then it will work provided you have write permission at the location and you ensure that if you change

Code:

---

strFolder = Environ("USERPROFILE") & "\Documents\"

---

(the My Documents folder) to a folder of your choice you retain the end slash.

Code:

---

Option Explicit
Sub SaveAttachment(Item As Outlook.MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Jul 2019
Dim olAtt As Attachment
Dim strFileName As String
Dim strName As String
Dim strFolder As String
    strFolder = Environ("USERPROFILE") & "\Documents\"
    If Item.Attachments.Count > 0 Then
        For Each olAtt In Item.Attachments
            strName = Left(olAtt.fileName, InStrRev(olAtt.fileName, ".") - 1)
            If strName Like "???-???????" Then
                strFolder = strFolder & Split(strName, "-")(0) & Chr(92)
                CreateFolders strFolder
                olAtt.SaveAsFile strFolder & olAtt.fileName
                Exit For
            End If
        Next olAtt
    End If
lbl_Exit:
    Set olAtt = Nothing
    Exit Sub
End Sub

---

i have added above code but multiple attachments are not saving in folders i was trying many times make correct but it couldn't :crying:

Thanks in advance Graham Mayor

There was a typo in my last message it should have read REMOVE the line Exit For. That line is still present.
Delete the line

Code:

---

Exit For

---

as this stops the process after the first found attachment.

Thanks lot i remove "Exit For" then save first attachment but when save second attachment error occurred. "Cannot Save the attachment,Path doesnt exist.Verify the path is correct.

Doh! My fault :crying: I forgot to move the folder definition into the loop so it is recreated for each attachment.:banghead:

Code:

---

Sub SaveAttachment(Item As Outlook.MailItem)'Graham Mayor - https://www.gmayor.com - Last updated - 05 Jul 2019
Dim olAtt As Attachment
Dim strFileName As String
Dim strName As String
Dim strFolder As String
    If Item.Attachments.Count > 0 Then
        For Each olAtt In Item.Attachments
            strFolder = Environ("USERPROFILE") & "\Documents\"
                strName = Left(olAtt.fileName, InStrRev(olAtt.fileName, ".") - 1)
            If strName Like "???-???????" Then
                strFolder = strFolder & Split(strName, "-")(0) & Chr(92)
                CreateFolders strFolder
                olAtt.SaveAsFile strFolder & olAtt.fileName
            End If
        Next olAtt
    End If
lbl_Exit:
    Set olAtt = Nothing
    Exit Sub
End Sub

---

Thanks gmayor for your valuable support!!!!!: pray2:: pray2: its works fine If you can please help me to following changes.:help

1.i want to check condition first five letters only eg;- ?????- After dash no need to check any condition.

Also some folders link with system therefore unable to change name eg: one of attachment send with 00161-344577558585 but folder name is 161 so can give ignore zero and save in 161 folder :wot

Thanks gmayor for your valuable support!!!!!: pray2:: pray2: its works fine If you can please help me to following changes.:help

1.i want to check condition first five letters only eg;- ?????- After dash no need to check any condition.

Also some folders link with system therefore unable to change name eg: one of attachment send with 00161-344577558585 but folder name is 161 so can give ignore zero and save in 161 folder :wot

Change the lines to

Code:

---

If strName Like "*???-?????*" Then
                strFolder = strFolder & Int(Split(strName, "-")(0)) & Chr(92)

---

However there's an old expression from the late Gilbert Briggs, a UK loudspeaker pioneer: 'The wider you open the window, the more dirt flies in'. The above string while working for the number sequences you have suggested, will also work with others that you may not want.

Hi gmayor thanks Master your valuable support i want to learn this kind of stuff. i am following some tutorial from Youtube .But still child for VBA:( ...

could i use if condition for "?????-??????*" if attachment has first 3 digit (before dash)run this loop or or 5 digit run this loop .:(
because attachment is system generated couldn't change rename part ( 5 digits attachment name)

i found solution i made two sub for each condition and it works :yes

Decent, need to accomplish something like this with mine.