Attribute VB_Name = "basMakeEnvio" ' $Id: basMakeEnvio.bas $ ' Last updated: ' $Date: 2021-02-05 00:57Z $ ' $Revision: 1.2.0 $ ' /******************************* LICENSE *********************************** ' * Copyright (C) 2020-21 David Ireland, DI Management Services Pty Limited. ' * All rights reserved. <https://di-mgt.com.au> <https://cryptosys.net> ' * The code in this module is licensed under the terms of the MIT license. ' * For a copy, see <http://opensource.org/licenses/MIT> ' **************************************************************************** Option Explicit Option Base 0 Public Const MIN_PKI_VER As Long = 200000 Public Const MIN_SC14N_VER As Long = 20100 ' Requires the following applications to be installed: ' CryptoSys PKI Pro <https://cryptosys.net/pki/> ' SC14N <https://cryptosys.net/sc14n/> ' xmlsq <https://cryptosys.net/xmlsq/> ' Requires the following modules to be in the project: ' basCrPKI.bas v20.0.0 ' basCrPKIWrappers.bas v20.0.2 <https://cryptosys.net/pki/vba-wrappers.html> ' basSc14n.bas v2.1.0 ' basXmlsq.bas v0.9.0 ' basUtf8FromString.bas <https://di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html> ' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ' CAUTION: this code contains a hard-coded date for debugging in `ProcessEnvioDoc`. ' Hardcoded TIMESTAMP is "2020-09-27T18:37:31" ' TODO: remove this hardcoded value and use current time with `Format(Now,...)` ' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ' GLOBAL DEFAULT ALGORITHMS ' These must match the algorithms hard-coded into the Signature template ' (change one, remember to change the other) Public Const pki_HASHALG As Long = PKI_HASH_SHA1 Public Const pki_SIGALG As Long = PKI_SIG_RSA_SHA1 Public Const sc14n_DIGALG As Long = SC14N_DIG_SHA1 Public Const sc14n_TRANMETHOD As Long = SC14N_METHOD_INCLUSIVE ' Compulsory placeholder expected in documents to be signed. Public Const SIGPLACE As String = "<Signature>@!SIGNATURE!@</Signature>" Public Function Main() Debug.Print "PKI Version=" & PKI_Version(0, 0) Debug.Print "SC14N Version=" & SC14N_Gen_Version() Debug.Print "XMLSQ Version=" & XMLSQ_Gen_Version() ' Check we have minimum library versions Debug.Assert PKI_Version(0, 0) >= MIN_PKI_VER Debug.Assert SC14N_Gen_Version() >= MIN_SC14N_VER ' Expecting `work` subdirectory with working files in it ChDir Application.CurrentProject.Path & "\work" Debug.Print "CurDir=" & CurDir() Dim strDigest As String strDigest = String(PKI_SHA1_CHARS, " ") Dim envioDoc As String ' Go do the business using test files envioDoc = ProcessEnvioDoc("output-enviodte.xml", "user.cer", "user.pfx", "password", _ "caf33.key", "template-enviodte.xml", "dte-33-1.xml", "dte-33-2.xml") ' Returns either the name of the file just created or an error message beginning with "**ERROR" If InStr(envioDoc, "**ERROR") Then Debug.Print envioDoc Else Debug.Print "Created file [" & envioDoc & "]" Call HASH_HexFromFile(strDigest, Len(strDigest), envioDoc, PKI_HASH_SHA1 Or PKI_HASH_MODE_TEXT) Debug.Print "HASH(file)=" & strDigest Debug.Print ' Expected HASH **if** TIMESTAMP is "2020-09-27T18:37:31": ' c94db97dbc682c803e2421f42b715c9c840d936c End If ' Go do the business - part 2 - EnvioBOLETA envioDoc = ProcessEnvioDoc("output-boleta.xml", "user.cer", "user.pfx", "password", _ "caf39.key", "template-boleta.xml", "dte-b1.xml", "dte-b2.xml") If InStr(envioDoc, "**ERROR") Then Debug.Print envioDoc Else Debug.Print "Created file [" & envioDoc & "]" Call HASH_HexFromFile(strDigest, Len(strDigest), envioDoc, PKI_HASH_SHA1 Or PKI_HASH_MODE_TEXT) Debug.Print "HASH(file)=" & strDigest Debug.Print ' Expected HASH **if** TIMESTAMP is "2020-09-27T18:37:31": ' b6f76d84ca854d163643e6efe9bfc0a970f2f20b End If End Function ''' <summary> ''' Create signed Envio document. ''' </summary> ''' <param name="outputxmlFile">Name of output file to create.</param> ''' <param name="certFile">Signer's X.509 certificate file (.cer).</param> ''' <param name="keyFile">Signer's private key file (.pfx)</param> ''' <param name="password">Password for private key file.</param> ''' <param name="cafKeyFile">CAF private key file.</param> ''' <param name="outerTemplate">XML template for outer Envio document.</param> ''' <param name="dtedocs">List of DTE XML documents to be signed (comma-separated list of filenames)</param> ''' <returns>Name of output file created if successful, or an error message that begins with "**ERROR:"</returns> Public Function ProcessEnvioDoc(strOutputXmlFile As String, strCertFile As String, strKeyFile As String, strPassword As String, _ strCafKeyFile As String, strOuterTemplate As String, ParamArray arrDteDocNames() As Variant) As String Dim colDteList As New Collection Dim i As Integer Dim n As Long Dim nChars As Long Dim nBytes As Long Dim strMsg As String Dim xmlsetdte As String Dim strSigningTime As String Dim strCertStr As String Dim strCafKey As String Dim strPriKey As String Dim strPubKey As String Dim strDteDoc As String Dim docid As String Dim sig As String Dim xmlData() As Byte Dim toinsert As String ' Compulsory placeholder expected in outer template. Const SETOFDTEPLACE As String = "<DTE>@!SET-OF-DTE!@</DTE>" ' Read in outer template xmlsetdte = ReadFileIntoString(strOuterTemplate) If Len(xmlsetdte) = 0 Then strMsg = "**ERROR: Failed to read template file '" & strOuterTemplate & "'" Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If ' Check for required placeholders If InStr(xmlsetdte, SIGPLACE) = 0 Then strMsg = "**ERROR: Placeholder is missing: " & SIGPLACE Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If If InStr(xmlsetdte, SETOFDTEPLACE) = 0 Then strMsg = "**ERROR: Placeholder is missing: " & SETOFDTEPLACE Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If ' Read in certificate file to a one-line base64 string strCertStr = x509ReadStringFromFile(strCertFile, 0) If Len(strCertStr) = 0 Then strMsg = "**ERROR: Failed to read X.509 certificate in '" & strCertFile & "'" Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If ' Read in CAF private key (no password) strCafKey = rsaReadPrivateKey(strCafKeyFile, "") If Len(strCafKey) = 0 Then strMsg = "**ERROR: Failed to read CAF private key in '" & strCafKeyFile & "'" Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If Debug.Print "CAF key has " & RSA_KeyBits(strCafKey) & " bits" ' Read in private key from PFX file strPriKey = rsaReadPrivateKey(strKeyFile, strPassword) If Len(strPriKey) = 0 Then strMsg = "**ERROR: Failed to read private key in '" & strKeyFile & "'" Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If Debug.Print "Private key has " & RSA_KeyBits(strPriKey) & " bits" ' Check private key matches certificate strPubKey = rsaReadPublicKey(strCertStr) n = RSA_KeyMatch(strPriKey, strPubKey) If (n <> 0) Then strMsg = "**ERROR: private key and certificate do not match." Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If ' Set signing time in <xs:datetime> form strSigningTime = Format(Now, "yyyy-mm-ddThh:mm:ss") ' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ' CAUTION: hard-coded value here for debugging ' TODO: [DEBUG] remove this line strSigningTime = "2020-09-27T18:37:31" ' %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Debug.Print "signingTime=" & strSigningTime ' Iterate through list of DTE documents For i = 0 To UBound(arrDteDocNames) strDteDoc = ProcessDte(CStr(arrDteDocNames(i)), strCertStr, strPriKey, strCafKey, strSigningTime) ' Catch error - result contains "**ERROR" If InStr(strDteDoc, "**ERROR") > 0 Then strMsg = strDteDoc Debug.Print strMsg ProcessEnvioDoc = strMsg Exit Function End If 'Debug.Print strDteDoc ' Store signed DTE document to be used later. colDteList.Add strDteDoc Next ' Process remainder of outer document Debug.Print vbCrLf & "Processing outer document..." xmlsetdte = Replace(xmlsetdte, "@!TIMESTAMP!@", strSigningTime) n = colDteList.Count xmlsetdte = Replace(xmlsetdte, "@!NUM-DTE!@", n) ' Concatenate the collection of signed DTE docs into an array toinsert = Join(CollectionToArray(colDteList), vbCrLf) ' Insert DTE docs into Envio outer XML xmlsetdte = Replace(xmlsetdte, "<DTE>@!SET-OF-DTE!@</DTE>", toinsert) ' Extract ID of SetDTE for Signature reference docid = xmlsqGetText(xmlsetdte, "//SetDTE/@ID", 0) Debug.Print "SetDTE ID=" & docid ' Convert XML string to bytes: NB explicit Latin-1 encoding. xmlData = StrConv(xmlsetdte, vbFromUnicode) ' Compute the signature over the element SetDTE sig = MakeSignature(xmlData, docid, "SetDTE", strPriKey, strCertStr) Debug.Assert Len(sig) > 0 xmlsetdte = Replace(xmlsetdte, SIGPLACE, sig) ' Final check for uncompleted '@!..!@' If InStr(xmlsetdte, "@!") > 0 Then Debug.Print "WARNING: uncompleted '@!..!@' items" End If ' Write out the final output file in Latin-1 xmlData = StrConv(xmlsetdte, vbFromUnicode) Call WriteFileFromBytes(strOutputXmlFile, xmlData) ' Clean up private keys strCafKey = wipeString(strCafKey) strPriKey = wipeString(strPriKey) ProcessEnvioDoc = strOutputXmlFile End Function ''' <summary> ''' Process an individual DTE document. ''' </summary> ''' <param name="xmlFile">Base DTE file to be processed with placeholders of form "@!...!@".</param> ''' <param name="certStr">User's X.509 certificate as a base64 string.</param> ''' <param name="sbPriKey">User's private signing key in Pki internal string form.</param> ''' <param name="sbCafKey">User's CAF private key in Pki internal string form.</param> ''' <param name="signingtime">Signing time as string in xs:dateTime form.</param> ''' <returns>Signed DTE document as a string, or an error message that begins with "**ERROR:"</returns> Public Function ProcessDte(strXmlFile As String, strCertStr As String, strPriKey As String, strCafKey As String, strSigningTime As String) As String Dim xmlData() As Byte Dim b() As Byte Dim dig() As Byte Dim xmlStr As String Dim strMsg As String Dim fecha As String Dim ddelem As String Dim frmtSig As String Dim docid As String Dim sig As String Dim n As Long Dim nBytes As Long Dim nChars As Long Dim xmlnewfile As String Dim header As String Dim temps As String Dim regex As Object Dim matches As Object ' Compulsory placeholder expected in DTE base document. Const FRMTSIGPLACE As String = "@!FRMT-SIG!@" ' NOTE: we use standard Unicode strings for string manipulation and regex, ' and byte arrays for crypto and C14N operations. Debug.Print vbCrLf & "Processing file: " & strXmlFile ' Read in the base XML file as bytes xmlData = ReadFileIntoBytes(strXmlFile) If cnvBytesLen(xmlData) = 0 Then strMsg = "**ERROR: Failed to read XML file '" & strXmlFile & "'" Debug.Print strMsg ProcessDte = strMsg Exit Function End If ' Convert XML byte input to a Unicode string for regex/replace editing ' Try to guess encoding: expecting either Latin-1 or UTF-8 (or just plain US-ASCII, a subset of UTF-8) n = CNV_CheckUTF8Bytes(xmlData(0), cnvBytesLen(xmlData)) If 0 = n Then ' Not valid UTF-8, so probably Latin-1 xmlStr = StrConv(xmlData, vbUnicode) Else xmlStr = Utf8BytesToString(xmlData) End If ' Check for required placeholders If InStr(xmlStr, SIGPLACE) = 0 Then strMsg = "**ERROR: Placeholder is missing" Debug.Print strMsg ProcessDte = strMsg Exit Function End If If InStr(xmlStr, FRMTSIGPLACE) = 0 Then strMsg = "**ERROR: Placeholder is missing" Debug.Print strMsg ProcessDte = strMsg Exit Function End If ' Set signing time in document placeholder xmlStr = Replace(xmlStr, "@!TIMESTAMP!@", strSigningTime) ' And set the Fecha Emision Contable del DTE (AAAA-MM-DD) fecha = Left(strSigningTime, 10) xmlStr = Replace(xmlStr, "@!FECHA!@", fecha) 'Debug.Print xmlStr ' [2021-02-05] FIX ' We can use Xmlsq to extract the flattened DD element - NO! ' PROBLEM: Xpath converts XML entities ' and &qout; to literal characters, e.g. " and ' ' ddelem = xmlsqFullQuery(xmlStr, "//DD", XMLSQ_RAW Or XMLSQ_TRIM) ' SOLUTION: Use regex instead to extract the <DD> element. Set regex = CreateObject("VBScript.RegExp") With regex .Pattern = "(<DD[\s\S]*</DD>)" .Multiline = True End With If regex.Test(xmlStr) Then ' (May need error handling here...) Set matches = regex.Execute(xmlStr) ddelem = matches(0).SubMatches(0) Else strMsg = "**ERROR: Cannot find DD element in DTE document" Debug.Print strMsg ProcessDte = strMsg Exit Function End If ' Now flatten it - this is the input for the FRMT signature With regex .Pattern = ">\s+<" .Global = True End With ddelem = regex.Replace(ddelem, "><") Debug.Print "---" & vbCrLf & ddelem & vbCrLf & "---" ' Convert to bytes in Latin-1 encoding b = StrConv(ddelem, vbFromUnicode) ' Compute FRMT signature over the flattened, Latin-1-encoded <DD> element using CAF key frmtSig = sigSignData(b, strCafKey, "", "", pki_SIGALG) Debug.Print "SIG(<DD>)=" & frmtSig Debug.Assert Len(frmtSig) > 0 ' Insert this signature in placeholder @!FRMT-SIG!@ xmlStr = Replace(xmlStr, "@!FRMT-SIG!@", frmtSig) ' Copy updated XML string to array of bytes, this time in UTF-8 encoding xmlData = Utf8BytesFromString(xmlStr) nBytes = cnvBytesLen(xmlData) ' Do a test C14N calc on this data to see if any XML problems dig = sc14nBytes2Digest(xmlData, nBytes, "", "", 0) If cnvBytesLen(dig) = 0 Then strMsg = "**ERROR: XML problem: " & sc14nErrLastError() Debug.Print strMsg ProcessDte = strMsg Exit Function End If ' Extract ID of Documento for Signature reference docid = xmlsqGetText(xmlStr, "//Documento/@ID", 0) Debug.Print "Documento ID=" & docid ' Compute the signature over the element <Documento> sig = MakeSignature(xmlData, docid, "Documento", strPriKey, strCertStr) 'Debug.Print "---" & vbCrLf & sig & vbCrLf & "---" ' Insert the completed Signature into the parent DTE document xmlStr = Replace(xmlStr, SIGPLACE, sig) ' Final check for uncompleted '@!..!@' If InStr(xmlStr, "@!") > 0 Then Debug.Print "WARNING: uncompleted '@!..!@' items" End If ' Output XML should now be complete ' Convert to UTF-8 bytes for XML check xmlData = Utf8BytesFromString(xmlStr) nBytes = cnvBytesLen(xmlData) ' Final check dig = sc14nBytes2Digest(xmlData, nBytes, "", "", 0) If cnvBytesLen(dig) = 0 Then strMsg = "**ERROR: XML problem: " & sc14nErrLastError() Debug.Print strMsg ProcessDte = strMsg Exit Function End If ' Save this DTE doc as a file for checking. xmlnewfile = AppendToFileStem(strXmlFile, "-signed") ' Add header to XML document and save header = "<?xml version='1.0' encoding='ISO-8859-1'?>" & vbCrLf & _ "<!DOCTYPE DTE [" & vbCrLf & _ "<!ATTLIST Documento ID ID #IMPLIED>" & vbCrLf & _ "]>" temps = header & vbCrLf & xmlStr WriteFileFromString xmlnewfile, temps Debug.Print "Saved temp DTE file '" & xmlnewfile & "'" ' Return the XML doc as a string (without the extra DOCTYPE header) ProcessDte = xmlStr End Function ''' <summary> ''' Create the Signature element to be inserted in <c><Signature>@!SIGNATURE!@</Signature></c>placeholder. ''' </summary> ''' <param name="xmldata">XML data in byte array including element-to-be-signed</param> ''' <param name="docid">ID of element to be signed</param> ''' <param name="elemName">Name of element to be signed</param> ''' <param name="sbPriKey">RSA private signing key as internal string</param> ''' <param name="certStr">User's signing certificate as a base64 string</param> ''' <returns>String containing the completed Signature element</returns> ''' <remarks>Example element-to-be-signed: <c>Documento ID="Ejemplo_F101T39"</c> ''' => <c>Reference URI="#Ejemplo_F101T39"</c> ''' </remarks> Public Function MakeSignature(xmlData() As Byte, docid As String, elemName As String, priKeyStr As String, certStr As String) As String Dim nDataLen As Long Dim nChars As Long Dim sig As String Dim digval As String Dim sigval As String Dim doc As String Dim nsigs As Long Dim siref As String Dim b() As Byte Dim lpDig() As Byte Dim xs As String ' Get Signature template sig = SignatureTemplate() ' 1. Insert all required values in the SignedInfo element ' 1.1 Insert docid in the Signature element @!DOCID!@ sig = Replace(sig, "@!DOCID!@", docid) ' Compute digest value for C14N of element-to-be-signed nDataLen = cnvBytesLen(xmlData) digval = sc14nBytes2Digest(xmlData, nDataLen, elemName, "", SC14N_TRAN_SUBSETBYTAG Or sc14n_DIGALG Or sc14n_TRANMETHOD) Debug.Print "DigestValue=" & digval Debug.Assert Len(digval) > 0 ' 1.2 Insert DigestValue in the Signature element @!DIGVAL!@ sig = Replace(sig, "@!DIGVAL!@", digval) ' Compute digest of SignedInfo ' Need to include entire document with all parent namespaces to propagate down to SignedInfo ' Make a temp string of entire document so we can insert the partially-made Signature element into it doc = Utf8BytesToString(xmlData) doc = Replace(doc, SIGPLACE, sig) ' Count number of Signature elements in doc - we want the last one nsigs = xmlsqCount(doc, "//Signature", 0) Debug.Assert nsigs > 0 siref = "SignedInfo[" & nsigs & "]" Debug.Print "siref=" & siref ' Now back to a temp byte array to perform C14N on SignedInfo b = Utf8BytesFromString(doc) digval = sc14nBytes2Digest(b, cnvBytesLen(b), siref, "", SC14N_TRAN_SUBSETBYTAG Or sc14n_DIGALG Or sc14n_TRANMETHOD) Debug.Print "Digest(" & siref & ")=" & digval Debug.Assert Len(digval) > 0 ' Compute signature value using digest of data lpDig = cnvBytesFromB64Str(digval) sigval = sigSignData(lpDig, priKeyStr, "", "", pki_SIGALG Or PKI_SIG_USEDIGEST) Debug.Print "Signature=" & sigval Debug.Assert Len(sigval) > 0 ' Insert in Signature string sig = Replace(sig, "@!SIGVAL!@", vbCrLf & Wrap(sigval) & vbCrLf) ' Insert all remaining values into the Signature string ' (NB these do not affect the SignatureValue) ' Extract and substitute RSAKeyValue components xs = rsaKeyValue(priKeyStr, "Modulus", 0) sig = Replace(sig, "@!RSA-MOD!@", vbCrLf & Wrap(xs) & vbCrLf) xs = rsaKeyValue(priKeyStr, "Exponent", 0) sig = Replace(sig, "@!RSA-EXP!@", xs) ' Insert the cert string after line wrapping xs = vbCrLf & Wrap(certStr) & vbCrLf sig = Replace(sig, "@!CERTIFICATE!@", xs) ' Return the Signature string MakeSignature = sig End Function ''' <summary> ''' Template for Signature element. ''' </summary> ''' <returns>Signature template string.</returns> ''' <remarks>Hard-coded algorithms here must match global default algorithms.</remarks> Public Function SignatureTemplate() As String Dim s As String s = "<Signature xmlns=""http://www.w3.org/2000/09/xmldsig#"">" & vbCrLf & _ "<SignedInfo>" & vbCrLf & _ "<CanonicalizationMethod Algorithm=""http://www.w3.org/TR/2001/REC-xml-c14n-20010315""/>" & vbCrLf & _ "<SignatureMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#rsa-sha1""/>" & vbCrLf & _ "<Reference URI=""#@!DOCID!@"">" & vbCrLf & _ "<Transforms>" & vbCrLf & _ "<Transform Algorithm=""http://www.w3.org/TR/2001/REC-xml-c14n-20010315""/>" & vbCrLf & _ "</Transforms>" & vbCrLf & _ "<DigestMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#sha1""/>" & vbCrLf & _ "<DigestValue>@!DIGVAL!@</DigestValue>" & vbCrLf & _ "</Reference>" & vbCrLf & _ "</SignedInfo>" & vbCrLf & _ "<SignatureValue>@!SIGVAL!@</SignatureValue>" & vbCrLf & _ "<KeyInfo>" & vbCrLf & _ "<KeyValue>" & vbCrLf & _ "<RSAKeyValue>" & vbCrLf & _ "<Modulus>@!RSA-MOD!@</Modulus>" & vbCrLf & _ "<Exponent>@!RSA-EXP!@</Exponent>" & vbCrLf & _ "</RSAKeyValue>" & vbCrLf & _ "</KeyValue>" & vbCrLf & _ "<X509Data>" & vbCrLf & _ "<X509Certificate>@!CERTIFICATE!@</X509Certificate>" & vbCrLf & _ "</X509Data>" & vbCrLf & _ "</KeyInfo>" & vbCrLf & _ "</Signature>" SignatureTemplate = s End Function ' ********* ' UTILITIES ' ********* ''' Wrap a long single-line string at 64 columns Public Function Wrap(singleLineString As String) As String Const columns As Long = 64 Dim rows As Long Dim i As Long Dim index As Long Dim s As String Dim ss As String rows = (Len(singleLineString) + columns - 1) \ columns If rows < 2 Then Wrap = singleLineString Exit Function End If s = "" For i = 0 To rows - 1 index = i * columns + 1 ' one-indexed ss = Mid$(singleLineString, index, columns) If i > 0 Then s = s & vbCrLf & ss Else s = s & ss End If Next Wrap = s End Function ''' Append a string to file stem inside a file name/path. ''' @param strFileName File name/path to be changed, e.g. "C:\dir\subdir\filename.ext" or "filename.ext" ''' @param strAppendage String to append to file stem, e.g. "-appendme" ''' @returns New file name with appendage, e.g. "C:\dir\subdir\filename-appendme.ext" ''' @remark Always returns a full absolute path. Public Function AppendToFileStem(strFileName As String, strAppendage As String) As String Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim filefullpath As String Dim filestem As String Dim dirname As String Dim extn As String Dim newfilename As String filefullpath = fso.GetAbsolutePathName(strFileName) 'Debug.Print filefullpath filestem = fso.GetBaseName(filefullpath) 'Debug.Print filestem extn = fso.GetExtensionName(filefullpath) 'Debug.Print extn dirname = fso.GetParentFolderName(filefullpath) 'Debug.Print dirname newfilename = fso.BuildPath(dirname, filestem + strAppendage + "." & extn) 'Debug.Print newfilename AppendToFileStem = newfilename End Function Public Function CollectionToArray(myCol As Collection) As Variant ' Acknowledgments to Vityata ' Ref: https://stackoverflow.com/questions/29015444/how-to-join-a-collection-in-vba Dim result As Variant Dim cnt As Long ReDim result(myCol.Count - 1) For cnt = 0 To myCol.Count - 1 result(cnt) = myCol(cnt + 1) Next cnt CollectionToArray = result End Function ' ************** ' FILE UTILITIES ' ************** Private Function ReadFileIntoString(sFilePath As String) As String ' Reads file (if it exists) into a string. Dim strIn As String Dim hFile As Integer ' Check if file exists If Len(Dir(sFilePath)) = 0 Then Exit Function End If hFile = FreeFile Open sFilePath For Binary Access Read As #hFile strIn = Input(LOF(hFile), #hFile) Close #hFile ReadFileIntoString = strIn End Function Private Function ReadFileIntoBytes(sFilePath As String) As Byte() ' Reads file (if it exists) into a byte array. Dim abIn() As Byte Dim hFile As Integer ' Check if file exists If Len(Dir(sFilePath)) = 0 Then Exit Function End If hFile = FreeFile Open sFilePath For Binary Access Read As #hFile abIn = InputB(LOF(hFile), #hFile) Close #hFile ReadFileIntoBytes = abIn End Function Private Function WriteFileFromString(sFilePath As String, strIn As String) As Boolean ' Creates a file from a string. Clobbers any existing file. On Error GoTo OnError Dim hFile As Integer If Len(Dir(sFilePath)) > 0 Then Kill sFilePath End If hFile = FreeFile Open sFilePath For Binary Access Write As #hFile Put #hFile, , strIn Close #hFile WriteFileFromString = True Done: Exit Function OnError: Resume Done End Function Private Function WriteFileFromBytes(sFilePath As String, abData() As Byte) As Boolean ' Creates a file from a string. Clobbers any existing file. On Error GoTo OnError Dim hFile As Integer If Len(Dir(sFilePath)) > 0 Then Kill sFilePath End If hFile = FreeFile Open sFilePath For Binary Access Write As #hFile Put #hFile, , abData Close #hFile WriteFileFromBytes = True Done: Exit Function OnError: Resume Done End Function