Function GetTemplate()
View.TextBox1.Text = "D:\SICHER\BK NEU-ORGA\Vorlage.pot"
End Function
Sub CopyWksToPPT()
Dim pptApp As Object
Dim sTemplatePPt As String
Dim wks As Worksheet
Dim sTargetTop As Single
Dim sTargetLeft As Single
Dim sTargetWidth As Single
Dim sTargetHeight As Single
Dim sScaleHeight As Single
Dim sScaleWidth As Single
Dim iIndex As Integer
Dim c As Integer
sTargetTop = 50
sTargetLeft = 40
sTargetWidth = 640
sTargetHeight = 500
sTemplatePPt = View.TextBox1.Text
If sTemplatePPt = "" Then
MsgBox "Bitte ein korrektes Powerpoint-Template angeben!"
End If
iIndex = 2
Set pptApp = CreateObject("Powerpoint.Application")
With pptApp
.Visible = True
.Presentations.Open _
Filename:=sTemplatePPt, Untitled:=msoTrue
For Each wks In Worksheets
wks.Select
.ActiveWindow.View.GotoSlide _
Index:=.ActivePresentation.Slides.Add _
(Index:=iIndex, Layout:=ppLayoutTitleOnly).SlideIndex
.ActiveWindow.View.Slide.Shapes.Title.TextFrame.TextRange.Text = "Entwicklung " + Replace(ActiveWorkbook.Name, ".xls", "") + " in " + wks.Name
iIndex = iIndex + 1
wks.UsedRange.Copy
.ActiveWindow.View.Paste
With .ActiveWindow.Selection.ShapeRange
sScaleHeight = sTargetHeight / .Height
sScaleWidth = sTargetWidth / .Width
If sScaleHeight < sScaleWidth Then
sScaleWidth = sScaleHeight
Else
sScaleHeight = sScaleWidth
End If
.ScaleHeight sScaleHeight, 0, 2
.ScaleWidth sScaleWidth, 0, 2
.Top = sTargetTop + (sTargetHeight - .Height) / 2
.Left = sTargetLeft + (sTargetWidth - .Width) / 2
End With
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(iCht).Chart
If .HasTitle Then
sTitle = .ChartTitle.Text
Else
sTitle = ""
End If
.HasTitle = False
.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
If Len(sTitle) > 0 Then
.HasTitle = True
.ChartTitle.Text = sTitle
End If
End With
Set PPSlide = PPPres.Slides.Add(Index:=iIndex, Layout:=ppLayoutTitleOnly)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
iIndex = iIndex + 1
With PPSlide
.Shapes.Paste.Select
With PPApp.ActiveWindow.Selection.ShapeRange
sScaleHeight = sTargetHeight / .Height
sScaleWidth = sTargetWidth / .Width
If sScaleHeight < sScaleWidth Then
sScaleWidth = sScaleHeight
Else
sScaleHeight = sScaleWidth
End If
.ScaleHeight sScaleHeight, 0, 2
.ScaleWidth sScaleWidth, 0, 2
.Top = sTargetTop + (sTargetHeight - .Height) / 2
.Left = sTargetLeft + (sTargetWidth - .Width) / 2
End With
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
End With
Next
Next
.Visible = True
.ActiveWindow.View.GotoSlide 1
.ActiveWindow.View.Slide.Shapes.Title.TextFrame.TextRange.Text = Replace(ActiveWorkbook.Name, ".xls", "")
End With
End Sub
Sub Auto_Open()
View.Show
GetTemplate
End Sub
Function CopyCharts(PPPres As PowerPoint.Application)
For iCht = 1 To ActiveSheet.ChartObjects.Count
With ActiveSheet.ChartObjects(iCht).Chart
If .HasTitle Then
sTitle = .ChartTitle.Text
Else
sTitle = ""
End If
.HasTitle = False
.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
If Len(sTitle) > 0 Then
.HasTitle = True
.ChartTitle.Text = sTitle
End If
End With
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
With PPSlide
.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
.Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
End With
Next
End Function