Search code examples
excelvbaimagefilecrop

Cropping image after pasting it into Excel

Below is what I've tried in Excel VBA. It works well pasting the image into Excel, but I need them to be cropped.

The code below represents the attempt:

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

I get this error:

"Run time error 438 object doesn't support this property or method"

on the following line:

Set oILS = Selection.InlineShapes(1)

It currently gets the PDFs converted into Word documents and then pastes them into Excel files. But I need the images to be cropped in all the Excel files.

Solution

  • I added a picture to a word document, then copied it over manually to excel. And just changing the dim to shape and the reference that was giving you trouble kinda worked on my end. I am having trouble reproducing the first half of your code, making a pdf into a word document and getting a copyable picture to show up. This is probably because of adobe/office version differences tho and I don't have the time to remake the whole setup, I'm sorry. See the suggestions in the comments in the code. 

    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://learn.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

    This does crop my one picture. This does insert it without a background tho, so you need to change it to white later if that is needed. Also, this is going to give some prompts which would need to be dealt with, if someone else wants to adopt this code later I mean.