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

Question

以下是我在 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 文件中裁剪图像。

Answer 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

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