AW: Diagramm per Makro als Grafik in PowerPoint einf.
16.07.2003 10:40:35
david
Hallo Alexander,
das folgende Makro hab ich in der Recherche gefunden...
Es speichert allerdings noch kein Diagramm, sondern nur die ersten 7 Spalten und 10 Zeilen des Excel-sheets. Es liegt wohl daran, dass noch kein Object definiert wurde (createObjects).
Das was es macht, macht es aber gut. Im Ppt wird jeweils eine neue Seite geöffnet, einen Titel kann man auch dazu schreiben... probier einfach mal. Hab gerade selbst keine Zeit, muss das Problem aber auch irgendwann lösen...
Falls es- wie gesagt- bei dir gehen sollte, wärs nett, wenn du postest...
Sub exportDieZweite()
' Prozedur fügt Diagramme der Arbeitsmappe in eine Presentation
' ein. Ist PowerPoint noch nicht geöffnet, wird die Anwendung
' geladen und während des Ablaufes die Steuerung übergeben.
Dim PP2000 As PowerPoint.Application
Dim folie As Byte, blatt As String, ordner As String
On Error GoTo Fehler
Set PP2000 = GetObject(, "Powerpoint.Application")
On Error GoTo 0
diagramm3.Show
blatt = diagramm3.diagramm
If blatt = "" Then Exit Sub
Unload dlg_diagramm
Workbooks("probe15.7.2003.xls").Activate
ordner = ActiveWorkbook.Path
With PP2000
.Visible = True
.Activate
If .Presentations.Count = 0 Then
.Presentations.Open Filename:="C:\Users\My Documents\Probe\probe15.7.2003.ppt", ReadOnly:=msoFalse
End If
folie = .ActivePresentation.Slides.Count + 1
.ActivePresentation.Slides.Add folie, ppLayoutTitleOnly
.ActivePresentation.Slides(folie).Select
.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With .ActiveWindow.Selection.TextRange
.Text = "Diagramm " & blatt
.Font.Size = 28
End With
.ActiveWindow.Selection.SlideRange.Shapes.AddOLEObject(Left:=120#, Top:=140#, Width:=480#, Height:=320#, Filename:="C:\Users\My Documents\Probe\probe2\probe15.7.2003.xls", Link:=msoTrue).Select
.ActiveWindow.Selection.ShapeRange.LinkFormat.AutoUpdate = ppUpdateOptionManual
.ActiveWindow.Selection.Unselect
End With
Set PP2000 = Nothing
Sheets("tabelle1").Activate
Exit Sub
Gruß
David
Fehler:
Set PP2000 = CreateObject("Powerpoint.Application")
Resume Next
End Sub