将图像粘贴到 Excel 后裁剪图像

Posted 2023-02-25

【中文标题】将图像粘贴到 Excel 后裁剪图像

【英文标题】：Cropping image after pasting it into Excel

【发布时间】：2020-02-12 07:26:26

【问题描述】：

以下是我在 Excel VBA 中尝试过的内容。将图像粘贴到 Excel 中效果很好，但我需要裁剪它们。

下面的代码代表了尝试：

Option Explicit

Sub PDF_To_Excel()
Dim setting_sh As Worksheet
Set setting_sh = ThisWorkbook.Sheets("Setting")
Dim pdf_path As String
Dim excel_path As String

pdf_path = Application.GetOpenFilename(FileFilter:="PDF Files (*.PDF), *.PDF", Title:="Select File To Be Opened")

excel_path = setting_sh.Range("E12").Value

Dim objFile As File
Dim sPath As String
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Set objFile = fso.GetFile(pdf_path)
sPath = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name))
Set fo = fso.GetFolder(sPath)
Dim wa As Object
Dim doc As Object
Dim wr As Object

Set wa = CreateObject("word.application")
'Dim wa As New Word.Application
wa.Visible = False
'Dim doc As Word.Document
Dim nwb As Workbook
Dim nsh As Worksheet
'Dim wr As Word.Range

For Each f In fo.Files
    Set doc = wa.documents.Open(f.Path, False, Format:="PDF Files")
    Set wr = doc.Paragraphs(1).Range
    wr.WholeStory

    Set nwb = Workbooks.Add
    Set nsh = nwb.Sheets(1)
    wr.Copy
    nsh.Paste

    Dim oILS As InlineShape
    Set oILS = Selection.InlineShapes(1)
    With oILS
        .PictureFormat.CropLeft = 100
        .PictureFormat.CropTop = 100
        .PictureFormat.CropRight = 100
        .PictureFormat.CropBottom = 100
    End With
    With oILS
        .LockAspectRatio = True
    '    .Height = 260
    '    .Width = 450
    End With

    nwb.SaveAs (excel_path & "\" & Replace(f.Name, ".pdf", ".xlsx"))

    doc.Close True
    nwb.Close True

Next

wa.Quit
End Sub

我得到这个错误：

“运行时错误 438 对象不支持此属性或方法”

在下面一行：

Set oILS = Selection.InlineShapes(1)

它目前将 PDF 转换为 Word 文档，然后将它们粘贴到 Excel 文件中。但我需要在所有 Excel 文件中裁剪图像。

【问题讨论】：

我认为您的问题是 InlineShapes 对象是 Word 对象。因此，使用它来引用 Excel 文件中的某些内容可能不起作用。

嘿，我没有看到您在引用选择的行之前选择任何内容。也许您可以更改给您带来麻烦的行，以避免使用 ".selection" ？在 Excel 中，inlineshapes 对我也不起作用，Excels 编译器无法识别它？不知道如果那是我的错。无论如何，Set oILS = nsh.Shapes(1) 有效吗？

@Beek 我从工具中引用了 MS Office 16.0 对象，但仍然有同样的问题。还有其他想法吗？

我的评论建议将 .selection 行更改为引用第一个形状的内容。但是对于更易读的示例，请参阅我的“答案”。我想我们只需要找到一个参考您添加的图片的好方法。引用它的方式取决于您的需要。但我认为引用 Excel 工作表上的最后一个形状可能有用吗？

@nytro：我认为@Czeskleba 在下面为您提供了正确的答案。如果您将 dim oILS As InlineShape 更改为 dim oILS As Shape

【参考方案1】：

我在 Word 文档中添加了一张图片，然后手动将其复制到 Excel 中。只是将暗淡更改为形状，而给您带来麻烦的参考对我来说有点工作。我无法重现您的代码的前半部分，将 pdf 制作成 word 文档并显示可复制的图片。这可能是因为 adobe/office 版本的差异，我没有时间重新制作整个设置，对不起。请参阅代码中 cmets 中的建议。

Option Explicit

Sub PDF_To_Excel()
Dim setting_sh As Worksheet
Set setting_sh = ThisWorkbook.Sheets("Setting")
Dim pdf_path As String
Dim excel_path As String

pdf_path = Application.GetOpenFilename(FileFilter:="PDF Files (*.PDF), *.PDF", Title:="Select File To Be Opened")

excel_path = setting_sh.Range("E12").Value

Dim objFile As File
Dim sPath As String
Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Set objFile = fso.GetFile(pdf_path)
sPath = Left(objFile.Path, Len(objFile.Path) - Len(objFile.Name))
Set fo = fso.GetFolder(sPath)
Dim wa As Object
Dim doc As Object
Dim wr As Object

Set wa = CreateObject("word.application")
'Dim wa As New Word.Application
wa.Visible = False
'Dim doc As Word.Document
Dim nwb As Workbook
Dim nsh As Worksheet
'Dim wr As Word.Range

For Each f In fo.Files
    Set doc = wa.documents.Open(f.Path, False, Format:="PDF Files")
    Set wr = doc.Paragraphs(1).Range
    wr.WholeStory

    Set nwb = Workbooks.Add
    Set nsh = nwb.Sheets(1)

    wr.Copy
    nsh.Activate 'Pastespecial like this needs to use an active sheet (according to https://docs.microsoft.com/en-us/office/vba/api/excel.worksheet.pastespecial)
    ActiveSheet.PasteSpecial Format:=1, Link:=False, DisplayAsIcon:=False

    Dim oILS As Shape 'Thanks Beek! :)
    Set oILS = nsh.Shapes(nsh.Shapes.Count)

    With oILS
        .PictureFormat.CropLeft = 100
        .PictureFormat.CropTop = 100
        .PictureFormat.CropRight = 100
        .PictureFormat.CropBottom = 100
    End With
    With oILS
        .LockAspectRatio = True
    '    .Height = 260
    '    .Width = 450
    End With

    nwb.SaveAs (excel_path & "\" & Replace(f.Name, ".pdf", ".xlsx"))

    doc.Close True
    nwb.Close True

Next

wa.Quit
End Sub

这确实裁剪了我的一张照片。这确实会在没有背景的情况下插入它，因此如果需要，您需要稍后将其更改为白色。此外，这将给出一些需要处理的提示，如果其他人想稍后采用此代码。

【讨论】：

您好，非常感谢您的回答。非常感谢，真的。我调整了我的代码，当我运行它时，我收到以下错误：在这一行上键入不匹配 Set oILS = ThisWorkbook.Sheets(1).Shapes(ThisWorkbook.Sheets(1).Shapes.Count)。

基本上，代码是将 PDF 转换为 Word 作为图像，然后从 Word 文档中抓取图像并将其粘贴到 Excel 中，必须在其中进行裁剪。 VBA 代码在 Excel 上运行。

@Nytro：oILS 是否仍被声明为 InlineShape？因为那会导致类型不匹配

哦，对不起，是的。那是我最后跑的那个。让我调整一下。我觉得自己很愚蠢。

@Beek 是的，这也可能是问题所在。我认为这是因为我引用了运行宏的工作表，然后引用了一个工作表，但它正在创建一个新工作表，我们需要引用该工作表。他之前宣布为“nsh”。所以引用 nsh 上的第一个形状应该可以解决问题