PDA

Vollständige Version anzeigen : Ungültige Zeichen in String


Josh88
16.07.2012, 09:39
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...

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

Besten Dank zum Voraus für eure Hilfe

chris-kaiser
16.07.2012, 10:53
hi


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

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

was auch immer deine ungültigen Zeichen sein mögen ;), einfach die Pattern anpassen.

Josh88
16.07.2012, 11:59
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 :D

Lg, Josh

chris-kaiser
16.07.2012, 12:17
Hi


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

Josh88
16.07.2012, 12:42
Jetzt funktionierts genau so wie ich will!

Herzlichen Dank Chris!

Topic closed...

haklesoft
16.07.2012, 16:52
Hai Josh,Jetzt funktionierts genau so wie ich will! 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.
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 SubHang loose, haklesoft