Speicherort ändern zwecks sonderzeichen
07.02.2020 10:04:50
kai
hab hier noch ein kleines Problemchen mit einem Code und hoffe auf eure Hilfe.
Schonmal ein Mega Dankeschön an Nepumuk, der den Großteil des Codes erstellt hat.
Nun zu meinem Problem:
Es geht darum, anhand von Zellvorgaben (Speicherpfad Zell "P68", Speichername Zelle "P69 einen Neuen Ordner zu erstellen und ein PDF + xlsm inkl. Abfrage ob vorhanden darin zu speichern.
Das ganze klappt auch mit denm Angehängten code. Nur ist es jetzt so, dass es vorkommen kann, dass der Speichername mal ein unzulässiges Zeichen beinhaltet (" : " / " > ") da ist eine Speicherung natürlich nicht möglich. Hierzu habe ich eine Inputbox erstellt in der nach der Fehlermeldung der geänderte Name vergeben werden kann.
Leider wird der geänderte Name nich in die Zelle "P69" übertragen.
Gruß Kai
Hoffe Ihr könnt mir erneut helfen
Option Explicit
Private Declare
Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
Sub Ordner_PDF_XLSM()
Dim DateiName As String
Dim Pfad As String
Dim lw_pfad As String
Dim strFolder As String
Dim lngRetun As Long
With Worksheets("Angebot")
strFolder = .Range("p68").Value
If Right$(strFolder, 1) "\" Then strFolder = strFolder & "\"
strFolder = strFolder & .Range("p69").Value
If Right$(strFolder, 1) "\" Then strFolder = strFolder & "\"
lngRetun = MakeSureDirectoryPathExists(strFolder)
If lngRetun = 0 Then
MsgBox "Fehler beim erstellen ungültiges Zeichen im Ordnername (Zelle P 69).", _
vbCritical, "Fehler"
End If
DateiName = Sheets("Angebot").Range("p69").Value
DateiName = InputBox("Geben Sie hier den Pfad an, wo die Datei gespeichert werden soll." & Chr( _
_
13) & Chr(13), "Datei speichern unter...", DateiName)
If DateiName = "" Then
MsgBox "Die Datei wird nicht gespeichert, da Sie [Abbrechen] gedrückt oder nichts eingegeben _
_
haben.", , "Abbruch"
Exit Sub
Else
If Right(DateiName, 1) "\" Then DateiName =DateiName & "\"
Sheets("Angebot").Range("P69").Value = DateiName
End If
DateiName = strFolder & .Range("p69") & "___" & Format(Date, "DD_MM_YYYY") & ".pdf" '!!! _
_
If Dir$(DateiName) vbNullString Then
If MsgBox("Das PDF existiert bereits." & vbLf & vbLf & _
"Überschreiben?", vbYesNo Or vbQuestion, "Abfrage") = vbYes Then
.Range("C55:K116").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=DateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
Else
.Range("C55:K116").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=DateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
DateiName = strFolder & .Range("p69").Value & "___" & Format(Date, "DD_MM_YYYY") & ". _
xlsm"
If Dir$(DateiName) vbNullString Then
If MsgBox("Die XLSM existiert bereits." & vbLf & vbLf & _
"Überschreiben?", vbYesNo Or vbQuestion, "Abfrage") = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=DateiName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
MsgBox "Die Datei wurde unter " & DateiName & " gespeichert.", _
vbExclamation, "OK"
End If
Else
ActiveWorkbook.SaveAs Filename:=DateiName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "Die Datei wurde unter " & DateiName & " gespeichert.", _
vbExclamation, "OK"
End If
End With
MsgBox "````Endlich geschafft :-)````"
End Sub