Export Pictures Excel VBA in original resolution - excel

Question

This solution: Export Pictures Excel VBA
Works just fine, but it's using a chart method that's being resized to the images inside the table to "screenshot" them(in my case even including the table borders), not actually exporting the images themselves.
When I get the images by converting the excel table to a html file, they even come in better resolution in the folder.
Is there a way to get the images themselves, with their original resolution instead using VBA(obviously I don't just need the pictures, otherwise I'd be content with the html conversion method)?
What I mean can be seen here: http://i.imgur.com/OUX9Iji.png The picture on the left is what I get using the html conversion method, the picture on the right is what I get using the chart method. As you can see the chart method just screenshots the picture within the excel table, and I need it to get the original picture like on the left.

Answer 1

As the newer filetypes .xlsm and .xlsx is actually a zip file, it's possible to have the workbook save a copy of itself and change the extension from .xlsm to .zip. From there, it can look inside the zip's xl/media folder and copy out the actual image files which will include metadata, etc.
For my purposes, since it changes the image filename (not filetype) inside the zip, I'm working on how to be more specific about renaming the image files based on workbook content (i.e., their placement in the workbook) as I copy them out for the user.
But yes, screenshots are not nearly as good as the real files and this method does it. This sub took me quite some time to write but I'm sure will be used by many!
Private Sub ExtractAllPhotosFromFile()
Dim oApp As Object, FileNameFolder As Variant, DestPath As String
Dim num As Long, sZipFile As String, sFolderName As String ', iPos As Long, iLen As Long
Dim vFileNameZip As Variant, strTmpFileNameZip As String, strTmpFileNameFld As String, vFileNameFld As Variant
Dim FSO As Object, strTmpName As String, strDestFolderPath As String
On Error GoTo EarlyExit
strTmpName = "TempCopy"
' / Check requirements before beginning / /
'File must be .xlsm
If Right(ActiveWorkbook.FullName, 5) <> ".xlsm" Then
MsgBox ("This function cannot be completed because the filetype of this workbook has been changed from its original filetype of .xlsm" _
& Chr(10) & Chr(10) & "Save as a Microsoft Excel Macro-Enabled Workbook (*.xlsm) and try again.")
Exit Sub
End If
'User to choose destination folder
strDestFolderPath = BrowseFolder("Choose a folder to Extract the Photos into", ActiveWorkbook.Path, msoFileDialogViewDetails)
If strDestFolderPath = "" Then Exit Sub
If Right(strDestFolderPath, 1) <> "\" Then strDestFolderPath = strDestFolderPath & "\"
'Prepare vars and Tmp destination
strTmpFileNameZip = Environ("Temp") & "\" & strTmpName & ".zip"
strTmpFileNameFld = Environ("Temp") & "\" & strTmpName
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTmpFileNameFld) Then
FSO.deletefolder strTmpFileNameFld
End If
If FSO.FileExists(strTmpFileNameZip) Then
Kill strTmpFileNameZip
End If
Set FSO = Nothing
'Save current workbook to Temp dir as a zip file
Application.StatusBar = "Saving copy of file to temp location as a zip"
ActiveWorkbook.SaveCopyAs Filename:=strTmpFileNameZip
'Create a folder for the contents of the zip file
strTmpFileNameFld = strTmpFileNameFld & "\"
MkDir strTmpFileNameFld
'Pass String folder path variables to Variant type variables
vFileNameFld = strTmpFileNameFld
vFileNameZip = strTmpFileNameZip
'Count files/folders inside the zip
Set oApp = CreateObject("Shell.Application")
num = oApp.Namespace(vFileNameZip).Items.Count
If num = 0 Then 'Empty Zip
GoTo EarlyExit 'Skip if somehow is empty as will cause errors
Else
'zip has files, copy out of zip into tmp folder
Application.StatusBar = "Copying items from temp zip file to folder"
oApp.Namespace(vFileNameFld).CopyHere oApp.Namespace(vFileNameZip).Items
End If
'Copy the image files from the tmp folder to the Dest folder
Application.StatusBar = "Moving Photos to selected folder"
strTmpFileNameFld = strTmpFileNameFld & "xl\media\"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.jpeg"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.jpg"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.png"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.bmp"
'Function complete, cleanup
'Prepare vars and Tmp destination
Application.StatusBar = "Cleaning up"
strTmpFileNameZip = Environ("Temp") & "\" & strTmpName & ".zip"
strTmpFileNameFld = Environ("Temp") & "\" & strTmpName
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTmpFileNameFld) Then
FSO.deletefolder strTmpFileNameFld
End If
If FSO.FileExists(strTmpFileNameZip) Then
Kill strTmpFileNameZip
End If
Application.StatusBar = False
MsgBox ("Photos extracted into the folder: " & strDestFolderPath)
Set oApp = Nothing
Set FSO = Nothing
Exit Sub
EarlyExit:
Application.StatusBar = False
Set oApp = Nothing
Set FSO = Nothing
MsgBox ("This function could not be completed.")
End Sub
I moved the copy to it's own sub to save space on how I filtered filetypes, not the best way but works
Private Sub CopyFiles(strFromPath As String, strToPath As String, FileExt As String)
'As function to get multiple filetypes
Dim FSO As Object
If Right(strFromPath, 1) <> "\" Then strFromPath = strFromPath & "\"
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.MoveFile Source:=strFromPath & FileExt, Destination:=strToPath
Set FSO = Nothing
On Error GoTo 0
End Sub
I found this stable function online to select a destination folder, was actually difficult to find a good solid one.
Private Function BrowseFolder(Title As String, Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = msoFileDialogViewList) As String
'Used for the Extract Photos function
Dim V As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
V = .SelectedItems(1)
If Err.Number <> 0 Then
V = vbNullString
End If
End With
BrowseFolder = CStr(V)
End Function