Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1752to1756
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
VBA PowerPoint Excel
20.04.2020 00:05:55
Andi
Hallo liebe VBAler!
ich bin leider wieder mal etwas am verzweifeln... Ich habe einen Code in Excel/VBA geschrieben, der eine bestehende PowerPoint Datei nehmen soll und diese in einen neuen Pfad kopieren und abspeichern soll. Anschließend sollen auch noch in einem Textfeld der Autor der PP angepasst werden auf Basis von Daten aus der Excel Tabelle.
Der Stand des aktuellen Codes (wahrscheinlich noch an einigen Stellen falsch) ist hier zu sehen:
Sub Powerpoint()
Dim PP As Powerpoint.Application
Dim pPres As Powerpoint.Presentation
Dim Folie As Powerpoint.Slide
Dim sPathDoku, Name As String
Dim Textfeld As Shape
Dim Pfad1
Dim i, Var1, Var2
'Definieren der Variablen
Pfad1 = [Pfad steht hier]
Name = [Name von Datei]
Vorlage = [Pfad steht hier]
i = ActiveCell.Row 'Abfrage, in welcher Zeile die aktuell angewählte Zelle ist
Var1 = Worksheets("T1").Cells(i, 8).Value & "\"
Var2 = Worksheets("T1").Cells(i, 7).Value
sPathDoku = Pfad1 & Var1 & Var2
'Zukünftiger Pfad für Ablagort der PowerPoint
Abfrage = sPathDoku & Name
'Hier Soll abgefragt werden, ob die Datei bereits existiert
If PP.FileExists(Abfrage) = True Then
Set PP = Nothing
'Hyperlink wird generiert und in Zelle ABi angezeigt
With Worksheets("T1")
.Hyperlinks.Add Anchor:=.Range("P" & i), Address:=sPathDoku, TextToDisplay:="Link"
Range("P" & i) = sPathDoku
End With
MsgBox "Datei bereits vorhanden"
Else
With PP
If Worksheets("T1").Cells(i, 15).Value = "Test" Then
Set PP = CreateObject("PowerPoint.Application")
PP.Visible = True
Set pPres = PP.Presentations.Open(Abfrage, untitled:=msoTrue) 'kopieren und neu  _
Speichern?!
Set Folie = ActivePresentation.Slides(2)
Set Textfeld = Folie.Shapes("Name1")   'Name der Form = Name1
a = WorksheetFunction.VLookup("N" & i, Worksheets("Tabelle2").Range("A2:B13"), 2) ' _
Muss über SVerweis gesucht werden
Textfeld.TextFrame.TextRange.Text = wks.Range(a).Text   'In das Textfeld soll der  _
durch Sverweis gefundene Wert gespeichert werden
'Powerpoint schliessen
PP.Close savechanges:=True
Set PP = Nothing
'Hyperlink wird generiert und in Zelle ABi angezeigt
With Worksheets("T1")
.Hyperlinks.Add Anchor:=.Range("P" & i), Address:=sPathDoku, TextToDisplay: _
="Link"
Range("P" & i) = sPathDoku
End With
MsgBox "Eine Kopie der PowerPoint wurde erstellt und abgespeichert."
End If
End With
End If
End Sub
Jetzt zu den Problemen:
1) Direkt beim Kompilieren erscheint die Fehlermeldung, dass "Benutzerdefinierter Typ nicht definiert" ist. Und bezieht sich dabei auf Dim PP As Powerpoint.Application
Ich habe geschaut und in Extras → Verweise ist Microsoft Office 16.0 Object Library aktiviert. Microsoft Powerpoint nicht und kann auch nicht extra/zusätzlich aktiviert werden, da es einen "konflikt mit vorhandenem Modul, Projekt oder vorhandener Objektbibliothek gibt.", so die Fehlermeldung.
If PP.FileExists(Abfrage) = True Then
2) Diese Abfrage funktioniert leider nicht. Da erscheint auch eine Fehlermeldung, dass ein Objekt erforderlich ist..
Set pPres = PP.Presentations.Open(Abfrage, untitled:=msoTrue)
3) Ich habe diesen Teil aus einer anderen Vorlage kopiert und hatte es so verstanden, dass die Vorlage kopiert und neu abgespeichert wird. Aber dafür fehlen doch irgendwie informationen. Also woher die Datei kommt bzw. wohin sie gespeichert werden soll...
Ich hoffe, dass ich die Problem verständlich erklären konnte und freue mich über jede Hilfe!
Gruß, euer
Andi

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA PowerPoint Excel
20.04.2020 12:09:12
volti
Hallo Andi,
anliegend mal ein Versuch Dein Anliegen umzusetzen. So ganz habe ich bei Deinem Code bzgl. Deines Wunsches nicht durchgeblickt und den Part mit dem VLookup nicht bearbeitet, aber vielleicht kannst Du dem u.a. Code als Vorschlag ja was abgewinnen.
PS: Ich habe auf Late Bilding umgestellt, da brauchst Du keine Verweise, so dass auch das klappen sollte...

