如何用VBA去除Excel复制粘贴到PPT时产生的灰色边框？

问题描述 #

使用VBA将Excel区域通过CopyPicture复制并粘贴到PPT时，生成的图片会带有不需要的灰色边框，需要去除该边框。当前使用的VBA代码如下：

Sub CopyAndPaste()

Dim PPTApp As PowerPoint.Application
Dim PPTShape As PowerPoint.Shape
Dim PPTFile As PowerPoint.Presentation
Dim mySlide As Object

Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String

strPresPath = "C:\Users\xxxxxxxx"
strExcelFilePath = "C:\Users\pppppppp"
    
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Visible = msoTrue
    
Set PPTFile = PPTApp.Presentations.Open(strPresPath)
    
'Step 1 Copy the data
Workbooks("Globalyyyy").Worksheets("ILLUSTRATIONS CHARTS").Range("B58:G69").CopyPicture

Application.CutCopyMode = False

'Step 2 Paste the data
Set mySlide = PPTFile.Slides(5)

With mySlide
mySlide.Shapes.PasteSpecial Paste:=xlPastePicture 'DataType:=ppEnhancedMetafile
End With

Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub

解决方法 #

核心思路是获取粘贴后的PPT形状对象，直接将其边框设置为不可见，具体有两种实现方式：

方法1：粘贴后立即设置边框 #

在PasteSpecial执行后，直接获取刚粘贴的形状，修改其线条属性：

With mySlide
    Set PPTShape = .Shapes.PasteSpecial(Paste:=xlPastePicture)(1) '获取粘贴的第一个形状
    PPTShape.Line.Visible = msoFalse '隐藏灰色边框
End With

方法2：遍历幻灯片形状（适合批量处理） #

如果需要处理幻灯片上所有图片的边框，可以遍历形状并设置：

For Each PPTShape In mySlide.Shapes
    If PPTShape.Type = msoPicture Then '仅处理图片类型的形状
        PPTShape.Line.Visible = msoFalse
    End If
Next PPTShape

修改后的完整代码 #

Sub CopyAndPaste()

Dim PPTApp As PowerPoint.Application
Dim PPTShape As PowerPoint.Shape
Dim PPTFile As PowerPoint.Presentation
Dim mySlide As Object

Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String

strPresPath = "C:\Users\xxxxxxxx"
strExcelFilePath = "C:\Users\pppppppp"
    
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Visible = msoTrue
    
Set PPTFile = PPTApp.Presentations.Open(strPresPath)
    
'Step 1 Copy the data
Workbooks("Globalyyyy").Worksheets("ILLUSTRATIONS CHARTS").Range("B58:G69").CopyPicture

Application.CutCopyMode = False

'Step 2 Paste the data and remove border
Set mySlide = PPTFile.Slides(5)

With mySlide
    Set PPTShape = .Shapes.PasteSpecial(Paste:=xlPastePicture)(1)
    PPTShape.Line.Visible = msoFalse '去除灰色边框
End With

Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub

内容的提问来源于stack exchange，提问作者moqa