打开多个链接图并将其插入到现有的Power Point

Question

我在excel中有大量图形，我想更新到现有的PowerPoint。

为此，我从以下位置找到了出色的代码：

http://www.myengineeringworld.net/2012/11/export-all-excel-charts-to-power-point.html

哪个作为魅力。 现在，我只需要打开一个现有的Power Point并添加图形（而不是新图形），我还想将图形发布为链接图表。

这是原始代码：

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")

还有更多，但是我似乎无法让系统捕获已经打开的Power Point文件，或者只是直接从链接中打开它。

这也导致我很难将图表链接到excel工作表，因此当我更改数字时，它们也会更改。

我似乎正在努力分配对象的正确方法？

Answer 1

我创建了一个代码，您可以使用FileDialog命令选择现有的PowerPoint。 选择要更新的PowerPoint文件后，它会转到所选的幻灯片，并删除所有现有的图表对象。 将所有图表对象从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