Option Explicit
Sub Test()
Dim XML As CustomXMLPart
For Each XML In ThisWorkbook.CustomXMLParts
If Not XML.BuiltIn Then Call XML.Delete
Next
Call AddFileToPackage(Environ$("userprofile") & "\Desktop\the_file.bla")
Call SavePackageFile("the_file.bla", Environ$("userprofile") & "\Documents\")
End Sub
Public Sub SavePackageFile(Name As String, Path As String)
Dim objXMLPart As Office.CustomXMLPart
Dim objXMLNode As Office.CustomXMLNode
On Error Resume Next
Set objXMLPart = ThisWorkbook.CustomXMLParts("internal:filepackage")
On Error GoTo 0
If objXMLPart Is Nothing Then
Exit Sub
End If
Set objXMLNode = objXMLPart.SelectSingleNode("//file[@name='" & Name & "']")
Dim Data() As Byte
Dim strPath As String: strPath = Path
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
Call WriteFileB(Base64ToData(objXMLNode.text), strPath & Name)
End Sub
Public Sub AddFileToPackage(Filename As String)
Dim Base64 As String
Base64 = DataToBase64(ReadFileB(Filename))
Dim objXMLPart As Office.CustomXMLPart
Dim objPackage As Office.CustomXMLNode
Dim objNode As Office.CustomXMLNode
On Error Resume Next
Set objXMLPart = ThisWorkbook.CustomXMLParts("internal:filepackage")
On Error GoTo 0
If objXMLPart Is Nothing Then
Set objXMLPart = ThisWorkbook.CustomXMLParts.Add("<CustomFilePackage xmlns='internal:filepackage' />")
End If
Set objPackage = objXMLPart.DocumentElement
Call objPackage.AppendChildNode("file", NodeValue:=Base64)
Set objNode = objPackage.ChildNodes(objPackage.ChildNodes.Count)
Call objNode.AppendChildNode("name", , msoCustomXMLNodeAttribute, Right$(Filename, Len(Filename) - InStrRev(Filename, "\")))
End Sub
Public Function ReadFileB(Filename As String) As Byte()
With CreateObject("ADODB.Stream")
Call .Open
.Type = 1
Call .LoadFromFile(Filename)
ReadFileB = .Read()
Call .Close
End With
End Function
Public Sub WriteFileB(Data() As Byte, Filename As String)
With CreateObject("ADODB.Stream")
Call .Open
.Type = 1
Call .Write(Data)
Call .SaveToFile(Filename, 2)
Call .Close
End With
End Sub
Public Function DataToBase64(Data() As Byte) As String
With CreateObject("MSXML2.DOMDocument")
With .CreateElement("base64")
.DataType = "bin.base64"
.nodeTypedValue = Data
DataToBase64 = .text
End With
End With
End Function
Public Function Base64ToData(Base64 As String) As Byte()
With CreateObject("MSXML2.DOMDocument")
With .CreateElement("base64")
.DataType = "bin.base64"
.text = Base64
Base64ToData = .nodeTypedValue
End With
End With
End Function