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

[nrk]

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:

[nrk]

Any one can help?:think:

[gmayor]

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.


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

[nrk]

Today, 09:25 AM
#3 (http://www.vbaexpress.com/forum/showthread.php?65445-Attachment-receiving-from-Specific-User-and-Save-Attachment-base-on-Attachment-Name&p=392126&viewfull=1#post392126)
gmayor (http://www.vbaexpress.com/forum/member.php?54471-gmayor) Thanks Lot
:thumb i will check and update

[nrk]

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

[gmayor]

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

strFolder = Environ("USERPROFILE") & "\Documents\" (the My Documents folder) to a folder of your choice you retain the end slash.

[nrk]

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

[gmayor]

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

Exit Foras this stops the process after the first found attachment.

[nrk]

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.

[gmayor]

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



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

[nrk]

Thanks gmayor (http://www.vbaexpress.com/forum/member.php?54471-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

[nrk]

Thanks gmayor (http://www.vbaexpress.com/forum/member.php?54471-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

[gmayor]

Change the lines to


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.

[nrk]

Hi gmayor (http://www.vbaexpress.com/forum/member.php?54471-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:( ...

[nrk]

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)

[nrk]

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

[EMILIOJAN]

Decent, need to accomplish something like this with mine.