Option Explicit
Sub Powerpoint()
 Dim pptApp As Object, oPres As Object, oFolie As Object
 Dim oTextfeld As Object
 Dim sPathDoku, sDateiname As String
 Dim sPfad1 As String, Vorlage As String, Abfrage   As String, a
 Dim i As Integer, Var1, Var2
'Definieren der Variablen
 sPfad1 = "D:\Telekomwelt\TEX-Dashboard\test\"  '[Pfad steht hier]
 sDateiname = "TEX1-Dashboard_H.pptx"           '[Name von Datei]
 Vorlage = "D:\Telekomwelt\TEX-Dashboard\"      '[Pfad steht hier]
 i = ActiveCell.Row                             'Abfrage, in welcher Zeile die aktuell angewählte Zelle ist
 Var1 = Worksheets("T1").Cells(i, 8).value & "\"
 Var2 = Worksheets("T1").Cells(i, 7).value
 sPathDoku = sPfad1 & Var1 & Var2
'Zukünftiger Pfad für Ablagort der PowerPoint
 Abfrage = sPathDoku & Name
'Hier Soll abgefragt werden, ob die Datei bereits existiert
 If Dir$(sPathDoku & sDateiname) <> "" Then
    'Hyperlink wird generiert und in Zelle ABi angezeigt
    With Worksheets("T1")
         .Hyperlinks.Add Anchor:=.Range("P" & i), Address:=sPathDoku, TextToDisplay:="Link"
         .Range("P" & i) = sPathDoku
    End With
    MsgBox "Datei ist bereits vorhanden", vbExclamation
 Else
    CreateObject("Scripting.FileSystemObject").CopyFile _
    Vorlage & sDateiname, sPathDoku & sDateiname
   
    Set pptApp = CreateObject("PowerPoint.Application")
    With pptApp
      If Worksheets("T1").Cells(i, 15).value = "Test" Then
         .Visible = True
         Set oPres = pptApp.Presentations.Open(Filename:=sPathDoku & sDateiname)
         If Not oPres Is Nothing Then
            Set oFolie = oPres.Slides(2)
            If Not oFolie Is Nothing Then
              On Error Resume Next
              Set oTextfeld = oFolie.Shapes("Name1")   'Name der Form = Name1
              If Not oTextfeld Is Nothing Then
                With Worksheets("Tabelle2")
                 a = WorksheetFunction.VLookup("N" & i, .Range("A2:B13"), 2) 'Muss über SVerweis gesucht werden
                 oTextfeld.TextFrame.TextRange.Text = .Range(a).Text   'In das Textfeld soll der durch Sverweis gefundene Wert gespeichert werden
               End With
               oPres.Close savechanges:=True           ''Powerpoint-Datei schliessen
            'Hyperlink wird generiert und in Zelle ABi angezeigt
               With Worksheets("T1")
                    .Hyperlinks.Add Anchor:=.Range("P" & i), Address:=sPathDoku, TextToDisplay:="Link"
                    .Range("P" & i) = sPathDoku
               End With
               MsgBox "Eine Kopie der PowerPoint wurde erstellt und abgespeichert.", vbInformation
              Else
               MsgBox "Textmarke nicht gefunden!", vbCritical
              End If
            Else
               MsgBox "Folie nicht gefunden!", vbCritical
            End If
         Else
               MsgBox "Präsentation nicht gefunden!", vbCritical
         End If
      Else
               MsgBox "Nix zu tun!", vbInformation
      End If
    End With
    pptApp.Quit                 'Powerpoint schliessen
    On Error Resume Next
    Set oFolie = Nothing
    Set oPres = Nothing
    Set pptApp = Nothing
 End If
