Microsoft Excel

Herbers Excel/VBA-Archiv

Vezeichnis erstellen


Betrifft: Vezeichnis erstellen
von: Michael Müller
Geschrieben am: 12.08.2017 12:17:59

Hallo,

ich bin noch Anfänger in der vba-Nutzung und komme bei dem Versuch nicht weiter, ein Verzeichnis erstellen zu lassen.

Ich möchte in dem Verzeichnis, in dem die Arbeitsmappe abgespeichert ist, ein Unterverzeichnis erstellen, das den Namen der Arbeitsmappe erhält.

Es erscheint die Fehlermeldung 75: Fehler beim Zugriff auf Pfad/Datei.

Ich habe folgenden Code verwendet:

Sub Pfadauslesen()
Dim strPfad, strAname, strPname As String

strPfad = ActiveWorkbook.Path
strAname = ActiveWorkbook.Name
strPname = Environ("USERPROFILE")

MsgBox ("ActiveWorkbook.path: " & strPfad)
MsgBox ("ActiveWorkbook.Name: " & strAname)
MsgBox ("Environ (Userprofile):" & strPname)
MsgBox ("Speicherpfad:" & vbLf & strPfad & "\" & strAname)
MsgBox ("Verzeichnis erstellen:" & strPfad & "\" & strAname)
MkDir (strPfad & "\" & strAname)
'MkDir ("TESTTEST")
End Sub
Kann mir jemand weiterhelfen? Danke im Voraus.

Michael

  

Betrifft: AW: Vezeichnis erstellen
von: Sepp
Geschrieben am: 12.08.2017 12:32:39

Hallo Michael,

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub createDirctory()
Dim strPath As String, strName As String


strName = ThisWorkbook.Name
strName = Left(strName, InStrRev(strName, ".") - 1)
strPath = ThisWorkbook.Path & "\" & strName

If MakeSureDirectoryPathExists(strPath) <> 0 Then
  MsgBox "Verzeichnis " & strPath & " erstellt!"
End If
End Sub


Gruß Sepp



  

Betrifft: Korrektur!
von: Sepp
Geschrieben am: 12.08.2017 13:18:32

Hallo Micheal,

hatte den "\" am Ende vergessen.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub createDirctory()
Dim strPath As String, strName As String


strName = ThisWorkbook.Name
strName = Left(strName, InStrRev(strName, ".") - 1)
strPath = ThisWorkbook.Path & "\" & strName & "\"

If MakeSureDirectoryPathExists(strPath) <> 0 Then
  MsgBox "Verzeichnis " & strPath & " erstellt!"
End If
End Sub


Gruß Sepp



  

Betrifft: AW: Korrektur!
von: Michael Müller
Geschrieben am: 13.08.2017 22:48:49

Hallo Sepp,

vielen Dank für den Code. Zwar verstehe ich ihn nicht vollständig, aber er funktioniert und erstellt das gewünschte Unterverzeichnis. Er kürzt sogar noch die Dateierweiterung.

Allerdings erscheint die Messagebox auch, wenn das Verzeichnis bereits existiert. Mal sehen, ob ich das selber hinbekomme.

Jetzt muss ich mir nur noch weitere Informationen anlesen, um den Code vollständig zu verstehen. Es handelt sich dabei um die Zeile
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Gruss
Michael


  

Betrifft: AW: Korrektur!
von: Sepp
Geschrieben am: 14.08.2017 06:35:54

Hallo Michael,

MakeSureDirectoryPathExists ist eine Windows-API-Funktion, sie erstellt einen kompletten Verzeichnispfad.

Prüfen ob ein Verzeichnis schon besteht, kannst du z.B. so.

' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub createDirctory()
Dim strPath As String, strName As String


strName = ThisWorkbook.Name
strName = Left(strName, InStrRev(strName, ".") - 1)
strPath = ThisWorkbook.Path & "\" & strName & "\"

If Dir(strPath, vbDirectory) = "" Then
  If MakeSureDirectoryPathExists(strPath) <> 0 Then
    MsgBox "Verzeichnis " & strPath & " erstellt!"
  End If
End If

End Sub


Gruß Sepp