I am trying to generate the base64 codification of an image (format BASE64;JPEG:/9j/4AAQSkZJRgABAQAA...) from a picture inserted on an Excel sheet and found as a Picture object.
So far, I have something along the lines:
Dim img as Picture
Set img = getPictureInRange("B5")
And I would need something that do
Debug.Print base64decode(img)
I've tried with every option I've found related to VBA, but to no avail.
May I have some help on this matter? or some recommendation?
Thanks
Based on the work of others, I've been able to do what you want to do, but, with a detour. Basically, the script below first exports an image to a file and then reads the file's contents and converts the contents to b64. The only thing you'd need to change to have this script suit your needs is to delete the exported image files.
Rem Based on: https://stackoverflow.com/questions/35223247/how-extract-images-from-excel-sheets
Sub extractImgs()
Dim shp As Shape
Dim tempChart As String, wsName As String, fileName As String, b64encoded As String
wsName = ActiveSheet.Name
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Select
Charts.Add
ActiveChart.Location xlLocationAsObject, wsName
ActiveChart.ChartArea.Height = shp.Height
ActiveChart.ChartArea.Width = shp.Width
tempChart = Mid(ActiveChart.Name, Len(wsName) + 2, 100)
shp.Copy
ActiveChart.Paste
Rem Change the directory to store your images
fileName = "E:\Temporary\images\Product-C" & shp.TopLeftCell.Column & "-R" & shp.TopLeftCell.Row & ".JPG"
ActiveChart.Export fileName:=fileName, FilterName:="jpg"
ActiveSheet.Shapes(tempChart).Delete
Debug.Print shp.Name & ": " & shp.TopLeftCell.Column & "/" & shp.TopLeftCell.Row & "(" & shp.TopLeftCell.Offset(0, 1).Value & ")"
Rem Get the file's contents and encode them
b64encoded = EncodeFile(fileName)
Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column + 2) = b64encoded
End If
Next
End Sub
Rem Source: https://stackoverflow.com/questions/2043393/convert-image-jpg-to-base64-in-excel-vba
Public Function EncodeFile(strPicPath As String) As String
Const adTypeBinary = 1 ' Binary file is encoded
Dim objXML, objDocElem, objStream
' Open data stream from picture
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.LoadFromFile (strPicPath)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.DataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
EncodeFile = objDocElem.Text
' Clean all
Set objXML = Nothing
Set objDocElem = Nothing
Set objStream = Nothing
End Function
Although the answer above works, there are some caveats I encountered while trying to generate product data which could be imported into Odoo. The first was not immediately obvious but Odoo started complaining that the base64 data was invalid. After some troubleshooting, I found that this was due to a limitation in Excel which restricts the size of a cell's content to 32KB of data. So, since a number of my images were exceeding this, the validate phase of the import failed accordingly. In order to work around this, I chose to generate a CSV file directly from within VBA.
Secondly, the MSXML library adds line feeds every 72 characters. Although as per specification, a base 64 decode should ignore characters like this, the CSV format certainly was not compatible. So, the script was modified to remove all line feeds as well.
The updated script which generates a file which can be directly imported into Odoo, is listed below:
Sub extractImgs()
Dim shp As Shape
Dim tempChart As String, wsName As String
Dim csvFileName As String, imageFileName As String, b64encoded As String, line As String
Dim header(0 To 19) As Variant, fields(0 To 19) As Variant
header(0) = "Active"
header(1) = "Barcode"
header(2) = "Can be Sold"
header(3) = "Can be Purchased"
header(4) = "Cost"
header(5) = "Favorite"
header(6) = "Internal Reference"
header(7) = "Name"
header(8) = "Quantity On Hand"
header(9) = "Image"
header(10) = "Description"
header(11) = "Point of Sale Category"
header(12) = "Product Category"
header(13) = "Product Tags"
header(14) = "Product Type"
header(15) = "Responsible"
header(16) = "Sales Price"
header(17) = "Type"
header(18) = "Unit of Measure"
header(19) = "Purchase UoM"
fields(0) = "TRUE" 'Active
fields(1) = "" 'Barcode
fields(2) = "FALSE" 'Can be Sold'
fields(3) = "TRUE" 'Can be Purchased
fields(4) = "1,000.00" 'Cost
fields(5) = "Normal" 'Favorite
fields(6) = "" 'Internal Reference
' 7 = Name = "Name"
' 8 = QuantityOnHand = "Quantity On Hand"
' 9 = Image = "Image"
' 10 = Description = "Description"
fields(11) = "" 'Point of Sale Category
fields(12) = "All / Buyable / Packaging" 'Product Category
fields(13) = "" 'Product Tags
fields(14) = "Storable Product" 'Product Type
fields(15) = "Purchasing" 'Responsible
fields(16) = "1.00" 'Sales Price
fields(17) = "Storable Product" 'Type
fields(18) = "Units" 'Unit of Measure
fields(19) = "Units" 'Purchase UoM
wsName = ActiveSheet.Name
csvFileName = "E:\Temporary\exported-products.csv"
Open csvFileName For Output As #1
Call WriteLine(header)
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
shp.Select
Charts.Add
ActiveChart.Location xlLocationAsObject, wsName
ActiveChart.ChartArea.Height = shp.Height
ActiveChart.ChartArea.Width = shp.Width
tempChart = Mid(ActiveChart.Name, Len(wsName) + 2, 100)
shp.Copy
ActiveChart.Paste
imageFileName = "E:\Temporary\images\Product-C" & shp.TopLeftCell.Column & "-R" & shp.TopLeftCell.Row & ".JPG"
ActiveChart.Export fileName:=imageFileName, FilterName:="jpg"
ActiveSheet.Shapes(tempChart).Delete
Debug.Print shp.Name & ": " & shp.TopLeftCell.Column & "/" & shp.TopLeftCell.Row & "(" & shp.TopLeftCell.Offset(0, 1).Value & ")"
b64encoded = EncodeFile(imageFileName)
' Excel is limited to 32KB per cell so, outputting data as CSV instead.
' Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column + 2) = b64encoded
fields(7) = Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column - 3)
fields(8) = Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column - 2)
fields(9) = b64encoded
fields(10) = Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column - 1)
Call WriteLine(fields)
End If
Next
Close #1
End Sub
Public Function EncodeFile(strPicPath As String) As String
Const adTypeBinary = 1 ' Binary file is encoded
Dim objXML, objDocElem, objStream
' Open data stream from picture
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.LoadFromFile (strPicPath)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.DataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
' Removing newline even though it is allowed
' CSV format still requires this.
' https://stackoverflow.com/questions/41837881/base64-encode-with-stream-stringtobinary-inserts-a-newline-breaking-the-string
' b64EncodedData = Replace(objDocElem.Text, vbLf, "")
EncodeFile = Replace(objDocElem.Text, vbLf, "")
' Clean all
Set objXML = Nothing
Set objDocElem = Nothing
Set objStream = Nothing
End Function
Public Sub WriteLine(ByRef myData As Variant)
Dim line
line = ""
For Index = LBound(myData) To UBound(myData) - 1
line = line + Chr(34) & myData(Index) & Chr(34) & ","
Next
line = line + Chr(34) & myData(UBound(myData)) & Chr(34)
Print #1, line
End Sub