End Sub

viele Grüße
Karl-Heinz

Anzeige
AW: VBA PowerPoint Excel
20.04.2020 16:57:34
Andi
Hallo Karl-Heinz,
wow vielen Dank! Ich habe den Code gerade übernommen und wollte probieren, wie es klappt, aber da kommt beim Debuggen die Fehlermeldung "Die Methode 'CopyFile' für das Objekt 'IFileSystem3' ist fehlgeschlagen". Die Meldung kommt nach der ersten Zeile nach dem ersten else:

CreateObject("Scripting.FileSystemObject").CopyFile _
Vorlage & sDateiname, sPathDoku & sDateiname

Ich habe überprüft, dass in allen Variablen auch tatsächlich die entsprechenden Pfade/Namen hinterlegt sind und bin leider nicht schlau daraus geworden, was da nicht stimmt. Kannst du mir da evtl weiterhelfen?
Und den VLookup habe ich eingebaut, da in der Zelle N & i nur ein Kürzel drinsteht. Über den Sverweis soll dann der Vollständige Name herausgefunden werden.
Grüße
Andi
Anzeige
AW: VBA PowerPoint Excel
20.04.2020 18:08:21
volti
Hallo Andi,
bei mir mit meiner Beispieldatei funktioniert das einwandfrei. Das mit dem 'IFileSystem3' habe ich irgendwie im Hinterkopf:
Ich meine das kommt dann, wenn kein Festplattenplatz mehr da ist oder kein Zugriff besteht. Prüfe das mal und poste ggf. mal Deinen Code dazu.
Ich lass den Thread mal offen, vielleicht hat grad einer noch eine Idee dazu...
Wenn gar nicht klappt, nehmen wir eine andere Kopierfunktion.
viele Grüße
Karl-Heinz
AW: VBA PowerPoint Excel
20.04.2020 19:34:18
Andi
Hallo Karl-Heinz,
ich habe gerade nochmal alles gecheckt und am Speicherplatz kann es definitiv nicht liegen. Und Zugriff habe ich auch auf alle Pfade/Dateien. Wenn du eine andere Kopierfunktion kennst, würde ich die gerne ausprobieren!
Hier der gesamte Code, wie er gerade ist. Wie kann ich den so bunt darstellen, wie er mir bei Excel bzw. deiner angezeigt wird?

