AW: VBA CODE KÜRZEN / INTELLIGENT & RUNTIME ERROR
16.02.2016 09:22:48
ChrisL
Hi Mark
Sub GenAll()
'************** Start wie bisher ******************
Dim pptFileName As String
'Tabelle
Dim PastePositionLeft As Integer
Dim PastePositionTop As Integer
Dim PastePositionHeight As Integer
Dim PastePositionWidth As Integer
Dim PasteTableAsDefined As Integer
'Diagramm
Dim PastePositionLeftChart As Integer
Dim PastePositionTopChart As Integer
Dim PastePositionHeightChart As Integer
Dim PastePositionWidthChart As Integer
'Einfügeposition in [cm] definieren --> Tabelle
PastePositionLeft = Application.CentimetersToPoints(14.84)
PastePositionTop = Application.CentimetersToPoints(9.68)
PastePositionHeight = Application.CentimetersToPoints(8.1)
PastePositionWidth = Application.CentimetersToPoints(17.31)
'Einfügeposition in [cm] definieren --> Diagramm
PastePositionLeftChart = Application.CentimetersToPoints(14.84)
PastePositionTopChart = Application.CentimetersToPoints(4.12)
PastePositionHeightChart = Application.CentimetersToPoints(4.51)
PastePositionWidthChart = Application.CentimetersToPoints(17.3)
'Dateiname des Templates festlegen
pptFileName = ThisWorkbook.Path & "\PPT_Template.ppt"
Dim ppApp, ppFile, ppSlide, objShape
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = msoTrue
'PowerPoint konfigurieren
Set ppFile = ppApp.presentations.Open(pptFileName)
ppApp.Activate
'Textbox in PowerPoint erstellen --> Auswahl Name
With ppFile.Slides(ppFile.Slides.Count).Shapes.AddShape(msoShapeRectangle, Application.CentimetersToPoints(15.57), Application.CentimetersToPoints(18.13), Application.CentimetersToPoints(4.15), Application.CentimetersToPoints(0.78)).TextFrame
.TextRange.Text = "PCM " & CStr(Worksheets("Gesamt-Überblick").Cells(11, 7).Value)
.TextRange.Font.Size = 12
.TextRange.Font.Size = 12
.TextRange.Font.Bold = False
.TextRange.Font.NameComplexScript = "Calibri"
.TextRange.Font.NameFarEast = "Calibri"
.TextRange.Font.Name = "Calibri"
.TextRange.Font.Color.RGB = RGB(0, 150, 150)
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.MarginBottom = Application.CentimetersToPoints(0.13)
.MarginLeft = Application.CentimetersToPoints(0.25)
.MarginRight = Application.CentimetersToPoints(0.25)
.MarginTop = Application.CentimetersToPoints(0.13)
.VerticalAnchor = msoAnchorTop
.HorizontalAnchor = msoAnchorNone
End With
With ppFile.Slides(ppFile.Slides.Count)
.Shapes(.Shapes.Count).Line.Visible = msoFalse
.Shapes(.Shapes.Count).Fill.Visible = msoFalse
End With
'***************** Ende Start ***********************
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Integer, rngKopierbereich As Range
Dim strGraph As String, strName As String
Set WS1 = Worksheets("Gesamt-Überblick")
' Blatt A
Set WS2 = Worksheets("A")
iZeile = 15
Set rngKopierbereich = WS2.Range("E46:L72")
strGraph = "Graph 1"
strName = WS1.Range("E35")
Call GenOne(ppApp, ppFile, ppSlide, objShape, WS1, WS2, iZeile, rngKopierbereich, strGraph, strName)
' Blatt B
Set WS2 = Worksheets("B")
iZeile = 16
Set rngKopierbereich = WS2.Range("E69:K103")
strGraph = "Graph 2"
strName = WS1.Range("E44")
Call GenOne(ppApp, ppFile, ppSlide, objShape, WS1, WS2, iZeile, rngKopierbereich, strGraph, strName)
'**************** Ende wie bisher ******************
Set objShape = Nothing
Set ppSlide = Nothing
Set ppFile = Nothing
Set ppApp = Nothing
End Sub
Private Sub GenOne(ppApp As Variant, ppFile As Variant, ppSlide As Variant, objShape As Variant, _
WS1 As Worksheet, WS2 As Worksheet, iZeile As Integer, rngKopierbereich, strGraph, strName)
'Excelblatt aktivieren
If WS1.Cells(iZeile, 12).Value > 0 Then
WS2.Activate
'Template-Folie für Detailsicht kopieren und einfügen --> Tabelle
Set ppSlide = ppFile.Slides(1)
ppSlide.Copy
ppFile.Slides(ppFile.Slides.Count).Select
ppApp.ActivePresentation.Slides.Paste(ppFile.Slides.Count + 1).Select
'zu kopierenden Bereich markieren --> Tabelle
rngKopierbereich.Select
'als Bild kopieren --> Tabelle
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'in PowerPoint einfügen --> Tabelle
ppApp.ActiveWindow.Selection.sliderange.Shapes.Paste.Select
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
ppApp.ActiveWindow.Selection.ShapeRange.Left = PastePositionLeft
ppApp.ActiveWindow.Selection.ShapeRange.Top = PastePositionTop
ppApp.ActiveWindow.Selection.ShapeRange.Height = PastePositionHeight
ppApp.ActiveWindow.Selection.ShapeRange.Width = PastePositionWidth
With ppFile.Slides(ppFile.Slides.Count).Select
'zu kopierenden Bereich markieren --> Diagramm
ActiveSheet.ChartObjects(strGraph).Activate
ActiveChart.ChartArea.Copy
ActiveChart.ChartArea.Select
With ppApp.ActiveWindow.Selection.ShapeRange
'in PowerPoint einfügen --> Diagramm
ppApp.ActiveWindow.Selection.sliderange.Shapes.Paste.Select
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
ppApp.ActiveWindow.Selection.ShapeRange.Left = PastePositionLeftChart
ppApp.ActiveWindow.Selection.ShapeRange.Top = PastePositionTopChart
ppApp.ActiveWindow.Selection.ShapeRange.Height = PastePositionHeightChart
ppApp.ActiveWindow.Selection.ShapeRange.Width = PastePositionWidthChart
End With
End With
'Textbox in PowerPoint erstellen --> Kommentare
With ppFile.Slides(ppFile.Slides.Count).Shapes.AddShape(msoShapeRectangle, _
Application.CentimetersToPoints(1.94), Application.CentimetersToPoints(4.48), Application.CentimetersToPoints(12.4), Application.CentimetersToPoints(13.25)).TextFrame
.TextRange.Text = CStr(Cells(4, 2).Value) & vbCr & vbCr & CStr(Cells(5, 2). _
Value) & vbCr & vbCr & CStr(Cells(6, 2).Value) & vbCr & vbCr & CStr(Cells(7, 2).Value) & vbCr & vbCr & CStr(Cells(8, 2).Value) & vbCr & vbCr & CStr(Cells(9, 2).Value) & vbCr & vbCr & CStr(Cells(10, 2).Value) & vbCr & vbCr & CStr(Cells(11, 2).Value) & vbCr & vbCr & CStr(Cells(12, 2).Value)
.TextRange.Font.Size = 12
.TextRange.Font.NameComplexScript = "Calibri"
.TextRange.Font.NameFarEast = "Calibri"
.TextRange.Font.Name = "Calibri"
.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.MarginBottom = Application.CentimetersToPoints(0)
.MarginLeft = Application.CentimetersToPoints(0)
.MarginRight = Application.CentimetersToPoints(0)
.MarginTop = Application.CentimetersToPoints(0)
.VerticalAnchor = msoAnchorTop
.HorizontalAnchor = msoAnchorNone
End With
With ppFile.Slides(ppFile.Slides.Count)
.Shapes(.Shapes.Count).Line.Visible = msoFalse
.Shapes(.Shapes.Count).Fill.Visible = msoFalse
End With
'Textbox in PowerPoint erstellen --> Name
With ppFile.Slides(ppFile.Slides.Count).Shapes.AddShape(msoShapeRectangle, _
Application.CentimetersToPoints(1.75), Application.CentimetersToPoints(0.8), Application.CentimetersToPoints(30.38), Application.CentimetersToPoints(3.2)).TextFrame
.TextRange.Text = strName
.TextRange.Font.Size = 35
.TextRange.Font.NameComplexScript = "Calibri"
.TextRange.Font.NameFarEast = "Calibri"
.TextRange.Font.Name = "Calibri"
.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.VerticalAnchor = msoAnchorTop
.HorizontalAnchor = msoAnchorNone
End With
With ppFile.Slides(ppFile.Slides.Count)
.Shapes(.Shapes.Count).Line.Visible = msoFalse
.Shapes(.Shapes.Count).Fill.Visible = msoFalse
End With
End If
End Sub