Question

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

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

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

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

Answer 1

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

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

但是，是的，截图并不像真实文件那样好，而且这种方法可以做到。这篇文章花了我一些时间来写，但我确信会被许多人使用！

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

以原始分辨率

1 个答案: