Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1616to1620
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
Inhaltsverzeichnis

Docx zu PDF

Docx zu PDF
13.04.2018 14:16:44
Cord
Gute Tag
Ich bin neu hier im Forum genau wie in der Programmierung mit VBA.
Ich versuche ein Modul anzupassen, das ein ehemaliger Kollege geschrieben hat.
Er hat nach dem umwandeln alle PDF in einen Ordner im Hauptverzeichnis gespeichert.
Ich möchte jetzt die PDF in die jeweiligen Unterverzeichnisse legen und die .docx löschen.
Diese beiden Sachen wären die ersten Schritte letzter Schritt wäre eine vorhandene .PPTX mit einem Schreibschutz zu versehen.
Nachdem ich die Umwandlungszeile mehrfach angepasst habe bin ich leider nicht weitergekommen. Entweder kommt garnichts oder Fehlermeldungen.
Vielleicht hat ja hier jemand eine einfache Lösung für mich mit Erklärung warum das so geht.
Private Sub CreatePdfWalkFolders(fld As folder)
Dim sfld As folder, ch As Integer
Dim docs As files, sdoc As File, pdfdoc As File
Dim dinf As cDocumentInfo, dtyp As itsCwType
Dim pdfpath As String, wassaved As Boolean
Dim fidate As Date, pdfdate As Date
Set docs = fld.files
Set dinf = New cDocumentInfo
For Each sdoc In docs
dinf.FromFileName sdoc.Name
dtyp = dinf.TypeEnum
If dtyp = itsCwTypeManual Or dtyp = itsCwTypeLessonSummary Then
dinf.Extension = ".pdf"
fidate = sdoc.DateLastModified
pdfpath = fso.BuildPath(pPdfPath, dinf.ToFileName)
If fso.FileExists(pdfpath) Then
Set pdfdoc = fso.GetFile(pdfpath)
pdfdate = pdfdoc.DateLastModified
Else
pdfdate = DateSerial(1900, 1, 1)
End If
If fidate > pdfdate Then
Application.StatusBar = "PDF Erstellung für " & sdoc.Name
Set docWord = appWord.Documents.Open(Filename:=sdoc.path, ReadOnly:=True,  _
Visible:=True)
docWord.ExportAsFixedFormat OutputFileName:=pdfpath, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks
docWord.Saved = True
docWord.Close
Set docWord = Nothing
End If
End If
DoEvents
Next sdoc
If fld.subfolders.Count > 0 Then
For Each sfld In fld.subfolders
ch = Asc(Left(sfld.Name, 1))
If ch > 47 And ch 

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Docx zu PDF
15.04.2018 09:55:08
fcs
Hallo Cor,
die Problemzeile ist
            pdfpath = fso.BuildPath(pPdfPath, dinf.ToFileName)

