I have manually inserted this file “ABC.exe” as an Object in excel workbook in sheet name e.g “Board”.
In NameBox the Object has name Object 1 and in Formula Bar =EMBED("Packager Shell Object","")
I can manually right-click on the cited object and choose Copy and then Paste on a predefined folder without any issue or warning message.
I need to automate the process of (Copy and Paste) using VBA.
This code copy the OLeObject to Clipboard successfully:
Sub Copy_OleObject_to_Clipboard()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim ole As OLEObject
Set ole = ws.OLEObjects(1)
ole.Copy
End Sub
Indeed, I also have tried ChatGPT , But none of his answers have worked correctly.
Please, try the next solution. I adapted a piece of code returning embedded pdf files and maybe some comments remained related to its previous scope.
After embedding the EXE files use 'Alt Text' from the right click object context menu (formatObject...) , and place there the EXE file name.
The workbook where from to be extracted embedded EXE files, must be closed. The following code warns about it if you do not take care...
Since, as stated above, the workbook having embedded exe files must be closed, the next code must be copied in a xlsm, xlsb, xlsa file and run it from there. Basically, it saves a copy of the workbook, but with zip extension (in fact workbook type xlsx, xlsm, xlsa etc. are such archives containing many xml files and objects. The code firstly extracts the files from archive \xl\worksheets, processes them to extract a logical association between the bin files in \xl\embeddings and the EXE name extracted from worksheets xml files. Then, it binary open the found bin files, and processes them to become correct EXE files.
Please, create a Public variable on top of a standard module (in the declarations area):
Public ExpArr()
Sub ExtractEmbeddedEXEFiles()
Dim retFolder As String, embWB As String, zipName As String, oShell As Object, arrO, i As Long
retFolder = ThisWorkbook.Path & "\Extracted Embeded EXE files" 'folder where to process and return extracted exe files
embWB = ThisWorkbook.Path & "\EXE Embedded wb.xlsm" 'wb containing embedded exe file(s) full name
ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\EXE Embedded wb.xlsm"
zipName = left(embWB, InStrRev(embWB, ".")) & "zip"
If Dir(retFolder, vbDirectory) = "" Then 'if the folder where to save EXE files does not exist
MkDir retFolder 'it is created
End If
'Deleting any previously created files, if any:
On Error Resume Next
Kill zipName
Kill retFolder & "\*.*"
Kill retFolder & "\_rels\*.*"
RmDir retFolder & "\_rels\"
On Error GoTo 0
'Copy/rename the Excel file changing extension to zip:
On Error Resume Next
FileCopy embWB, zipName
If Err.number = 70 Then 'error in case of workbook being open:
Err.Clear: On Error GoTo 0
MsgBox "Please, close the workbook where from the embedded EXE files to be extracted." & vbCrLf & _
"A zipped copy cannot be created...", vbInformation, "Need to close the workbook": Exit Sub
End If
On Error GoTo 0
Dim flsWsh As Object, fileNameInZip As Variant
Set oShell = CreateObject("Shell.Application")
Set flsWsh = oShell.NameSpace(oShell.NameSpace((zipName)).Items.item(("xl\worksheets")))
For Each fileNameInZip In oShell.NameSpace(flsWsh).Items
oShell.NameSpace((retFolder)).CopyHere _
oShell.NameSpace(flsWsh).Items.item(CStr(fileNameInZip))
Next
getOLEObjSheetsREL retFolder 'build the array which matches any .bin oleObject with the extracted EXE name
For i = 0 To UBound(ExpArr) 'copy the bin file in a separate place
arrO = Split(ExpArr(i), "|") 'split the matching array elements by "|" to extract bin name in relation with EXE name
oShell.NameSpace((retFolder)).CopyHere oShell.NameSpace((zipName)).Items.item("xl\embeddings\" & arrO(0))
ReadAndWriteExtractedBinFile_Exe retFolder & "\" & arrO(0), retFolder, CStr(arrO(1))
Next i
On Error Resume Next 'clear the working folder, to remain only extracted exe files
Kill zipName
Kill retFolder & "\*.bin"
Kill retFolder & "\*.xml"
Kill retFolder & "\_rels\*.*"
RmDir retFolder & "\_rels\"
On Error GoTo 0
MsgBox "Ready..."
shell "explorer.exe" & " " & retFolder, vbNormalFocus
End Sub
Sub ReadAndWriteExtractedBinFile_Exe(s As String, TmpPath, Optional pdfName As String = "")
Dim byteFile As Long, byt As Byte, fileName As String, firstByte As Long, lastByte As Long
Dim MyAr() As Byte, NewAr() As Byte, i As Long, j As Long, k As Long
byteFile = FreeFile: j = 1
Dim fLen As Long: fLen = FileLen(s)
ReDim MyAr(1 To fLen + 1)
Open s For Binary Access Read As byteFile 'Open the bin file
Do While Not EOF(byteFile) 'loop untill the last line (count the file bytes)
Get byteFile, , byt
MyAr(j) = byt: j = j + 1
If j > 7 Then
If Hex(MyAr(j - 4)) = "4D" And Hex(MyAr(j - 3)) = "5A" And _
Hex(MyAr(j - 2)) = 90 And MyAr(j - 1) = 0 Then
firstByte = j - 4: ' first byte to be used in the returned byte array
End If
If MyAr(j - 6) = 0 And MyAr(j - 5) = 0 And MyAr(j - 4) = 0 And _
Hex(MyAr(j - 3)) = 43 And MyAr(j - 2) = 0 And Hex(MyAr(j - 1)) = "3A" Then
lastByte = j - 2: Exit Do 'last byte to be used
End If
End If
Loop
Close byteFile
Dim oStream As Object 'solution to speed up writing the binary array...
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
'build the correct byte array without bytes up to exe file real start:
ReDim NewAr(1 To lastByte - firstByte + 1)
k = 1
For j = firstByte To lastByte
NewAr(k) = MyAr(j): k = k + 1
Next j
oStream.Write NewAr
'byteFile = FreeFile
'Set the exe file to be saved name:
If pdfName = "" Then 'if no pdfName parameter, it builds a unique name:
fileName = TmpPath & "\" & Format(Now, "ddmmyyhhmmss") & ".exe"
Else
fileName = TmpPath & "\" & pdfName 'this solution uses only the extracted (from OLEObject) name
End If
'Write the new (exe) binary file:
If isArrLoaded(NewAr()) Then 'only for EXE (bin) embedded files:
oStream.SaveToFile fileName, 2 ' 2 to overWrite
oStream.Close
Else
'If by mistake a not appropriate bin file has been choosen:
Debug.Print "The object is not of exe type..." 'theoretically, this line should never be reached
End If
End Sub
Private Sub getOLEObjSheetsREL(strPath As String)
Dim patt As String: patt = "oleObject\d{1,3}.bin"
Dim strFold As String, strFile As String, strText As String
Dim fso As Object, ts As Object, arrOLE, arrOLEC(1), arrTot, i As Long
strFold = strPath & "\_rels\" 'copied folder (from archive) keeping sheets and OLEObjects information
ReDim arrTot(0)
strFile = Dir(strFold & "*.rels")
Do While strFile <> "" 'iterate between all existing files
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.getFile(strFold & strFile).OpenAsTextStream(1, -2)
strText = ts.ReadAll 'read their content
ts.Close
arrOLE = getOLEObj(strText, patt) 'extract an array linking OLEObject to EXE file name(s)
If arrOLE(0) <> "" Then
arrOLEC(0) = left(strFile, Len(strFile) - 5): arrOLEC(1) = arrOLE
BubbleSort arrOLEC(1) 'sort the array
arrTot(i) = arrOLEC: i = i + 1: ReDim Preserve arrTot(i)
End If
strFile = Dir()
Loop
ReDim Preserve arrTot(i - 1)
getOLEObjects arrTot, strPath 'returning an array linking the bin object to EXE file(s) to be saved file name
End Sub
Function getOLEObj(strTxt As String, strPatt As String) As Variant
Dim objOccurr As Object, objOcc, arr, k As Long
With CreateObject("vbscript.regexp")
.Global = True 'Get all matches.
.pattern = strPatt 'Search for any string that contains the pattern entered in quotes. .
If .TEST(strTxt) Then
Set objOccurr = .Execute(strTxt)
ReDim arr(objOccurr.count - 1)
For Each objOcc In objOccurr
arr(k) = objOcc: k = k + 1
Next
getOLEObj = arr
Else
getOLEObj = Array("")
End If
End With
End Function
Private Sub getOLEObjects(arrOLE As Variant, strPath As String)
Dim strFile As String, strText As String
Dim fso As Object, ts As Object, j As Long
Dim arr, frstTxt As String, el, i As Long, strName As String, PrID As String
Dim k As Long: ReDim ExpArr(100)
Const strObj As String = "oleObject"
For j = 0 To UBound(arrOLE)
strFile = strPath & "\" & arrOLE(j)(0)
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.getFile(strFile).OpenAsTextStream(1, -2)
strText = ts.ReadAll
ts.Close
arr = extractBetweenChars(strText, "<oleObject progId=", "<\/mc:Fallback>")
For Each el In arr
strName = extractBetweenChars(CStr(el), "altText=""", """ r:id")(0)
PrID = extractBetweenChars(CStr(el), """", """")(0)
If PrID = "Packager Shell Object" Then i = i + 1 'alt raspuns pentru exe
If strName <> "" Then
If InStr(strName, ".exe") > 0 Then 'for exe files
ExpArr(k) = strObj & i & ".bin" & "|" & strName: k = k + 1
End If
End If
Next
Next j
'keep only the elements having values:
If k > 0 Then
ReDim Preserve ExpArr(k - 1)
Else
Erase ExpArr
End If
End Sub
Private Function extractBetweenChars(prevString As String, startCh As String, endCh As String) As Variant
Dim objOccurr As Object, objOcc, arr, k As Long
With CreateObject("vbscript.regexp")
.Global = True 'Get all matches.
.pattern = startCh & "((.|\n)*?)" & endCh 'Search for any string that contains the pattern entered in quotes. .
'if boolglobal then extractbetweenchars =
If .TEST(prevString) Then
Set objOccurr = .Execute(prevString)
ReDim arr(objOccurr.count - 1)
For Each objOcc In objOccurr
arr(k) = objOcc.subMatches(0): k = k + 1
'arr(k) = Replace(Replace(objOcc, startCh, ""), Replace(endCh, "\", ""), ""): k = k + 1
Next
extractBetweenChars = arr
Else
'Debug.Print "Not matched"
extractBetweenChars = Array("")
End If
End With
End Function
Private Function isArrLoaded(arr() As Byte) As Boolean
If Not Not arr() Then isArrLoaded = True
End Function
Private Sub BubbleSort(arr)
Dim i As Long, j As Long, temp
For i = LBound(arr) To UBound(arr) - 1
For j = i + 1 To UBound(arr)
If arr(i) > arr(j) Then
temp = arr(i): arr(i) = arr(j)
arr(j) = temp
End If
Next j
Next i
End Sub
Please, test it and send some feedback.
I tested on two embedded EXE files and it was able to return them. I did not test it extensively, so I need your feedback. I tried finding HEX elements to extract only the necessary part from the bin files in order to rebuild the EXE file.
It worked in my those two cases...
Since is a big code and some Sub(s), Functions exist in different modules I maybe missed something. I do not think so, but it may not be impossible...
Edited:
Please, test this simpler way able to extract the embedded object as it was embedded. I mean, even without extension...
Even if I think that this method will not be considered by your antivirus as a threat. Is looks as a simple copy - paste action. But this is just a supposition.
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Sub Extract_All_EmbededObjectsFromClipboard() 'It works...
Dim strPath As String: strPath = ThisWorkbook.Path & "\Embedded Objects" 'the folder where to return the extracted file
If Dir(strPath, vbDirectory) = "" Then 'if the folder where to save EXE files does not exist
MkDir strPath 'it is created
End If
Dim oleObj As OLEObject, boolOK As Boolean
For Each oleObj In ActiveSheet.OLEObjects
oleObj.Copy
boolOK = EmbededObjectFromClipboard(strPath)
Next oleObj
RenameEXEFiles strPath
If boolOK Then
Shell "explorer.exe" & " " & strPath, vbNormalFocus
End If
End Sub
Sub RenameEXEFiles(strPath As String) ' it works only for extracted EXE files (to place ".exe" if it is missing
Dim fileName As String
fileName = Dir(strPath & "\*.*")
Do While fileName <> ""
Debug.Print fileName
If Right(fileName, 4) <> ".exe" Then
If FileExists(strPath & "\" & fileName & ".exe") Then
Name strPath & "\" & fileName As strPath & "\" & fileName & "_.exe"
Else
Name strPath & "\" & fileName As strPath & "\" & fileName & ".exe"
End If
End If
fileName = Dir
Loop
End Sub
Private Function FileExists(ByVal fname As String) As Boolean
On Error Resume Next
FileExists = ((GetAttr(fname) And vbDirectory) <> vbDirectory)
On Error GoTo 0: Err.Clear
End Function
Function EmbededObjectFromClipboard(DestinationFolder As String) As Boolean
EmbededObjectFromClipboard = False
If Not CBool(IsClipboardFormatAvailable(49162)) Then Exit Function '49162 is Format ID for Embeded Object!
CreateObject("Shell.Application").Namespace(CVar(DestinationFolder)).Self.InvokeVerb "Paste"
EmbededObjectFromClipboard = True
End Function
And run TestEmbededObjectFromClipboard. It will copy the "Object `" embedded file to the nominated folder. Even if does not have any extension. It looks copying binary...
The updated code add ".exe" to the extracted files, if they do not have it... But is should be obvious that it works only if you try extracting EXE files. Without extension there is no VBA method to understand what kind of file is it about. Or, it is very complicated (binary reading the file and search for some markers...)...
Edited again:
A way to return all files from a folder is the next one:
Private Function getAllFiles(strFold As String, Optional strExt As String = "*.*") As Variant
Dim arrD
arrD = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & strFold & strExt & """ /b").StdOut.ReadAll, vbCrLf)
arrD(UBound(arrD)) = "@@##": arrD = Filter(arrD, "@@##", False) 'remove the last (empty) array elem
getAllFiles = arrD
End Function
'a sub to test it:
Sub testGetAllFiles()
Debug.Print Join(getAllFiles(ThisWorkbook.Path & "\"), vbCrLf)
End Sub