VBA script creating folder on networkdrive and copy attachment file to that specific

[pbeumer]

Hello there,

I have a question reagrding saving an attachment file to a folder that has to be created.

I recieve email with the following subject; **actie**: HAH datum 22-01-2019 | ordernummer 11676

The date and numbers in red will change every time i recieve this email. I have found a VBA script which saves the attachment file but only to one specific folder.

I`m looking for a script which creates a folder on a network drive (name of the folder should be the subject of the email) and than saves the attachment file to the older which was just created.

Is this even possible what I want?

Thanks in advance for all the effort everybody puts in.

Greetings Patrick

[gmayor]

In theory it is possible, assuming you have write access to the network drive location in question, however you say the message subjects are like
**actie**: HAH datum 22-01-2019 | ordernummer 11676
This string contains three illegal filename characters '*: and |' and so without addressing that, is unsuited to being used as a folder name. Are the asterisks used to signify missing letters you don't wish to disclose in a public forum? What's the significance of the red colour (which cannot be repeated in a folder name)? I take it you are identifying these messages using a rule so that you are not going to process all your received messages? What is the file format of the attachment?

[pbeumer]

Dear Gmayor,

The asteriks is simply in the subject and is there every time.

The red colour was just for showing that these characters will change in every email So the date and teh ordernummer will be different with every email.

I indeed going to apply a rule so that only messages with

**actie**: HAH datum in the subject will be processed.

The file format is excel.

Thank you in advance

[gmayor]

In that case run the following script 'CustomSaveAttachments' from your rule. Change the path '"\\NetworkName\backup\Attachments"' to the location where you want to create the sub folders. The macro will create a subfolder as requested (and the additional folders in the path that are required) if they are not present and save any Excel XLSX files attached to that folder. Use the test macro with an existing message to test it.

Option Explicit

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

Public Sub CustomSaveAttachments(Item As Outlook.MailItem)
Const strPath As String = "\\ServerName\backup\Attachments\" 'The root path
Dim olAtt As Attachment
Dim strFileName As String
Dim strSavePath As String
    If Item.Attachments.Count > 0 Then
        For Each olAtt In Item.Attachments
            If olAtt.fileName Like "*.xlsx" Then
                strSavePath = Item.Subject
                strSavePath = Replace(strSavePath, "**actie**: ", "") 'optional
                strSavePath = CleanFileName(strSavePath)
                strSavePath = strPath & strSavePath & "\"
                CreateFolders strSavePath
                strFileName = FileNameUnique(strSavePath, olAtt.fileName, "xlsx")
                strFileName = strSavePath & strFileName
                olAtt.SaveAsFile strFileName
            End If
        Next olAtt
    End If
lbl_Exit:
    Exit Sub
End Sub

Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
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

Private Function CleanFileName(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
    'Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    'Remove any illegal filename characters
    CleanFileName = strFileName
    For lng_Index = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
    Next lng_Index
lbl_Exit:
    Exit Function
End Function

Private Function FileNameUnique(strPath As String, _
                               strFileName As String, _
                               strExtension As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strextension is the extension of the filename to check
Dim lng_F As Long
Dim lng_Name As Long
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    strExtension = Replace(strExtension, Chr(46), "")
    lng_F = 1
    lng_Name = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lng_Name)
    'If the filename exists, add or increment a number to the filename
    'and keep checking until a unique name is found
    Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
        lng_F = lng_F + 1
    Loop
    'Reassemble the filename
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function

[pbeumer]

GMAYOR... YOU ARE THE MAN!!!

Script works like a charm