以原始分辨率导出图片 Excel VBA

Question

这个解决方案：Export Pictures Excel VBA

工作得很好，但它使用了一种图表方法，它被调整为表格内的图像以“截屏”它们（在我的情况下甚至包括表格边框），而不是实际导出图像本身。

当我通过将 excel 表格转换为 html 文件来获取图像时，它们在文件夹中的分辨率甚至更高。

有没有办法以原始分辨率而不是使用 VBA 来获取图像本身（显然我不只需要图片，否则我会满足于 html 转换方法）？

我的意思可以看这里：http://i.imgur.com/OUX9Iji.png左图是我使用html转换方法得到的，右图是我使用图表方法得到的。如您所见，图表方法只是对excel表格中的图片进行截图，我需要它来获取左侧的原始图片。

Answer 1

由于较新的文件类型 .xlsm 和 .xlsx 实际上是一个 zip 文件，因此可以让工作簿保存自己的副本并将扩展名从 .xlsm 更改为 .zip。从那里，它可以查看 zip 的 xl/media 文件夹并复制出包含元数据等的实际图像文件。

出于我的目的，由于它更改了 zip 中的图像文件名（不是文件类型），我正在研究如何更具体地根据工作簿内容（即它们在工作簿中的位置）重命名图像文件为我将它们复制给用户。

但是，是的，屏幕截图不如真实文件好，而这种方法可以做到。这个sub花了我相当长的时间来写，但我肯定会被很多人使用！

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

我将副本移动到它自己的子目录以节省我如何过滤文件类型的空间，这不是最好的方法，但可以工作

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

我在网上找到了这个稳定的选择目标文件夹的功能，实际上很难找到一个好的固体。

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