Charts aus Excel in Powerpoint einfügen
31.10.2007 11:33:00
Hein
ich möchte gerne aus einer bestehenden Excel-Datei heraus bereits vorhandene Charts und Tabellen kopieren (copyPicture) und im Powerpoint einfügen.
Das Problem dass sich stellt ist dass ich diese im Powerpoint gerne noch formatieren möchte (länge, breite, position) bei meinen bisherigen Versuchen mit 'shapes' werden leider alle shapes des betr. slides entsprechend formatiert.
Weiss jemand wie ich das jeweils unmittelbar vorher eingefügte shape formatieren kann ohne dass die anderen shapes des betroffenen slides in mitleidenschaft gezogen werden?
Anbei mein Code
Gruss aus Zürich
Hein
Public Sub tabellen_einfügen()
Dim i As Integer
Dim xl_path As String
Dim xl_wb_name As String
Dim xl_ws_name As String
Dim xl_chart_name As String
Dim pp_slide_no As Long
Dim pp_left_points As Long
Dim pp_top_points As Long
Dim pp_width_points As Long
Dim pp_height_points As Long
Dim objPowerpoint As Object
Set objPowerpoint = CreateObject("Powerpoint.Application")
objPowerpoint.Visible = True
Dim pp_presentation As String
i = 2
Do Until IsEmpty(Cells(i, 1).Value)
xl_path = Cells(i, 1).Value
xl_wb_name = Cells(i, 2).Value
xl_ws_name = Cells(i, 3).Value
xl_type_name = Cells(i, 4).Value
xl_chart_name = Cells(i, 5).Value
pp_presentation = Cells(i, 6).Value
pp_slide_no = Cells(i, 7).Value
pp_left_points = Cells(i, 8).Value
pp_top_points = Cells(i, 9).Value
pp_width_points = Cells(i, 10).Value
pp_height_points = Cells(i, 11).Value
Workbooks.Open xl_path & xl_wb_name, UpdateLinks:=0
If xl_type_name = "chart" Then
Worksheets(xl_ws_name).Shapes(xl_chart_name).CopyPicture
Else
Worksheets(xl_ws_name).Range(xl_chart_name).CopyPicture
End If
objPowerpoint.Presentations.Open pp_presentation, ReadOnly:=msoFalse
objPowerpoint.ActivePresentation.Slides(pp_slide_no).Shapes.Paste
With objPowerpoint.ActivePresentation.Slides(pp_slide_no).Shapes.Range
.LockAspectRatio = msoFalse 'funktioniert?
.Left = pp_left_points
.Top = pp_top_points
.Width = pp_width_points
.Height = pp_height_points
End With
objPowerpoint.ActivePresentation.Save
objPowerpoint.ActivePresentation.Close
Workbooks(xl_wb_name).Close SaveChanges:=False
Workbooks("versuch1.xls").Activate
i = i + 1
Loop
End Sub