📅  最后修改于: 2022-03-11 14:58:26.682000             🧑  作者: Mango
#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