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_employ_a_digital_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.