📜  PowerPoint图表不刷新 - 无论代码示例

📅  最后修改于: 2022-03-11 14:58:26.682000             🧑  作者: Mango

代码示例1
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal milliseconds As LongPtr) 'MS Office 64 Bit
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long) 'MS Office 32 Bit
#End If
 
Function CopyChartFromExcelToPPT(excelFilePath As String, sheetName As String, chartName As String, dstSlide As Long, Optional shapeLeft As Long, Optional shapeTop As Long, Optional shapeWidth As Long, Optional shapeHeight As Long) As Shape
    On Error GoTo ErrorHandl 'Handle Errors
    
    'Set Variables and Open Excel
    Dim eApp As Excel.Application, wb As Excel.Workbook, ppt As PowerPoint.Presentation, ws As Excel.Worksheet
    Set eApp = New Excel.Application
    eApp.Visible = False
    Set wb = eApp.Workbooks.Open(excelFilePath)
    Set ppt = ActivePresentation
 
    'Copy Chart in Excel
    wb.Sheets(sheetName).ChartObjects(chartName).Copy
    
    'Paste into first slide in active PowerPoint presentation
    ppt.Slides(dstSlide).Shapes.PasteSpecial ppPasteBitmap
    Set CopyChartFromExcelToPPT = ppt.Slides(dstSlide).Shapes(ppt.Slides(dstSlide).Shapes.Count)
    'Close and clean-up Excel
    wb.Close SaveChanges:=False
    eApp.Quit
    Set wb = Nothing: Set eApp = Nothing
    
    'Move the new shape if left/top provided
    If Not (IsMissing(shapeTop)) Then
        With CopyChartFromExcelToPPT
            .Left = shapeLeft
            .Top = shapeTop
        End With
    End If
    
    
    If Not (IsMissing(shapeWidth)) Then
        With CopyChartFromExcelToPPT
            .LockAspectRatio = False
            .Width = shapeWidth
            .Height = shapeHeight
        End With
    End If
 
    Exit Function
ErrorHandl:
    'Make sure to close the workbook and Excel and return False
    On Error Resume Next
    If Not (eApp Is Nothing) Then
        wb.Close SaveChanges:=False
        eApp.Quit
    End If
    Set CopyChartFromExcelToPPT = Nothing
End Function