Обрезка изображения после вставки в Excel - PullRequest
Новая
       55

Обрезка изображения после вставки в Excel

1 голос
/ 12 февраля 2020

Вот что я пробовал в 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.

1 Ответ

3 голосов
/ 12 февраля 2020

Я добавил изображение в текстовый документ, а затем скопировал его вручную, чтобы преуспеть. И просто поменяв тусклость, чтобы придать форму, и ссылка, которая доставляла вам неприятности, сработала на моем конце. У меня проблемы с воспроизведением первой половины вашего кода, превращением pdf в текстовый документ и получением копируемой картинки для отображения. Это, вероятно, из-за различий в версии Adobe / Office, и у меня нет времени, чтобы переделать всю установку, извините. Смотрите предложения в комментариях в коде. 

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

Это обрезает одну мою фотографию. Это вставляет его без фона, поэтому вам нужно поменять его на белый позже, если это необходимо. Кроме того, это даст некоторые подсказки, с которыми нужно будет разобраться, если кто-то еще захочет принять этот код позже, я имею в виду.

...