打开多个链接图并将其插入现有的 Power Point
Open and insert multiple linked graphs to existing Power Point
我在 excel 中有大量图表，我想更新到现有的 power-point。
为此，我找到了 excel 借出的代码：
http://www.myengineeringworld.net/2012/11/export-all-excel-charts-to-power-point.html
这很有魅力。现在，我需要简单地打开现有的电源点并添加图表（不是新图表），我还想 post 将图表作为 linked 图表。
这是原代码：
Option Explicit
'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
'Exports all the chart sheets to a new power point presentation.
'It also adds a text box with the chart title.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim ws As Worksheet
Dim intChNum As Integer
Dim objCh As Object
'Count the embedded charts.
For Each ws In ActiveWorkbook.Worksheets
intChNum = intChNum + ws.ChartObjects.Count
Next ws
'Check if there are chart (embedded or not) in the active workbook.
If intChNum + ActiveWorkbook.Charts.Count < 1 Then
MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
Exit Sub
End If
'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
'Loop through all the embedded charts in all worksheets.
For Each ws In ActiveWorkbook.Worksheets
For Each objCh In ws.ChartObjects
Call pptFormat(objCh.Chart)
Next objCh
Next ws
'Loop through all the chart sheets.
For Each objCh In ActiveWorkbook.Charts
Call pptFormat(objCh)
Next objCh
'Show the power point.
pptApp.Visible = True
'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
'Infrom the user that the macro finished.
MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
End Sub
Private Sub pptFormat(xlCh As Chart)
'Formats the charts/pictures and the chart titles/textboxes.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim chTitle As String
Dim j As Integer
On Error Resume Next
'Get the chart title and copy the chart area.
chTitle = xlCh.ChartTitle.Text
xlCh.ChartArea.Copy
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
'Paste the chart and create a new textbox.
pptSlide.Shapes.PasteSpecial ppPasteJPG
If chTitle <> "" Then
pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
End If
'Format the picture and the textbox.
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
'Picture position.
If .Type = msoPicture Then
.Top = 87.84976
.Left = 33.98417
.Height = 422.7964
.Width = 646.5262
End If
'Text box position and formamt.
If .Type = msoTextBox Then
With .TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = chTitle
.Font.Name = "Tahoma (Headings)"
.Font.Size = 28
.Font.Bold = msoTrue
End With
End If
End With
Next j
End Sub
首先，我根本不知道如何更改这部分代码：
'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
所以我只是打开我现有的演示文稿，我尝试了
的很多变体
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
pptApp.Presentations.Open("filelocation.pptx")
还有很多，但我似乎无法让系统捕获已经打开的 powerpoint 文件，或者直接从 link 打开它。
这也导致我无法将图表作为 linked 到 excel sheet，所以当我更改数字时，它们也会更改。
我似乎在为分配对象的正确方法而苦恼？
我已经创建了一个代码，您可以使用 FileDialog 命令 select 一个现有的 PowerPoint。
在您 select 要更新的 PowerPoint 文件之后，它会转到您的 selected 幻灯片，删除所有现有的图表对象。
将 Excel 中某个工作表中的所有图表对象复制到此幻灯片后。
这是我正在使用的一段代码。
首先你需要调用主程序。
Public Sub Main()
Dim PowerPoint_Selected As String
PowerPoint_Selected = GetFileName(ActiveWorkbook.Path)
Call UpdatePowerPoint(PowerPoint_Selected)
End Sub
这是让您选择要更新的 PowerPoint 幻灯片的功能。
Public Function GetFileName(strPath As String) As String
Dim fDialog As FileDialog
Dim result As Integer
Dim FileSelected As String
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
'Optional: FileDialog properties
fDialog.AllowMultiSelect = False
fDialog.Title = "Select a file"
fDialog.InitialFileName = strPath
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "PowerPoint files", "*.ppt*"
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
GetFileName = fDialog.SelectedItems(1)
End If
If GetFileName = "" Then
MsgBox "No PowerPoint file was selected !", vbExclamation, "Warning"
End
End If
End Function
这是更新您要更新的 PowerPoint 幻灯片中所有图表的例程。将 SlideNum 变量中的值更新为您要使用的任何幻灯片。
Public Sub UpdatePowerPoint(PowerPointFile)
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim cht_count As Integer
Dim SlideNum As Integer
Dim ShapeNum As Integer
' Open an existing PowerPoint
Set PPT = New PowerPoint.Application
PPT.Presentations.Open Filename:=PowerPointFile
Worksheets("YourSelectedSheetName").Activate
SlideNum = ActiveSheet.Cells(5, 2)
PPT.ActivePresentation.Slides(SlideNum).Select
' loop throughthe PowerPoint Slide shapes and search for the Shape that contains a chart
For i = PPT.ActivePresentation.Slides(SlideNum).Shapes.Count To 1 Step -1
If PPT.ActivePresentation.Slides(SlideNum).Shapes.Item(i).HasChart Then
PPT.ActivePresentation.Slides(SlideNum).Shapes.Item(i).Delete
End If
Next
'Show the PowerPoint
PPT.Visible = True
cht_count = 1
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
Set activeSlide = PPT.ActivePresentation.Slides(SlideNum) ' (17)
'Copy the chart and paste it into the PowerPoint as a Linked object to Excel
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(ppPasteDefault).Select
'Adjust the positioning of the Chart on Powerpoint Slide , each inch is 72 points
Select Case cht_count
Case 1 ' Timeline Chart
PPT.ActiveWindow.Selection.ShapeRange.Left = 7 ' 0.1"
PPT.ActiveWindow.Selection.ShapeRange.Top = 400 ' 5.55"
Case 2 ' Man-Hours Chart
PPT.ActiveWindow.Selection.ShapeRange.Left = 400 ' 5.55"
PPT.ActiveWindow.Selection.ShapeRange.Top = 295 ' 4.1"
End Select
cht_count = cht_count + 1
Next
With PPT.ActivePresentation.Slides(SlideNum).Shapes
For i = 1 To .Count
If .Item(i).HasTable Then
ShapeNum = i
End If
Next
End With
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub
我在 excel 中有大量图表，我想更新到现有的 power-point。
为此，我找到了 excel 借出的代码：
http://www.myengineeringworld.net/2012/11/export-all-excel-charts-to-power-point.html
这很有魅力。现在，我需要简单地打开现有的电源点并添加图表（不是新图表），我还想 post 将图表作为 linked 图表。
这是原代码：
Option Explicit
'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
'Exports all the chart sheets to a new power point presentation.
'It also adds a text box with the chart title.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim ws As Worksheet
Dim intChNum As Integer
Dim objCh As Object
'Count the embedded charts.
For Each ws In ActiveWorkbook.Worksheets
intChNum = intChNum + ws.ChartObjects.Count
Next ws
'Check if there are chart (embedded or not) in the active workbook.
If intChNum + ActiveWorkbook.Charts.Count < 1 Then
MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
Exit Sub
End If
'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
'Loop through all the embedded charts in all worksheets.
For Each ws In ActiveWorkbook.Worksheets
For Each objCh In ws.ChartObjects
Call pptFormat(objCh.Chart)
Next objCh
Next ws
'Loop through all the chart sheets.
For Each objCh In ActiveWorkbook.Charts
Call pptFormat(objCh)
Next objCh
'Show the power point.
pptApp.Visible = True
'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
'Infrom the user that the macro finished.
MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
End Sub
Private Sub pptFormat(xlCh As Chart)
'Formats the charts/pictures and the chart titles/textboxes.
'By Christos Samaras
'http://www.myengineeringworld.net
Dim chTitle As String
Dim j As Integer
On Error Resume Next
'Get the chart title and copy the chart area.
chTitle = xlCh.ChartTitle.Text
xlCh.ChartArea.Copy
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
'Paste the chart and create a new textbox.
pptSlide.Shapes.PasteSpecial ppPasteJPG
If chTitle <> "" Then
pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
End If
'Format the picture and the textbox.
For j = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(j)
'Picture position.
If .Type = msoPicture Then
.Top = 87.84976
.Left = 33.98417
.Height = 422.7964
.Width = 646.5262
End If
'Text box position and formamt.
If .Type = msoTextBox Then
With .TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = chTitle
.Font.Name = "Tahoma (Headings)"
.Font.Size = 28
.Font.Bold = msoTrue
End With
End If
End With
Next j
End Sub
首先，我根本不知道如何更改这部分代码：
'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
所以我只是打开我现有的演示文稿，我尝试了
的很多变体Set pptApp = New PowerPoint.Application
pptApp.Visible = True
pptApp.Presentations.Open("filelocation.pptx")
还有很多，但我似乎无法让系统捕获已经打开的 powerpoint 文件，或者直接从 link 打开它。
这也导致我无法将图表作为 linked 到 excel sheet，所以当我更改数字时，它们也会更改。
我似乎在为分配对象的正确方法而苦恼？
我已经创建了一个代码，您可以使用 FileDialog 命令 select 一个现有的 PowerPoint。 在您 select 要更新的 PowerPoint 文件之后，它会转到您的 selected 幻灯片，删除所有现有的图表对象。 将 Excel 中某个工作表中的所有图表对象复制到此幻灯片后。
这是我正在使用的一段代码。 首先你需要调用主程序。
Public Sub Main()
Dim PowerPoint_Selected As String
PowerPoint_Selected = GetFileName(ActiveWorkbook.Path)
Call UpdatePowerPoint(PowerPoint_Selected)
End Sub
这是让您选择要更新的 PowerPoint 幻灯片的功能。
Public Function GetFileName(strPath As String) As String
Dim fDialog As FileDialog
Dim result As Integer
Dim FileSelected As String
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
'Optional: FileDialog properties
fDialog.AllowMultiSelect = False
fDialog.Title = "Select a file"
fDialog.InitialFileName = strPath
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "PowerPoint files", "*.ppt*"
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
GetFileName = fDialog.SelectedItems(1)
End If
If GetFileName = "" Then
MsgBox "No PowerPoint file was selected !", vbExclamation, "Warning"
End
End If
End Function
这是更新您要更新的 PowerPoint 幻灯片中所有图表的例程。将 SlideNum 变量中的值更新为您要使用的任何幻灯片。
Public Sub UpdatePowerPoint(PowerPointFile)
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim cht_count As Integer
Dim SlideNum As Integer
Dim ShapeNum As Integer
' Open an existing PowerPoint
Set PPT = New PowerPoint.Application
PPT.Presentations.Open Filename:=PowerPointFile
Worksheets("YourSelectedSheetName").Activate
SlideNum = ActiveSheet.Cells(5, 2)
PPT.ActivePresentation.Slides(SlideNum).Select
' loop throughthe PowerPoint Slide shapes and search for the Shape that contains a chart
For i = PPT.ActivePresentation.Slides(SlideNum).Shapes.Count To 1 Step -1
If PPT.ActivePresentation.Slides(SlideNum).Shapes.Item(i).HasChart Then
PPT.ActivePresentation.Slides(SlideNum).Shapes.Item(i).Delete
End If
Next
'Show the PowerPoint
PPT.Visible = True
cht_count = 1
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
Set activeSlide = PPT.ActivePresentation.Slides(SlideNum) ' (17)
'Copy the chart and paste it into the PowerPoint as a Linked object to Excel
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(ppPasteDefault).Select
'Adjust the positioning of the Chart on Powerpoint Slide , each inch is 72 points
Select Case cht_count
Case 1 ' Timeline Chart
PPT.ActiveWindow.Selection.ShapeRange.Left = 7 ' 0.1"
PPT.ActiveWindow.Selection.ShapeRange.Top = 400 ' 5.55"
Case 2 ' Man-Hours Chart
PPT.ActiveWindow.Selection.ShapeRange.Left = 400 ' 5.55"
PPT.ActiveWindow.Selection.ShapeRange.Top = 295 ' 4.1"
End Select
cht_count = cht_count + 1
Next
With PPT.ActivePresentation.Slides(SlideNum).Shapes
For i = 1 To .Count
If .Item(i).HasTable Then
ShapeNum = i
End If
Next
End With
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
End Sub