AW: CopyPicture von Excel zu PPT
20.03.2020 15:46:42
Excel
Hallo zusammen,
ich bin ein Stückchen weiter gekommen.
Ich habe einfach mal getestet, ob er die CopyPicture Aktion denn zumindest auf ein leeres Worksheet in Excel einfügt. Und siehe da, es funktioniert. Irgendwie scheint also die Kommunikation zwischen Excel und PPT nicht ganz zu funktionieren. Oder an meinem Code passt diesbezüglich etwas nicht.
Hier mal der gesamte Code:
Public Function DateiVorhanden(savePPT As String)
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.filesystemobject")
If objFSO.fileexists(savePPT) = True Then
DateiVorhanden = True
Else
DateiVorhanden = False
End If
Set objFSO = Nothing
End Function
Public Function VorlageVorhanden(pptVorlage As String)
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.filesystemobject")
If objFSO.fileexists(pptVorlage) = True Then
VorlageVorhanden = True
Else
VorlageVorhanden = False
End If
Set objFSO = Nothing
End Function
Sub create_acmb()
Dim strPOTX As String
Dim strPfad As String
Dim pptVorlage As String
Dim savePPT As String
Dim pptApp As Object
Dim pptPres As Presentation
Dim msgDone As Boolean
strPfad = ThisWorkbook.Path
strPOTX = "\ACMB_Vorlage.potx"
pptVorlage = strPfad & strPOTX
missionDate = Worksheets("AIRCRAFT CREW").Range("J2").Value
missionName = Worksheets("AIRCRAFT CREW").Range("D2").Value
savePPT = strPfad & "\" & Format(missionDate, "YYYY-MM-DD") & " ACMB " & missionName & ".pptx"
If VorlageVorhanden(pptVorlage) = False Then
MsgBox "ACMB_Vorlage.potx kann nicht gefunden werden! Bitte sicherstellen, dass sich die _
Datei im selben Ordner wie XXX befindet!"
Exit Sub
End If
If DateiVorhanden(savePPT) = False Then
Dim Mldg, Stil, Titel, Hilfe, Ktxt, Antwort, Text1
Mldg = "Wirklich alles ausgefüllt? Ein nachträgliches bearbeiten der XXX Daten in Powerpoint _
ist nicht möglich (weil Bilder)! ACMB wird im gleichen Ordner gespeichert."
Stil = vbYesNo + vbCritical + vbDefaultButton2
Titel = "Fortfahren?"
Hilfe = ""
Ktxt = 1000
Antwort = MsgBox(Mldg, Stil, Titel, Hilfe, Ktxt)
If Antwort = vbNo Then
UserForm2.Hide
Exit Sub
End If
End If
UserForm2.Hide
'On Error Resume Next
If missionDate "" And missionName "" Then
Set pptApp = New Powerpoint.Application
'Falls gleichnamige Datei schon vorhanden, diese öffnen und Folien erneut kopieren, _
anderenfalls neues ACMB erstellen
If DateiVorhanden(savePPT) = False Then
msgDone = False
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Else
msgDone = True
If pptApp.ActivePresentation Is Nothing Then
pptApp.Presentations.Open Filename:=savePPT, untitled:=msoTrue
Else
pptApp.ActivePresentation.Save
pptApp.ActivePresentation.Close
pptApp.Presentations.Open Filename:=savePPT, untitled:=msoTrue
End If
End If
Set pptPres = pptApp.ActivePresentation
'Missionsname aus AIRCRAFT AND CREW DETAILS wird auf Seite 1 der PPT eingefügt
pptPres.Slides(1).Shapes("Missionsname").TextFrame.TextRange.Characters.Text = Worksheets(" _
AIRCRAFT CREW").Range("D2").Value
'Callsigns aus AIRCRAFT AND CREW DETAILS werden auf Folie ROLL CALL eingefügt
Dim roll As Integer
Dim cs As Integer
roll = 2
For cs = 7 To 19
pptPres.Slides(2).Shapes("rollcall").Table.Cell(roll, 1).Shape.TextFrame.TextRange.Text = _
Worksheets("AIRCRAFT CREW").Cells(cs, 2).Value
roll = roll + 1
cs = cs + 1
Next
'-------------------------HIER FOLIEN EINFÜGEN----------------------------
'TIMELINE
Range("TIMELINE").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(40).Shapes.Paste
.LockAspectRatio = True
.Left = 100
.Top = 100
.Width = 500
End With
'AIRCRAFT
Range("AIRCRAFT").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(13).Shapes.Paste
.LockAspectRatio = True
.Left = 50
.Top = 150
.Width = 600
End With
'COMPLAN
Range("COMPLAN").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(37).Shapes.Paste
.LockAspectRatio = True
.Left = 100
.Top = 90
.Width = 500
End With
'SOM
Range("SOM").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(10).Shapes.Paste
.LockAspectRatio = True
.Left = 80
.Top = 80
.Width = 550
End With
'HLZ1
Range("HLZ_1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(18).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 570
End With
'HLZ2
Range("HLZ_2").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(20).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 570
End With
'HLZ3
Range("HLZ_3").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(22).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 570
End With
'HLZ4
Range("HLZ_4").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(24).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 570
End With
'HLZ5
Range("HLZ_5").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(26).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 570
End With
'HLZ6
Range("HLZ_6").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(28).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 570
End With
'CONTINGENCIES
Range("CONTINGENCIES").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(33).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 580
End With
'IIMC
Range("IIMC").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With pptPres.Slides(34).Shapes.Paste
.LockAspectRatio = True
.Left = 70
.Top = 80
.Width = 580
End With
'Speichern mit Datum aus Aircraft and Crew Details
pptPres.SaveAs savePPT
If msgDone = False Then
MsgBox "ACMB erstellt!"
Else
MsgBox "ACMB aktualisiert!"
End If
'Aufräumen
Set pptPres = Nothing
Set pptApp = Nothing
'Ordner öffnen
'Shell "explorer.exe /e, " & strPfad, vbNormalFocus
Else
MsgBox "Bitte Missionsnamen und Datum bei AIRCRAFT AND CREW DETAILS eingeben!"
Worksheets("AIRCRAFT CREW").Activate
End If
End Sub
Danke fürs Drüberschauen!
MfG Chris
