Office: Ungültige Zeichen in String

Josh88 · 14. Juli 2012

Hallo liebe Community

Ich möchte im nachfolgenden VBA-Code die Input Box für den Dateinamen auf ungültige Zeichen überprüfen. Wenn ein ungültiges Zeichen eingegeben wird möchte ich eine MsgBox ausgegeben haben und anschliessend den Vorgang Loopen bis der Dateiname den konventionen entsprechen eingegeben wird.

Anschliessend möchte ich, dass bei der Folder auswahl (gleich nächster Arbeitsschritt im Code) überprüft wird ob der Ausgewählte Dateiname bereits im Verzeichnis existiert und wenn ja den Vorgang erneut loopen.

Ich bin verzweifelt auf der Suche nach einer Lösung für die beiden Probleme, aber komme einfach nicht weiter...

Code:

Option Explicit

Sub SaveAsxlOpenXMLWorkbookMacroEnabled()

Dim strWorkbookName As String
Dim intPos As Integer

'Find position of extension in filename
strWorkbookName = ActiveWorkbook.Name
intPos = InStrRev(strWorkbookName, ".")

If intPos = 0 Then

'If the document has not yet been saved
'Ask the user to provide a filename
strWorkbookName = InputBox("Bitte geben Sie den Namen " & _
"von dem Dokument ein.")

Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
sPath = .SelectedItems.Item(1) & "\"
End With

ActiveWorkbook.SaveAs Filename:=sPath & _
strWorkbookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Else

'Strip off extension and add ".xlsm" extension
strWorkbookName = Left(strWorkbookName, intPos - 1)
strWorkbookName = strWorkbookName & ".xlsm"

End If

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Besten Dank zum Voraus für eure Hilfe

:)

chris-kaiser · 15. Juli 2012

hi

deine IF kannst du ja noch dazubauen......

Code:

Sub SaveAsxlOpenXMLWorkbookMacroEnabled()
Dim strWorkbookName As String
Dim intPos As Integer
Dim sPath As String

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
sPath = .SelectedItems.Item(1) & "\"
End With
Do
strWorkbookName = InputBox("Bitte geben Sie den Namen von dem Dokument ein.")
Dim Regex
Dim temp As String
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.Pattern = "(\/|:|\\|\*|\?|""||\||\.)"
.Global = True
temp = .Replace(strWorkbookName, "")
End With
Loop While Dir(sPath & temp & ".xlsm") "" Or Len(strWorkbookName) Len(temp)

ActiveWorkbook.SaveAs Filename:=sPath & _
strWorkbookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

was auch immer deine ungültigen Zeichen sein mögen *wink.gif*, einfach die Pattern anpassen.

Josh88 · 16. Juli 2012

Hallo Chris

Besten Dank, funktioniert perfekt!!
Wenn du mir jetzt noch sagen kannst, wie ich da eine MsgBox reinkriege wie "Sonderzeichen im Dateinamen, bitte Dateinamen erneut eingeben"

Dann bin ich glücklich *biggrin.gif*

Lg, Josh

chris-kaiser · 16. Juli 2012

Hi

Code:

Option Explicit

Sub SaveAsxlOpenXMLWorkbookMacroEnabled()
Dim strWorkbookName As String
Dim intPos As Integer
Dim sPath As String
Dim check As Boolean

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
sPath = .SelectedItems.Item(1) & "\"
End With
Do
check = False
strWorkbookName = InputBox("Bitte geben Sie den Namen von dem Dokument ein.")
Dim Regex
Dim temp As String
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.Pattern = "(\/|:|\\|\*|\?|""||\||\.)"
.Global = True
temp = .Replace(strWorkbookName, "")
If strWorkbookName = "" Then MsgBox "Bitte geben Sie einen Dateinamen ein!": check = True
If Len(strWorkbookName) Len(temp) Then MsgBox "Bitte keine Sonderzeichen " & Regex.Pattern & " eingeben!": check = True
If Dir(sPath & temp & ".xlsm") "" Then MsgBox "Datei " & sPath & temp & ".xlsm" & " schon vorhanden!, Bitte erneut Namen wählen": check = True
End With
Loop While check = True

ActiveWorkbook.SaveAs Filename:=sPath & _
strWorkbookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Josh88 · 16. Juli 2012

Jetzt funktionierts genau so wie ich will!

Herzlichen Dank Chris!

Topic closed...

haklesoft · 12. Januar 2021

Hai Josh,

von Josh88

Jetzt funktionierts genau so wie ich will!
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

aber ob Deine User damit glücklich werden, wenn Sie Pfad und Dateinamen getrennt eingeben müssen und dann auch noch unzulässige Zeichen vorgehalten bekommen? (Wobei, Chris: Punkte im Dateinamen sind schon erlaubt.) Wenn der genervte User dann in einer der beiden Abfragen Abbruch drückt, crasht gleich die ganze Procedure.

Das Abfragen des Pfades und des Dateinamens kann man auch in einen einzigen Dialog legen und muss dann nicht mal auf gültige Zeichen checken. Einzig die Sache mit dem Verhindern des Überschreibens erfordert eigenen Aufwand.
Code:

Sub SaveAsxlOpenXMLWorkbookMacroEnabled()
Dim bAgain As Boolean
Const csHINWEIS As String = "Der vorgesehene Dateiname ist im gewählten Verzeichnis " & _
"schon vergeben." & vbCrLf & "Bitte einen anderen Dateinamen festlegen."
Const csTITEL As String = "Vorhandene Dateien sollen nicht überschrieben werden"

MachsNochEinmal:
bAgain = False
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.Title = "Verzeichnis wählen und Dateiname festlegen"
If .Show = True Then 'positiver Dialogabschluss
If InStrRev(ActiveWorkbook.Name, ".") Then 'Datei ist schon benannt
If ActiveWorkbook.FullName .SelectedItems(1) Then
'bei abweichendem Namen vorab prüfen, ob es den schon gibt
If Dir(.SelectedItems(1), vbNormal) = vbNullString Then
ActiveWorkbook.SaveAs .SelectedItems(1), FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
MsgBox csHINWEIS, vbInformation, csTITEL
bAgain = True
End If
Else
'gleicher Name wie bisher = Datei überschreiben/refreshen/erneuern zulassen
ActiveWorkbook.Save
End If
Else
'mit neuem Dateinamen speichern, auch hier vorab Dateiexistenz prüfen
If Dir(.SelectedItems(1), vbNormal) = vbNullString Then
ActiveWorkbook.SaveAs .SelectedItems(1), FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else
MsgBox csHINWEIS, vbInformation, csTITEL
bAgain = True
End If
End If
Else
'User wählte Abbruch
End If
End With
If bAgain = True Then GoTo MachsNochEinmal
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hang loose, haklesoft

Office: Ungültige Zeichen in String

Ungültige Zeichen in String

Ungültige Zeichen in String

Ungültige Zeichen in String

Ungültige Zeichen in String - Similar Threads - Ungültige Zeichen String

Ungültiges Argument

Excel Powerquery: Nach Schließen & Laden Fehlermeldung [DataFormat.Error]

Dateiformat oder Dateierweiterung ungültig

Anzeigen oder Ausblenden von Kreisen um ungültige Daten

Laufzeitfehler 5: Ungültiger Prozeduraufruf oder ungültiges Argument

Teams - alle Dateien weg? "Die angegebene Liste ist ungültig"

Microsoft Teams Einladungslink ungültig