VBA粘贴选定Excel嵌入式图表到当前PowerPoint幻灯片中

以下代码由PHP站长网 52php.cn收集自互联网

现在PHP站长网小编把它分享给大家，仅供参考

Sub CopyChartsIntoPowerPoint()
''' COPY SELECTED EXCEL CHARTS INTO POWERPOINT
' Set a VBE reference to Microsoft PowerPoint Object Library

Dim pptApp As PowerPoint.Application
Dim iShapeIx As Integer,iShapeCt As Integer
Dim myShape As Shape,myChart As ChartObject
Dim bCopied As Boolean

Set pptApp = GetObject(,"PowerPoint.Application")

If ActiveChart Is Nothing Then
    ''' SELECTION IS NOT A SINGLE CHART
    On Error Resume Next
    iShapeCt = Selection.ShapeRange.count
    If Err Then
        MsgBox "Select charts and try again",vbCritical,"Nothing Selected"
        Exit Sub
    End If
    On Error GoTo 0
    For Each myShape In Selection.ShapeRange
        ''' IS SHAPE A CHART?
        On Error Resume Next
        Set myChart = ActiveSheet.ChartObjects(myShape.name)
        If Not Err Then
            bCopied = CopyChartToPowerPoint(pptApp,myChart)
        End If
        On Error GoTo 0
    Next
Else
    ''' CHART ELEMENT OR SINGLE CHART IS SELECTED
    Set myChart = ActiveChart.Parent
    bCopied = CopyChartToPowerPoint(pptApp,myChart)
End If

Dim myPptShape As PowerPoint.Shape
Dim myScale As Single
Dim iShapesCt As Integer

''' BAIL OUT IF NO PICTURES ON SLIDE
On Error Resume Next
iShapesCt = pptApp.ActiveWindow.Selection.SlideRange.Shapes.count
If Err Then
    MsgBox "There are no shapes on the active slide","No Shapes"
    Exit Sub
End If
On Error GoTo 0

''' ASK USER FOR SCALING FACTOR
myScale = InputBox(Prompt:="Enter a scaling factor for the shapes (percent)",_
    Title:="Enter Scaling Percentage") / 100

''' LOOP THROUGH SHAPES AND RESCALE "PICTURES"
For Each myPptShape In pptApp.ActiveWindow.Selection.SlideRange.Shapes
    If myPptShape.name Like "Picture*" Then
        With myPptShape
            .ScaleWidth myScale,msoTrue,msoScaleFromMiddle
            .ScaleHeight myScale,msoScaleFromMiddle
        End With
    End If
Next

Set myChart = Nothing
Set myShape = Nothing
Set myPptShape = Nothing
Set pptApp = Nothing
End Sub

Function CopyChartToPowerPoint(oPPtApp As PowerPoint.Application,_
    oChart As ChartObject)
CopyChartToPowerPoint = False

oChart.Chart.CopyPicture Appearance:=xlScreen,Format:=xlPicture,Size:=xlScreen
oPPtApp.ActiveWindow.View.Paste

CopyChartToPowerPoint = True
End Function

以上内容由PHP站长网【52php.cn】收集整理供大家参考研究

如果以上内容对您有帮助，欢迎收藏、点赞、推荐、分享。

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!