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