AW: Powerpoint Versionen in VBA Late Binding
23.06.2017 12:18:27
Nepumuk
Hallo Nathalie,
teste mal:
Option Explicit
Sub CreatePowerPoint()
Dim oPPTApp As Object 'Die PowerPoint Anwendung
Dim oPPTFile As Object 'Die PowerPoint Datei
Dim oPPTSlide As Object 'PowerPoint Folien
Dim referenzVersion14 As String
Dim referenzVersion16 As String
Dim deltaTop As Integer
Dim deltaLeft As Integer
Dim oPPTSlide1 As Object
Dim oPPTSlide2 As Object
Dim oPPTSlide3 As Object
Dim oPPTSlide4 As Object
Dim oPPTSlide5 As Object
'Erkenne Komputermodell Lenovo
Dim manufacturer As String
Const fujitsu As String = "FUJITSU"
Const lenovo As String = "LENOVO"
Dim lenov As String
Dim fujit As String
Dim deltaTopLenovo As Integer
Dim deltaLeftLenovo As Integer
Dim objWMIService As Object
Dim colBIOS As Object, objBios As Object
'PowerPoint öffnen/starten
Set oPPTApp = CreateObject("Powerpoint.Application")
oPPTApp.Visible = True
'Neue Präsentation
Set oPPTFile = oPPTApp.Presentations.Add
' 'Button ausblenden
' Workbooks(fileName).Sheets("Purchasing").OLEObjects.Visible = False
'neue Folien einfügen
'Index: Foliennummer, Layout 12: Leeres Layout
Set oPPTSlide1 = oPPTFile.Slides.Add(Index:=1, Layout:=12)
Set oPPTSlide2 = oPPTFile.Slides.Add(Index:=2, Layout:=12)
Set oPPTSlide3 = oPPTFile.Slides.Add(Index:=3, Layout:=12)
Set oPPTSlide4 = oPPTFile.Slides.Add(Index:=4, Layout:=12)
Set oPPTSlide5 = oPPTFile.Slides.Add(Index:=5, Layout:=12)
' Set oPPTSlide6 = oPPTFile.Slides.Add(Index:=6, Layout:=12)
' Set oPPTSlide7 = oPPTFile.Slides.Add(Index:=7, Layout:=12)
'Anzeige auf 16:9 umstellen
oPPTApp.ActivePresentation.PageSetup.SlideSize = 15
'Gleicht die Office Versionen ab
referenzVersion14 = "14.0"
referenzVersion16 = "16.0"
'Stellt Delta zwischen Office 2010 und 2016 ein. Hier kann justiert werden
If Application.Version = referenzVersion16 Then
deltaLeft = deltaLeft - 140
deltaTop = deltaTop - 50
End If
Debug.Print (deltaLeft)
'Stellt Delta von Lenovo ein. Hier kann justiert werden
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colBIOS = objWMIService.ExecQuery("Select * from Win32_BIOS")
For Each objBios In colBIOS
Debug.Print (objBios.manufacturer)
manufacturer = objBios.manufacturer
If InStr(manufacturer, lenovo) > 0 Then
deltaLeftLenovo = deltaLeftLenovo + 14
deltaTopLenovo = deltaTopLenovo + 6
End If
Next
'Kopiere Bereich A1:N35 aus Tabellenblatt SIF und füge es in Folie 1 ein
Sheets("SIF").Range("A1:N35").CopyPicture
oPPTSlide1.Shapes.Paste
With oPPTSlide1.Shapes(1)
.IncrementLeft 400 + deltaLeft + deltaLeftLenovo
.IncrementTop 198 + deltaTop + deltaTopLenovo
.Width = 721
End With
'Kopiere Bereich A1:N34 aus Tabellenblatt Purchasing und füge es in Folie 2 ein
Sheets("Purchasing").Range("A1:R34").CopyPicture
oPPTSlide2.Shapes.Paste
With oPPTSlide2.Shapes(1)
.IncrementLeft 400 + deltaLeft + deltaLeftLenovo
.IncrementTop 198 + deltaTop + deltaTopLenovo
.Width = 721
End With
'Kopiere Bereich A1:N34 aus Tabellenblatt Quality und füge es in Folie 3 ein
Sheets("Quality").Range("A1:N34").CopyPicture
oPPTSlide3.Shapes.Paste
With oPPTSlide3.Shapes(1)
.IncrementLeft 400 + deltaLeft + deltaLeftLenovo
.IncrementTop 198 + deltaTop + deltaTopLenovo
.Width = 721
End With
'Kopiere Bereich A1:N34 aus Tabellenblatt Logistics und füge es in Folie 4 ein
Sheets("Logistics").Range("A1:N34").CopyPicture
oPPTSlide4.Shapes.Paste
With oPPTSlide4.Shapes(1)
.IncrementLeft 400 + deltaLeft + deltaLeftLenovo
.IncrementTop 198 + deltaTop + deltaTopLenovo
.Width = 721
End With
'Kopiere Bereich A1:L29 aus Tabellenblatt Greetings und füge es in Folie 4 ein
Sheets("Greetings").Range("A1:L29").CopyPicture
oPPTSlide5.Shapes.Paste
With oPPTSlide5.Shapes(1)
.IncrementLeft 400 + deltaLeft + deltaLeftLenovo
.IncrementTop 198 + deltaTop + deltaTopLenovo
.Width = 721
End With
'Variablen leeren
Set oPPTSlide1 = Nothing
Set oPPTSlide2 = Nothing
Set oPPTSlide3 = Nothing
Set oPPTSlide4 = Nothing
Set oPPTSlide5 = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
End Sub
Gruß
Nepumuk