Function Anderungsdoku()
Dim PPApp As Object, oPres As Object, oFolie, oTextfeld As Object
Dim sPathDoku, sDateiname As String
Dim Pfad1, Vorlage, Abfrage, Var1, Var2 As String
Dim i As Integer
'Definieren der Variablen
Pfad1 = [hier steht der Pfad]
sDateiname = [hier steht der Dateiname]
Vorlage = [Pfad zur Vorlage]
i = ActiveCell.Row 'Abfrage, in welcher Zeile die aktuell angewählte Zelle ist
Var1 = Worksheets("T1").Cells(i, 8).Value & "\"
Var2 = Worksheets("T1").Cells(i, 7).Value
'zukünftiger Pfad für Ablageort der PowerPoint
sPathDoku = Pfad1 & Var1 & Var2
Set PPApp = CreateObject("Scripting.FileSystemObject")
Set oPres = CreateObject("Scripting.FileSystemObject")
'Hier wird abgefrat, ob die Datei bereits existiert
If Dir$(sPathDoku & sDateiname)  "" Then
'Hyperlink wird generiert und in Zelle AAi angezeigt
With Worksheets("T1")
.Hyperlinks.Add Anchor:=.Range("P" & i), Address:=Pfad1, TextToDisplay:="Link"
Range("P" & i) = PfadNeu
End With
MsgBox "Datei bereits vorhanden", vbExclamation
Else
CreateObject("Scripting.FileSystemObject").CopyFile Vorlage & sDateiname, sPathDoku &  _
sDateiname
Set PPApp = CreateObject("PowerPoint.Application")
With PPApp
If Worksheets("T1").Cells(i, 15).Value = "Test1" Then
.Visible = True
Set oPres = pptApp.Presentations.Open(Filename:=sPathDoku & sDateiname)
If Not oPres Is Nothing Then
Set oFolie = oPres.Slides(2)
If Not oFolie Is Nothing Then
On Error Resume Next
Set oTextfeld = oFolie.Shapes("Name1") 'Name der Form = Name1
If Not oTextfeld Is Nothing Then
With Worksheets("Tabelle2")
a = WorksheetFunction.VLookup("N" & i, .Range("A2:B13"), 2) 'Muss ü  _
_
ber SVerweis gesucht werden
oTextfeld.TextFrame.TextRange.Text = .Range(a).Text   'In das  _
Textfeld soll der durch Sverweis gefundene Wert gespeichert werden
End With
oPres.Close savechanges:=True           'Powerpoint-Datei schliessen
'Hyperlink wird generiert und in Zelle AAi angezeigt
With Worksheets("T1")
.Hyperlinks.Add Anchor:=.Range("P" & i), Address:=Pfad1,  _
TextToDisplay:="Link"
Range("P" & i) = Pfad1
End With
MsgBox "Eine Kopie der PowerPoint wurde erstellt und abgespeichert.",    _
_
_
vbInformation
Else
MsgBox "Textmarke nicht gefunden!", vbCritical
End If
Else
MsgBox "Folie nicht gefunden!", vbCritical
End If
Else
MsgBox "Präsentation nicht gefunden!", vbCritical
End If
Else
MsgBox "Nix zu tun!", vbInformation
End If
End With
PPApp.Quit                 'Powerpoint schliessen
On Error Resume Next
Set oFolie = Nothing
Set oPres = Nothing
Set pptApp = Nothing
End If
End Function

Ich bin für jede Hilfe dankbar!
Grüße
Andi
Anzeige
AW: VBA PowerPoint Excel
20.04.2020 20:02:27
volti
Hi Andi,
ich schaue noch mal danach. Wird ggf. morgen....
Wie kann ich den so bunt darstellen, wie er mir bei Excel bzw. deiner angezeigt wird?
Da ich hier öfter was poste, habe ich mir dafür extra ein VBA-AddIn für Highlightning geschrieben. Ohne Tool geht das nicht. Andere hier im Forum haben auch irgendwas dafür.
viele Grüße
Karl-Heinz
AW: VBA PowerPoint Excel
20.04.2020 20:23:57
volti
Sorry Andi,
aber warum hast Du meine Vorlage nicht so benutzt, wie ich sie geliefert habe?
Nur stichprobenweise....
Set PPApp = CreateObject("Scripting.FileSystemObject")
Set oPres = CreateObject("Scripting.FileSystemObject")

Das ist Quatsch....
PPApp As Object verändert, aber nicht überall
PfadNeu nicht gedimt und nicht gesetzt =>leer
Du solltest oben Option Explicit stehen haben, dann wäre Dir so einiges aufgefallen...
viele Grüße
KArl-Heinz
Anzeige
AW: VBA PowerPoint Excel
20.04.2020 21:48:21
Andi
Hallo Karl-Heinz,
vielen Dank für deine ganze Hilfe und Zeit. Es war nicht meine Absicht, nicht vollständig deinen Code zu nutzen. Bei mir geht vieles durch die Hand in den Verstand und deswegen habe ich versucht, nur die Änderungen zu übernehmen (habe die abgetippt), da ich so auch besser nachvollziehen kann, was du geändert hast. Offenbar sind mir da einige Fehler untergelaufen, was logischerweise keine Absicht war.
Ich habe es jetzt via Copy and Paste versucht und meine Pfade eingefügt. Leider kommt die gleiche Fehlermeldung wie zuvor auch bei CreateObject etc. Es kann aber auch sein, dass ich einfach irgendwas falsch in die Variablen eingefügt habe. Das schaue ich mir morgen in Ruhe nochmal an.
Grüße und Danke
Andi
Anzeige
AW: VBA PowerPoint Excel
20.04.2020 23:06:07
volti
Hallo Andi,
hier noch eine Alternative zum Kopieren der Datei:
FileCopy Vorlage & sDateiname, sPathDoku & sDateiname
viele Grüße
KH

43 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige