Einen Ordner erstellen (immer mit bestimmtem Unterordner). Ungültige Zeichen sollen entfernt werden und Umlaute konvertiert (Ä = Ae usw.). Im Beispiel wird der Wert aus Zelle A1 genommen.
Create a folder (always with a specific subfolder). Invalid characters should be removed and umlauts converted (Ä = Ae etc.). In the example the value from cell A1 is taken.
Hier noch eine Beispieldatei / Here's a sample file:
API - Ordner erstellen, Zeichen prüfen, Umlaute konvertieren...[XLSB 25 KB]
Code gehört in ein Modul / Code belongs in a module:
Create a folder (always with a specific subfolder). Invalid characters should be removed and umlauts converted (Ä = Ae etc.). In the example the value from cell A1 is taken.
Hier noch eine Beispieldatei / Here's a sample file:
API - Ordner erstellen, Zeichen prüfen, Umlaute konvertieren...[XLSB 25 KB]
Code gehört in ein Modul / Code belongs in a module:
' Variablendeklaration erforderlich!
OptionExplicit
' Bedingte Kompilierung 32Bit/64Bit - Ordner vorhanden? Ordner anlegen.
#If Win64 Then
PrivateDeclarePtrSafeFunctionPathFileExistsLib"shlwapi.dll"_
Alias"PathFileExistsA"(ByValpszPathAsString)AsLongPtr
PrivateDeclarePtrSafeFunctionMakeSureDirectoryPathExists_
Lib"imagehlp.dll"(ByValPfadAsString)AsLong
#Else
PrivateDeclareFunctionPathFileExistsLib"shlwapi.dll"Alias_
"PathFileExistsA"(ByValpszPathAsString)AsLong
PrivateDeclareFunctionMakeSureDirectoryPathExists_
Lib"imagehlp.dll"(ByValPfadAsString)AsLong
#End If
' Pfad anpassen!!!!! Abschließender Backslash NICHT vergessen!!!!
ConststrPathAsString="C:\Temp\"
' Name des Subfolder, der immer zusätzlich erstellt wird
' Abschließender Backslash NICHT vergessen!!!!
ConststrSubFolderAsString="Archiv\"
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 29.02.2020
' Purpose : API - Ordner erstellen - Name in A1 - ungültige Zeichen weg
'--------------------------------------------------------------------------
PublicSubMain()
DimstrFolderAsString
OnErrorGoToFin
' Bezieht sich auf das Tabellenblatt "Tabelle1"
WithThisWorkbook.Worksheets("Tabelle1")
' Wenn in A1 nichts steht - auch keine Leerzeichen, dann...
IfTrim(.Cells(1,1).Value)<>""Then
' Pfad- und Dateiname zusammen zu lang?
IfNotLen(strPath&.Cells(1,1).Value)>250Then
' Nicht erlaubte Zeichen im Ordnername entfernen
' WENN keine Umlaute erlaubt sein sollen, dann einfach
' PATTERN ändern und strFolder = fncSyntax(strFolder)
' auskommentieren!!!!!
strFolder=fncCheckName(.Cells(1,1).Value)
' Umlaute ersetzen
strFolder=fncSyntax(strFolder)
' Prüfe, ob abschließender Backslash vorhanden
IfRight(strFolder,1)<>"\"Then
' Wenn nicht vorhanden, setze Einen am Ende
strFolder=strFolder&"\"
EndIf
' Ordner schon da?
IfPathFileExists(strPath&strFolder)<>0Then
MsgBox"Ordner vorhanden!"
Else
' Ordner erstellen
MakeSureDirectoryPathExists_
(strPath&strFolder&strSubFolder)
MsgBox"Erstellt: "&strPath&strFolder&strSubFolder
EndIf
Else
MsgBox"Pfad- und Dateiname zu lang!"
EndIf
Else
MsgBox"Zelle A1 leer!"
EndIf
EndWith
Fin:
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : fncCheckName
' Author : Case (Ralf Stolzenburg)
' Date : 29.02.2020
' Purpose : REGEXP - ungültige Zeichen Ordnername entfernen...
'--------------------------------------------------------------------------
PrivateFunctionfncCheckName(ByValstrTMPAsString)AsString
DimobjRegExpAsObject
SetobjRegExp=CreateObject("VBScript.RegExp")
WithobjRegExp
.Global=True
.Pattern="[^\wäÄöÖüÜß]"
'.Pattern = "[^\w]"
'.Pattern = "[^A-Za-z0-9_äÄöÖüÜß]"
fncCheckName=.Replace(strTMP,"")
EndWith
SetobjRegExp=Nothing
EndFunction
'--------------------------------------------------------------------------
' Module : Modul1
' Procedure : fncSyntax
' Author : Case (Ralf Stolzenburg)
' Date : 29.02.2020
' Purpose : Replacen - Umlaute und "ß" ersezten...
'--------------------------------------------------------------------------
PrivateFunctionfncSyntax(ByValstrTextAsString)AsString
strText=Replace(strText,"Ä","Ae")
strText=Replace(strText,"Ö","Oe")
strText=Replace(strText,"Ü","Ue")
strText=Replace(strText,"ß","ss")
strText=Replace(strText,"ä","ae")
strText=Replace(strText,"ö","oe")
strText=Replace(strText,"ü","ue")
fncSyntax=strText
EndFunction