AW: Automatische ppt's aus Excel mit VBA
22.06.2011 08:53:50
Dirk
Hallo Dirk,
hier mal ein Makro zur Verwendung. Du must bei Aufruf des Makros die noetigen Variablen entsprechend versorgen. Beim Speicherpfad musst Du entsprechend Deinen beduerfnissen anpassen.
Laeuft unter 2003 und 2007. Alles in ein Modul kopieren.
Public PPApp As PowerPoint.Application
Public PPPres As PowerPoint.Presentation
Public PPSlide As PowerPoint.Slide, PPFileName
Sub ExcelToNewPP(MyTemplate As String, MyRange As Range, Slide As Long, last As Boolean)
If Slide = 1 Then
'Dim PPApp As PowerPoint.Application
'Dim PPPres As PowerPoint.Presentation
'Dim PPSlide As PowerPoint.Slide, PPFileName
Dim SD As String, MyTop As Long, MyLeft As Long, Shp As PowerPoint.Shape
Dim ShpRange As PowerPoint.ShapeRange, MyWidth As Long, xfact, Yfact
Dim SLideH As Long, SlideW As Long, SlideRatio, PictRatio
Dim PictWidth As Long, PictHeight As Long
Dim ShpArr(10), i As Long
' Create instance of PowerPoint
Set PPApp = CreateObject("Powerpoint.Application")
' For automation to work, PowerPoint must be visible
PPApp.Visible = True
' Create a presentation
Set PPPres = PPApp.Presentations.Open(MyTemplate, untitled:=msoTrue)
'MyTemplate , untitled:=msoTrue
' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewSlide
' Add first slide to presentation
Set PPSlide = PPPres.Slides(2)
'PPApp.ActiveWindow.Presentation.ApplyTemplate MyTemplate
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = 1
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Select
End If
'clean template slide of old report data
PPSlide.Select
If Slide = 1 Then
PPSlide.Shapes.Range.Delete
End If
'copy the selected range
Worksheets(MyRange.Parent.Name).Range(MyRange.Address).Select
Worksheets(MyRange.Parent.Name).Range(MyRange.Address).CopyPicture Appearance:=xlScreen, _
Format:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
'name shape for reference
PPApp.ActiveWindow.Selection.ShapeRange.Name = "Pic" & Slide
'check if pasted picture already exist
If Slide > 1 Then
MyTop = PPSlide.Shapes("Pic" & Slide - 1).Top
MyLeft = PPSlide.Shapes("Pic" & Slide - 1).Left + PPSlide.Shapes("Pic" & Slide - 1). _
Width
' Align the pasted range
PPSlide.Shapes("Pic" & Slide).Top = MyTop
PPSlide.Shapes("Pic" & Slide).Left = MyLeft
Else
' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End If
If last = False Then
Exit Sub
End If
'adjust the position and size of the pictures on the slide, first get width of pictures
For i = 1 To Slide
PictWidth = PictWidth + PPSlide.Shapes("Pic" & i).Width
ShpArr(i) = PPSlide.Shapes("Pic" & i).Name
Next i
PictHeight = PPSlide.Shapes("Pic" & Slide).Height
PictRatio = PictWidth / PictHeight
SlideW = PPApp.ActiveWindow.Presentation.PageSetup.SlideWidth - 30
SLideH = PPApp.ActiveWindow.Presentation.PageSetup.SlideHeight - 40
SlideRatio = (SlideW / SLideH)
xfact = (SlideW - 30) / PictWidth 'scaling factor
With PPSlide.Shapes
.Range(ShpArr).Group.Select
End With
If xfact
Lass' uns wissen, ob ok.
Gruss
Dirk aus Dubai