Export Pictures Excel VBA in original resolution

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: https://i.sstatic.net/fajQC.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