将图像粘贴到 Excel 后裁剪图像
Cropping image after pasting it into Excel
以下是我在 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
我收到此错误:
"Run time error 438 object doesn't support this property or method"
在以下行中:
Set oILS = Selection.InlineShapes(1)
它目前将 PDF 转换为 Word 文档,然后将它们粘贴到 Excel 文件中。但我需要在所有 Excel 文件中裁剪图像。
我在 word 文档中添加了一张图片,然后手动将其复制到 excel。只是改变暗淡的形状和给你带来麻烦的参考对我来说有点奏效。我无法重现您的前半部分代码,将 pdf 制作成 word 文档并显示可复制的图片。这可能是因为 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
这确实裁剪了我的一张照片。这确实会在没有背景的情况下插入它,因此如果需要,您需要稍后将其更改为白色。此外,这将给出一些需要处理的提示,如果其他人以后想采用此代码,我的意思是。
以下是我在 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
我收到此错误:
"Run time error 438 object doesn't support this property or method"
在以下行中:
Set oILS = Selection.InlineShapes(1)
它目前将 PDF 转换为 Word 文档,然后将它们粘贴到 Excel 文件中。但我需要在所有 Excel 文件中裁剪图像。
我在 word 文档中添加了一张图片,然后手动将其复制到 excel。只是改变暗淡的形状和给你带来麻烦的参考对我来说有点奏效。我无法重现您的前半部分代码,将 pdf 制作成 word 文档并显示可复制的图片。这可能是因为 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
这确实裁剪了我的一张照片。这确实会在没有背景的情况下插入它,因此如果需要,您需要稍后将其更改为白色。此外,这将给出一些需要处理的提示,如果其他人以后想采用此代码,我的意思是。