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
1420to1424
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

VBA pdf erzeugen und speichern

VBA pdf erzeugen und speichern
27.04.2015 18:28:12
WalterK
Hallo,
der folgende Code sollte aus einer Tabelle eine PDF-Datei erzeugen und falls im Blatt Menü in der Zelle A30 ein Pfad angegeben ist die Datei beiom angegebenen Pfad speichern, oder falls die Zelle A30 leer ist sollte die Datei automatisch auf dem Desktop gespeichert werden.
Es kommt aber der Fehler: Laufzeitfehler 1004 - Anwendungs- oder objektdefinierter Fehler
Sub PDF_Alle_Alphabetisch()
Dim WshShell As Object
Dim wksAlph As Worksheet
Dim wksMenü As Worksheet
Dim Pfad As String
Set wksAlph = Worksheets("Alle_Alphabetisch")
Set wksMenü = Worksheets("MENÜ und NAVIGATION")
Set WshShell = CreateObject("WScript.Shell")
wksMenü.Range("A31") = WshShell.SpecialFolders("Desktop")
If wksMenü.Range("A30") = "" Then
Pfad = wksMenü.Range("A31").Value
Else
Pfad = wksMenü.Range("A30").Value
End If
wksAlph.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Pfad & "\" & wksAlph.Range("B8"). _
Value & "_" & wksAlph.Range("B3").Value & "_" & Date & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
wksMenü.Range("A31").ClearContents
Set WshShell = Nothing
End Sub
Bitte um Ergänzung bzw. Berichtigung zum Erreichen meines Zieles.
Besten Dank und Servus, Walter

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA pdf erzeugen und speichern
28.04.2015 07:41:36
Nepumuk
Hallo,
nicht nachvollziehbar. Was steht denn in Zelle B8 und B3 der Tabelle? Eventuell mag dein Excel die Punkte im Datum nicht.
Gruß
Nepumuk

AW: VBA pdf erzeugen und speichern-Dateiname prüfe
28.04.2015 08:32:31
fcs
Hallo Walter,
entweder ist das Verzeichnis nicht vorhanden, oder der aus den Zellinhalten generierte Dateiename enthält für Dateinamen unzulässige Zeichen.
Außerdem ist es sinnvoll, das Datum im Format JJJJ-MM-TT oder JJJJMMTT einzubauen.
Gruß
Franz
Sub PDF_Alle_Alphabetisch()
Dim WshShell As Object
Dim wksAlph As Worksheet
Dim wksMenü As Worksheet
Dim Pfad As String
Dim Dateiname As String
Set wksAlph = Worksheets("Alle_Alphabetisch")
Set wksMenü = Worksheets("MENÜ und NAVIGATION")
Set WshShell = CreateObject("WScript.Shell")
Dateiname = wksAlph.Range("B8").Value & "_" _
& wksAlph.Range("B3").Value & "_" & Format(Date, "YYYY-MM-DD") & ".pdf"
If fncDateiname_Check(strText:=Dateiname) = False Then
MsgBox "Dateiname" & vbLf & Dateiname & vbLf _
& "enthält eines der unzulässigen/ungünstigen Zeichen " & _
"""  '  /  \  :  |  *  ?    [ ]", _
vbOKOnly, "PDF_Alle_Alphabetisch"
Else
wksMenü.Range("A31") = WshShell.SpecialFolders("Desktop")
If wksMenü.Range("A30") = "" Then
Pfad = wksMenü.Range("A31").Value
Else
Pfad = wksMenü.Range("A30").Value
End If
If Dir(Pfad, vbDirectory)  "" Then
wksAlph.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Pfad & "\" & Dateiname, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
_
OpenAfterPublish:=False
Else
MsgBox "Verzeichnis" & vbLf & Pfad & vbLf & "existiert nicht!", _
vbOKOnly, "PDF_Alle_Alphabetisch"
End If
wksMenü.Range("A31").ClearContents
End If
Set WshShell = Nothing
End Sub
Function fncDateiname_Check(strText As String) As Boolean
'Ungültige Zeichen in Dateinamem
'Anführungszeichen ("), Schrägstrich (/), umgekehrter Schrägstrich (\), _
Doppelpunkt (:), vertikale Linie (|), Stern (*), Fragezeichen (?), _
kleiner (), eckige Klammer aus ([), eckige Klammer zu (])
'ungünstige Zeichen in Dateinamem
'Apostroph (')
Dim arrZeichen, intZeichen As Integer
fncDateiname_Check = True
arrZeichen = Array("""", "'", "/", "\", ":", "|", "*", "?", "", "[", "]")
For intZeichen = LBound(arrZeichen) To UBound(arrZeichen)
If InStr(1, strText, arrZeichen(intZeichen)) > 0 Then
fncDateiname_Check = False
Exit For
End If
Next
End Function

Anzeige
Perfekt! Besten Dank und Servus, Walter
28.04.2015 17:40:27
WalterK

311 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige