Save attachment using TAG in the name

[Romulo Avila]

Good Morning,
I need to save the attachments with .xml extension that receive the outlook in a folder C:\xml, but must save them by renaming the contents of the TAG <ChNFe> said received file.

Can someone help me

Thank you

Romulo

[gmayor]

Can you post an example file (go advanced and attach it). Can you clarify what you need from that file as the file name (it might be more obvious when we see a sample).
When do you want this to happen? When you run the macro? When the messages arrive? As a batch?

[Romulo Avila]

Good afternoon,
The following attached file with NotaFiscal.xml name , I need the macro to run when the email and is found to contain an attached file with XML extension and save the file with the key content name < chNFe > in the example would look like 311607*********************XX60746000060745.xml



I could not attach the file , is giving error loading . The following part of the file which contains the < chNFe > key .


-<protNFe versao="3.10">
-<infProt><tpAmb>1</tpAmb>
<verAplic>SVCAN.PrLot_3.6.3</verAplic>
<chNFe>311607*********************60746000060745</chNFe>
<dhRecbto>2016-07-18T17:01:38-03:00</dhRecbto>
<nProt>631160003090092</nProt>
<digVal>ytdQoxZrvyYPu2GmRBuV6P0bo1c=</digVal>
<cStat>100</cStat>
<xMotivo>Autorizado o uso da NF-e</xMotivo>


Thank you for your help

[gmayor]

The following set of processes are required to perform the save as required. There is a big proviso however and that is that the asterisk is an illegal filename character, so if the asterisks in the tag are part of the tag and not masking characters you would rather we didn't see then it is not going to work. I have therefore used a function to strip your tag of illegal filename characters.

In order to read the tag it is first necessary to save the attachment, so this is initially saved in a temporary folder. The file is then read line by line to locate the tag, and then that line is stripped of the tags, to leave the text between them, which will make up the new filename. The resulting name is checked for illegal characters and the target folder is checked for the existence of the new filename. If it exists (n) is appended, where (n) is the next unused number associated with that name.

You can either select an existing message and run the macro 'ProcessAttachment', or you can use the 'SaveAttachments' macro as a script with a rulew to process the messages as they arrive.

You will almost certainly need to see http://www.gmayor.com/create_and_emp...gital_cert.htm

Obviously I have not been able to test the filename extraction code with your original file, but it works with the sample saved as a text file with the extension 'xml. so should work with a larger sample. If the tag appears more than once, only the first instance is processed.

The process creates the two folders if not already present.

Option Explicit

Sub ProcessAttachment()
'An Outlook macro by Graham Mayor - http://www.gmayor.com
Dim olMsg As MailItem
    'On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    SaveAttachments olMsg
lbl_Exit:
    Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor - http://www.gmayor.com
Dim olAttach As Attachment
Dim strFname As String
Dim strNewName As String
Dim strExt As String
Dim j As Long
Dim strTempFldr As String
Const strSaveFldr As String = "C:\XML\"
    strTempFldr = Environ("Temp") & "\TempXML\"
    CreateFolders strSaveFldr
    CreateFolders strTempFldr
    On Error GoTo lbl_Exit
    If olItem.Attachments.Count > 0 Then
        For j = olItem.Attachments.Count To 1 Step -1
            Set olAttach = olItem.Attachments(j)
            If LCase(olAttach.fileName) Like "*.xml" Then
                strFname = olAttach.fileName
                olAttach.SaveAsFile strTempFldr & strFname
                strNewName = GetName(strTempFldr & strFname) & ".xml"
                If strNewName = ".xml" Then
                    strNewName = strFname
                End If
                strNewName = CleanFileName(strNewName, "xml")
                strNewName = FileNameUnique(strSaveFldr, strNewName, "xml")
                olAttach.SaveAsFile strSaveFldr & strNewName
            End If
        Next j
        olItem.Save
    End If
    If FileExists(strTempFldr & strFname) Then
        Kill strTempFldr & strFname
    End If
lbl_Exit:
    Set olAttach = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Private Function GetName(strFname As String) As String
'An Outlook macro by Graham Mayor - http://www.gmayor.com
Dim textRow As String
Dim fileNo As Integer
    fileNo = FreeFile
    Open strFname For Input As #fileNo
    Do While Not EOF(fileNo)
        Line Input #fileNo, textRow
        If InStr(1, textRow, "<chNFe>") > 0 Then
            GetName = textRow
            GetName = Replace(GetName, "<chNFe>", "")
            GetName = Replace(GetName, "</chNFe>", "")
            Exit Do
        End If
    Loop
    Close #fileNo
lbl_Exit:
    Exit Function
End Function

Public Function CleanFileName(strFileName As String, strExtension As String) As String
'Graham Mayor  - http://www.gmayor.com
'A function to ensure there are no illegal filename
'characters in a string to be used as a filename
'strFilename is the filename to check
'strExtension is the extension of the file
Dim arrInvalid() As String
Dim vfName As Variant
Dim lng_Name As Long
Dim lng_Ext As Long
Dim lngIndex As Long
    'Ensure there is no period included with the extension
    strExtension = Replace(strExtension, Chr(46), "")
    'Record the length of the extension
    lng_Ext = Len(strExtension)

    'Remove the path from the filename if present
    If InStr(1, strFileName, Chr(92)) > 0 Then
        vfName = Split(strFileName, Chr(92))
        CleanFileName = vfName(UBound(vfName))
    Else
        CleanFileName = strFileName
    End If

    'Remove the extension from the filename if present
    If Right(CleanFileName, lng_Ext + 1) = "." & strExtension Then
        CleanFileName = Left(CleanFileName, InStrRev(CleanFileName, Chr(46)) - 1)
    End If

    'Define illegal characters (by ASCII CharNum)
    arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
    'Add the extension to the filename
    CleanFileName = CleanFileName & Chr(46) & strExtension
    'Remove any illegal filename characters
    For lngIndex = 0 To UBound(arrInvalid)
        CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lngIndex)), Chr(95))
    Next lngIndex
lbl_Exit:
    Exit Function
End Function

Private Function FileNameUnique(strPath As String, _
                                strFileName As String, _
                                strExtension As String) As String
'An Office macro by Graham Mayor - http://www.gmayor.com
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor - http://www.gmayor.com
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Office macro by Graham Mayor - http://www.gmayor.com
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If (fso.FolderExists(fldr)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor - http://www.gmayor.com
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function

[Romulo Avila]

Good afternoon,
I tested using an email that contains 03 XML files and did not work , he just recorded an XML file in the temp \ xml folder , I tried to attach the file for you to test and not did, you would have an email address so I can you to send?

Thank you for your help.
Link for download files

[gmayor]

Send the attachment to me at supportATgmayor.com with your forum user name in the subject (or the message will be discarded).

[Romulo Avila]

Good Morning,

Email sent

Thank you

[gmayor]

I have tested the message you sent me and apart from an unwanted leading character in the filename (which the following function has an extra line to correct), the process works as you requested.

Private Function GetName(strFname As String) As String
'An Outlook macro by Graham Mayor - http://www.gmayor.com
Dim textRow As String
Dim fileNo As Integer
    fileNo = FreeFile
    Open strFname For Input As #fileNo
    Do While Not EOF(fileNo)
        Line Input #fileNo, textRow
        If InStr(1, textRow, "<chNFe>") > 0 Then
            GetName = textRow
            GetName = Replace(GetName, "<chNFe>", "")
            GetName = Replace(GetName, "</chNFe>", "")
            GetName = Mid(GetName, 2) 'Add this line
            Exit Do
        End If
    Loop
    Close #fileNo
lbl_Exit:
    Exit Function
End Function

[Romulo Avila]

Good Morning,
I took the test and it worked, thanks for the help.