Hier wird der Name der PDF-Datei mit dem fixen Pfad festgelegt/generiert.
Hier muss das Unterverzeichnis eingbaut werden, wenn diese abgearbeitet werden.
Mit meiner Anpassung im Code funktioniert es aber nur mit 1 Ebene von Unterverzeichnissen. Bei mehr Ebenen muss man noch mehr Aufwand treiben um das Unterverzeichnis zu ermitteln.
Zum Löschen der umgwandelten Worddateien kann man deren Pfad\Name vorm Umwandeln in einem Array zwischenspeichern und im Anschluss das Lösch-Makro ausführen.
Nachfolgend der angpasste Code - natürlich ungetestet!
Gruß
Franz
Public parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs
'Löschen der in PDF umgewandelten Worddokumente
Private Sub Kill_Docs()
Dim intJ As Integer
If pintDoc > 0 Then
For intJ = 1 To pintDoc
Kill parrDocs(intJ)
Next
Erase parrDocs
pintDoc = 0
MsgBox "Worddokumente gelöscht", vbInformation + vbOKOnly, "Kill_Docs"
Else
MsgBox "Keine Worddokumente in Array gespeichert", vbInformation + vbOKOnly, "Kill_Docs" _
End If
End Sub
Private Sub CreatePdfWalkFolders(fld As folder, Optional ByVal subFolder As String = "") '#### _
geändert
Dim sfld As folder, ch As Integer
Dim docs As Files, sdoc As File, pdfdoc As File
Dim dinf As cDocumentInfo, dtyp As itsCwType
Dim pdfpath As String, wassaved As Boolean
Dim fidate As Date, pdfdate As Date
Set docs = fld.Files
Set dinf = New cDocumentInfo
For Each sdoc In docs
dinf.FromFileName sdoc.Name
dtyp = dinf.TypeEnum
If dtyp = itsCwTypeManual Or dtyp = itsCwTypeLessonSummary Then
dinf.Extension = ".pdf"
fidate = sdoc.DateLastModified
pdfpath = FSO.BuildPath(pPdfPath & IIf(subFolder = "", "", "\" & subFolder), _
dinf.ToFileName)     '####geändert
If FSO.FileExists(pdfpath) Then
Set pdfdoc = FSO.GetFile(pdfpath)
pdfdate = pdfdoc.DateLastModified
Else
pdfdate = DateSerial(1900, 1, 1)
End If
If fidate > pdfdate Then
Application.StatusBar = "PDF Erstellung für " & sdoc.Name
pintDoc = pintDoc + 1 'Worddokumente hochzählen         ####neu
ReDim Preserve parrDocs(1 To pintDoc) 'Array erweitern  ####neu
parrDocs(pintDoc) = sdoc.Path 'Doc-Name im Array merken ####neu
Set docWord = appWord.Documents.Open(Filename:=sdoc.Path, ReadOnly:=True, _
Visible:=True)
docWord.ExportAsFixedFormat OutputFileName:=pdfpath, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks
docWord.Saved = True
docWord.Close
Set docWord = Nothing
End If
End If
DoEvents
Next sdoc
If fld.subfolders.Count > 0 Then
For Each sfld In fld.subfolders
ch = Asc(Left(sfld.Name, 1))
If ch > 47 And ch 
            pdfpath = fso.BuildPath(fld, dinf.ToFileName)

Anzeige
AW: Docx zu PDF
16.04.2018 09:41:06
Cord
Danke für die Antwort so komme ich dem Ziel näher :)
Ich habe versucht den Code komplett zu übernehmen, was aber nicht funktioniert hat.
Dann habe ich die Zeile
pdfpath = FSO.BuildPath(pPdfPath & IIf(subFolder = "", "", "\" & subFolder), _
dinf.ToFileName)     '####geändert

welche alles ausser Funktion gesetzt hat ersetzt durch die letzte Zeile
pdfpath = fso.BuildPath(fld, dinf.ToFileName)

jetzt erstellt er durch alle Unterordner wie gewünscht von den richtigen Dateien, die PDF Kopie.
Dafür schonmal allerherzlichsten Dank
Und die Zeile
Public parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs

Produziert den Fehler "Ungültiges Attribut in Sub oder Funktion"
Habe das in Dim geändert bekomme jetzt keine Fehlermeldung mehr sehe aber natürlich auch keine Ausgabe.
Die Zeilen
pintDoc = pintDoc + 1 'Worddokumente hochzählen         ####neu
ReDim Preserve parrDocs(1 To pintDoc) 'Array erweitern  ####neu
parrDocs(pintDoc) = sdoc.Path 'Doc-Name im Array merken ####neu

habe ich auch an dieser Stelle eingefügt.
Leider hat die Löschfunktion keine Funktion alle zu löschenden Daten sind noch da und auch die Messagebox kommt nicht hoch.
Habe die Sub vor und hinter die andere Sub eingefügt hier war keine Änderung sichtbar.
Ich hoffe du kannst mich dort weiter unterstützen
Anzeige
AW: Docx zu PDF
16.04.2018 10:38:25
Cord
Völlig vergessen die Zeile
Call CreatePdfWalkFolders(sfld, sfld.Name) '####geändert

Produziert "Fehler beim Kompilieren:Falsche Anzahl an Argumenten oder ungültige Zuweisung zu einer Eigenschaft
AW: Docx zu PDF
17.04.2018 07:51:48
Cord
Die Zeile
Public parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs

habe ich an den Anfang der Prozedur versetzt jetzt kommt keine Fehlermeldung aber auch das Löschen funktioniert nicht leider.
Vielleicht kann ja noch einer rüberschauen Danke
Cord
AW: Docx zu PDF
17.04.2018 11:14:07
fcs
Hallo Cord,
die Deklaration der öffentlichen (Public) Variablen
Public parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs

muss im Code des allgemeinen Moduls zu Beginn stehen oberhalb/vor allen Subs und Functions.
Das hast du ja inzwischen erledigt.
pdfpath = FSO.BuildPath(pPdfPath & IIf(subFolder = "", "", "\" & subFolder), _
dinf.ToFileName)     '####geändert

Der Inhalt von Variable "pPdfPath" war für mich unklar. Ich war davon ausgegangen, dass die PDF-Dateien in einem anderen Verzeichnis gespeichert werden sollten als die Word-Dateien.
Deshalb das Konstrukt mit dem Subfolder, beim 1. Aufruf aus deiner mir unbekannten Sub bleibt der Wert leer und die PDF würden in pPdfPath gespeichert. Wenn die Unterverzeichnisse abgearbeitet werden, dann sollten entsprechende Unterverzeichnisse angelgt und die Dateien dort gespeichert werden.
Mit der neuen Zeile
pdfpath = fso.BuildPath(fld, dinf.ToFileName)

werden jetzt die PDF im gleichen Verzeichnis wie die Worddateien gespeichert, was wohl auch dein Ziel war.
Fehler in
Call CreatePdfWalkFolders(sfld, sfld.Name) '####geändert

Das ist dann auf die anderen Modifikationen zurückzuführen, die du gemacht hast..
Da die Sub jetzt wahrscheinlich wieder
 Private Sub CreatePdfWalkFolders(fld As folder)

heißt, statt wie von mir vor vorgeschlagen
 Private Sub CreatePdfWalkFolders(fld As folder, Optional ByVal subFolder As String = "") '####  _
_
geändert

darf in dem Abschnitt für die Unterverzeichnisse auch nur noch ein Parameter angegeben werden.
Da die Erstellung der PDFs über alle Unterverzeichnisse jetzt funktioniert ist das wohl auch erledigt.
Erstellen der Liste mit den zu löschenden Word-Dateien.
Nachdem du die Deklaration der Variablen an die korrekte Position verschoben hast sollte es eigentlich funktionieren.
                  parrDocs(pintDoc) = sdoc.Path 'Doc-Name im Array merken ####neu
muss den korrekten Pfad\Dateinamen speichern, denn sdoc.Path öffnet in der folgenden Zeile die korrekte Word-Datei.
Führe das Makro mal im Schrittmodus aus oder setze im Makro einen Haltepunkt in der Zeile in der das PDF-Erzeugt wird, dann kannst den Wert von parrDocs(pintDoc) kontrollieren. Hier sollte dann immer der komplette Pfad mit Dateiname angezeigt werden.
Zusätzlich kannst du im Makro, das die Sub "CreatePdfWalkFolders" startet vor der aufrufenden Zeile folgendes einfügen:
          Erase parrDocs
pintDoc = 0

Dadurch werden der Zähler und das Array gezielt zurückgesetzt.
Ich hab das Makro zum Löschen getestet. Wenn das Daten-Array korrekt gefüllt wird. dann wird auch gelöscht. Die Daten des Arrays bleiben allerdings nur solange gespeichert, bis das VBA-Projekt neu kompiliert wird order die Excel-Datei geschlossen wird. Nach Ausführung der Löschaktionen wird der Inhalt des Arrays und der Zähler ebenfalls zurückgesetzt.
Die Position des Löschen-Makros spielt keine Rolle.
Allerdings sollte der komplette Code in einem allgemeinen Modul gespeichert werden.
Gruß
Franz
Anzeige
AW: Docx zu PDF
17.04.2018 13:21:35
Cord
Hallo danke für deine Antwort wie ich mit jedem Schritt merke muss ich noch vieles lernen.
Leider ist die gesamte Prozedur viel umfangreicher wie es hier aussieht.In dem Project werden diverse Dokumente geprüft korrigiert und eine Liste erstellt in der nicht behebbare Fehler aufgelistet sind und noch diverse Funktionen mehr.Ich poste das komplette Modul, weil es leider nicht funktioniert hier ist auch noch die Erstellung eines Ordners für die PDF vorgesehen, den ich aber nicht brauche, weil die PDF ja in den jeweiligen Ordnern liegen.
Vielleicht liegt hier schon der Hase im Pfeffer. Gleichzeitig werden noch mehrere Informationsmodule angesprochen die hier aber den Rahmen mehr als sprengen würden.
Option Explicit
Public parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs
Private pPdfPath As String
Public Sub CreatePdfMakro(control As IRibbonControl)
CreatePdf
End Sub
Public Sub CreatePdfShowResult()
CreatePdf
If pResultText  "" Then
MsgBox pResultText, pResultIcon + vbOKOnly, "Syllabus Prüfer - " & ActiveWorkbook.Name
End If
End Sub
Public Sub CreatePdf()
Dim fileExcel As File
Erase parrDocs
pintDoc = 0
On Error GoTo MsgBoxFehler
pResultText = ""
pResultIcon = vbInformation
If Not IsSyllabusWorkbook() Then
pResultText = "Diese Excel Mappe ist keine Courseware Liste!" & vbCrLf & vbCrLf & " _
Bitte verwenden Sie die Korrekte Vorlage" & vbCrLf & "zum Erstellen einer Courseware Liste."
pResultIcon = vbCritical
Exit Sub
End If
If Not TestWorkbookExists() Then
pResultText = "Die Excel Mappe wurde noch nicht gespeichert!" & vbCrLf & vbCrLf & " _
Bitte speichen Sie die Mappe mit dem korrekten Namen" & vbCrLf & "in der Hierarchie des Kurses."
pResultIcon = vbCritical
Exit Sub
End If
TestOpenDocuments
Application.Cursor = xlDefault ' xlWait
Application.StatusBar = "PDF Erstellung beginnt."
Set fileExcel = fso.GetFile(ActiveWorkbook.FullName)
Set rootFolder = fileExcel.parentfolder
pPdfPath = fso.BuildPath(rootFolder.path, "_PDF")
If Not fso.FolderExists(pPdfPath) Then
fso.CreateFolder pPdfPath
End If
Set appWord = CreateObject("Word.Application")
CreatePdfWalkFolders rootFolder
appWord.Quit
Set appWord = Nothing
GoTo noerr
MsgBoxFehler:
pResultText = "Fehler Nr. " & Err.Number & " von " & Err.Source & vbCrLf & Err.Description
pResultIcon = vbCritical
noerr:
Application.Cursor = xlDefault
Application.StatusBar = "PDF Erstellung beendet."
End Sub
Private Sub CreatePdfWalkFolders(ByVal fld As folder)
Dim sfld As folder, ch As Integer
Dim docs As files, sdoc As File, pdfdoc As File
Dim dinf As cDocumentInfo, dtyp As itsCwType
Dim pdfpath As String, wassaved As Boolean
Dim fidate As Date, pdfdate As Date
Dim parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs
Set docs = fld.files
Set dinf = New cDocumentInfo
For Each sdoc In docs
dinf.FromFileName sdoc.Name
dtyp = dinf.TypeEnum
If dtyp = itsCwTypeManual Or dtyp = itsCwTypeLessonSummary Or _
dtyp = itsCwTypeWorksheetTask Or dtyp = itsCwTypeWorksheetSolution Then
dinf.Extension = ".pdf"
fidate = sdoc.DateLastModified
pdfpath = fso.BuildPath(fld, dinf.ToFileName)
If fso.FileExists(pdfpath) Then
Set pdfdoc = fso.GetFile(pdfpath)
pdfdate = pdfdoc.DateLastModified
Else
pdfdate = DateSerial(1900, 1, 1)
End If
If fidate > pdfdate Then
Application.StatusBar = "PDF Erstellung für " & sdoc.Name
pintDoc = pintDoc + 1 'Worddokumente hochzählen  ####neu
ReDim Preserve parrDocs(1 To pintDoc) 'Array erweitern  ####neu
parrDocs(pintDoc) = sdoc.path 'Doc-Name im Array merken ####neu
Set docWord = appWord.Documents.Open(Filename:=sdoc.path, ReadOnly:=True,  _
Visible:=True)
docWord.ExportAsFixedFormat OutputFileName:=pdfpath, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, _
CreateBookmarks:=wdExportCreateHeadingBookmarks
docWord.Saved = True
docWord.Close
Set docWord = Nothing
End If
End If
DoEvents
Next sdoc
If fld.subfolders.Count > 0 Then
For Each sfld In fld.subfolders
ch = Asc(Left(sfld.Name, 1))
If ch > 47 And ch  0 Then
For intJ = 1 To pintDoc
Kill parrDocs(intJ)
Next
Erase parrDocs
pintDoc = 0
MsgBox "Worddokumente gelöscht", vbInformation + vbOKOnly, "Kill_Docs"
Else
MsgBox "Keine Worddokumente in Array gespeichert", vbInformation + vbOKOnly, "Kill_Docs" _
_
End If
End Sub

wenn du bitte prüfen könntest ob ich alles richtig eingefügt habe.
Danke
Cord
Anzeige
AW: Docx zu PDF
18.04.2018 07:30:21
fcs
Hallo Cord,
Hauptproblem:
Du hast die beiden Public-Variablen in Makro selbst auch noch lokal deklariert
    Dim parrDocs() As String, pintDoc As Integer 'Variablen zum Merken der umgewandelten Docs

Diese Deklaration muss gelöscht werden. sonst werden die Public-Variablen nicht mit Daten gefüllt und das Löschen kann nicht funktionieren.
Word-Dokumente Löschen
Damit gelöscht wird muss das entsprechende Makro auch gestartet werden. Diese Anweisung fügt man am besten an der Position ein nachdem die Word-Anwendung wieder beendet wurde.
Ordner "..._PDF"
Damit der Unter-Ordner "..._PDF" nicht mehr angelegt wird "einfach" die entsprechenden 4 Zeilen löschen - zusätzlich auch die nicht mehr benötigte Deklaration der Variablen für den Ordner.
Den Abshnitt zum Merken des Namens der Worddatei hab ich hinter die Anweisung zum Speichern als PDF verschoben. So wird sichergestellt, das nur Namen gemerkt werden, die auch ohne Fehler als PDF gespeichert wurden.
Gruß
Franz
Textdatei mit angepasstem Code:
https://www.herber.de/bbs/user/121114.txt
Anzeige
AW: Docx zu PDF
18.04.2018 10:13:34
Cord
Zu allererst ein herzliches DANKESCHÖN an Franz für deine super Hilfe.
Ich hoffe eines Tages die Zeit zu haben den Umgang mit VBA zumindest so zu lernen, das ich so etwas selber erstellen kann.
Der Code funktioniert jetzt genauso wie ich mir das vorgestellt habe PDF wird im richtigen Ordner erstellt und im Nachgang die Word gelöscht.
AW: Docx zu PDF
18.04.2018 15:32:17
Cord
Nächste Aufgabe ist nun in jedem der Unterordner die PPTX zu finden und Schreibgeschützt mit Passwort zu speichern(ich weis das ist nicht die Lösung aber ich kenne keine andere).
Also erst Öffnen dann Speichern mit Schreibschutz leider habe ich beim Googlen nur etwas über speichern auch Schreibgeschützt aber nur auf Explorerebene nicht aus dem Programm heraus. Da dieser Vorgang gleichzeitig mit dem Umformen in PDF passieren soll wäre es super das in dem vorhandenen Code unterzubringen oder von dort zu starten.
Ich habe aus dem "alten" Code einen neuen gebaut der Powerpoint öffnet was mir fehlt ist das öffnen(hier muss mann einen Filenamen angeben der ja in der Liste sein sollte), speichern und wie starte ich das aus dem alten Code heraus zum richtigen Zeitpunkt.
Vielleicht geht das auch viel einfacher :)
Private Sub SavePptxAsNotWriteable()
Dim filePowerpoint As file
Dim fileexcel As file
Dim appPower As Object
On Error GoTo MsgBoxFehler
pResultText = ""
pResultIcon = vbInformation
If Not IsSyllabusWorkbook() Then
pResultText = "Diese Excel Mappe ist keine Courseware Liste!" & vbCrLf & vbCrLf & " _
Bitte verwenden Sie die Korrekte Vorlage" & vbCrLf & "zum Erstellen einer Courseware Liste."
pResultIcon = vbCritical
Exit Sub
End If
If Not TestWorkbookExists() Then
pResultText = "Die Excel Mappe wurde noch nicht gespeichert!" & vbCrLf & vbCrLf & " _
Bitte speichen Sie die Mappe mit dem korrekten Namen" & vbCrLf & "in der Hierarchie des Kurses."
pResultIcon = vbCritical
Exit Sub
End If
TestOpenDocuments
Application.Cursor = xlDefault ' xlWait
Application.StatusBar = "Powerpoint wird geschützt"
Set fileexcel = fso.GetFile(ActiveWorkbook.FullName)
' Start-Ordner setzen für die zu schützenden Powerpoint
Set rootFolder = fileexcel.parentfolder
'Powerpoint-Anwendung starten
Set appPower = CreateObject("Powerpoint.Application")
sPowerpointSecureSave rootFolder
'Powerpoint-Anwendung wieder beenden
appPower.Quit
Set appPower = Nothing
GoTo noerr
MsgBoxFehler:
pResultText = "Fehler Nr. " & Err.Number & " von " & Err.Source & vbCrLf & Err.Description
pResultIcon = vbCritical
noerr:
Application.Cursor = xlDefault
Application.StatusBar = "Powerpoint fertig"
End Sub

Anzeige
AW: Docx zu PDF
18.04.2018 15:34:09
Cord
Wieder den Haken vergessen, das der Thread auf Ungelöst steht
AW: Docx zu PDF -pptx mit Kennwort speichern
19.04.2018 11:42:18
fcs
Hallo Cord,
ich hab mich jetzt auch noch mit Kennwörternfür PowerPoint unter VBA rumgeschlagen - keine Ahnung warum Microsoft bei jedem Programm eine andere Methode verwendet.
Im Prizip ist es genau so wie beim Speichern der Word-Dateien als PDF.
Die Variable für PowerPoint-Application muss as Public deklariert werden.
In der Sub, die die pptx speichern soll muss eine Prüfung für den Datei-Namen eingebaut werden.
Zusätzlich muss du im VBA-Editor unter "Extras" den Verweis auf die Microsft PowerPoint x.y Object Library aktivieren. Alternativ kannst du im Code auch alle Deklarationen mit PowerPoint.xxx als Object deklarieren.
Gruß
Franz
Textdatei mit neuem Code
https://www.herber.de/bbs/user/121146.txt
Anzeige
AW: Docx zu PDF
19.04.2018 15:44:55
Cord
Komme nicht voran habe den Code soweit ich konnte angepasst bekomme aber in der Zeile
 .WritePassword "passwd"

immer die Fehlermeldung Unzulässige Verwendung einer Eigenschaft.
Ich weiß leider nicht was ich dort Falsch mache
Rest Code füge ich hier ein
Private Sub SavePptxAsNotWriteable()
Dim filePowerpoint As file
Dim fileexcel As file
Dim appPower As Object
On Error GoTo MsgBoxFehler
pResultText = ""
pResultIcon = vbInformation
If Not IsSyllabusWorkbook() Then
pResultText = "Diese Excel Mappe ist keine Courseware Liste!" & vbCrLf & vbCrLf & " _
Bitte verwenden Sie die Korrekte Vorlage" & vbCrLf & "zum Erstellen einer Courseware Liste."
pResultIcon = vbCritical
Exit Sub
End If
If Not TestWorkbookExists() Then
pResultText = "Die Excel Mappe wurde noch nicht gespeichert!" & vbCrLf & vbCrLf & " _
Bitte speichen Sie die Mappe mit dem korrekten Namen" & vbCrLf & "in der Hierarchie des Kurses."
pResultIcon = vbCritical
Exit Sub
End If
TestOpenDocuments
Application.Cursor = xlDefault ' xlWait
Application.StatusBar = "Powerpoint wird geschützt"
Set fileexcel = fso.GetFile(ActiveWorkbook.FullName)
' Start-Ordner setzen für die zu schützenden Powerpoint
Set rootFolder = fileexcel.parentfolder
'Powerpoint-Anwendung starten
Set appPower = CreateObject("Powerpoint.Application")
sPowerpointSecureSave rootFolder
'Powerpoint-Anwendung wieder beenden
appPower.Quit
Set appPower = Nothing
GoTo noerr
MsgBoxFehler:
pResultText = "Fehler Nr. " & Err.Number & " von " & Err.Source & vbCrLf & Err.Description
pResultIcon = vbCritical
noerr:
Application.Cursor = xlDefault
Application.StatusBar = "Powerpoint fertig"
End Sub
Sub sPowerpointSecureSave(ByVal fld As folder)
Dim sfld As folder, ch As Integer
Dim pptdocs As files, pdoc As file, pptdoc As file
Dim dinf As cDocumentInfo, dtyp As itsCwType
Dim pdfpath As String, wassaved As Boolean
Dim fidate As Date, pdfdate As Date
'Dateiliste die Dateien des Ordners zuweisen
Set pptdocs = fld.files
Set dinf = New cDocumentInfo
'Dateiliste im Ordner abarbeiten
For Each pdoc In pptdocs
dinf.FromFileName pdoc.Name
dtyp = dinf.TypeEnum
If dtyp = itsCwTypePowerPoint Then
dinf.Extension = ".pptx"
fidate = pdoc.DateLastModified
pdfpath = fso.BuildPath(fld, dinf.ToFileName)
If fso.FileExists(pdfpath) Then
Set pptdoc = fso.GetFile(pdfpath)
'pdfdate = pdfdoc.DateLastModified
'Else
'   pdfdate = DateSerial(1900, 1, 1)
End If
'If fidate > pdfdate Then
'   Application.StatusBar = "PDF Erstellung für " & sdoc.Name
Set appPpt = CreateObject("Powerpoint.Application")
Set presPpt = appPpt.Presentations.Open(Filename:=pdoc.path, ReadOnly:=False)
With appPpt.Presentations.Open(Filename:=pdoc.path, ReadOnly:=False)
.WritePassword "passwd"
'Dateiname der als PDF gespeicherten Worddatei in Array merken'
pintDoc = pintDoc + 1 'Worddokumente hochzählen  ####neu
ReDim Preserve parrDocs(1 To pintDoc) 'Array erweitern  ####neu
parrDocs(pintDoc) = sdoc.path 'Doc-Name im Array merken ####neu
presPpt.Saved = True
presPpt.Close
Set presPpt = Nothing
End If
End If
DoEvents
Next sdoc
'Abarbeiten der Unterverzeichnisse im Ordner
If fld.subfolders.Count > 0 Then
For Each sfld In fld.subfolders
ch = Asc(Left(sfld.Name, 1))
If ch > 47 And ch 

Ich hoffe auf eure Hilfe
Cord
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige