FSO.Createfolder skal oprette flere subfolders

Option Explicit

Public Sub CreateFolders(ByVal strPath As String)
Dim fso As Object
Dim strSlash As Integer
Dim strFolderDir As String

Set fso = CreateObject("Scripting.FileSystemObject")
strSlash = 1

Do While strSlash > 0
  strSlash = InStr(strSlash + 1, strPath, "\")
  If strSlash > 0 Then
    strFolderDir = Left(strPath, strSlash - 1)
    If Not fso.FolderExists(strFolderDir) Then
      fso.CreateFolder strFolderDir
    End If
  End If
Loop
If Not fso.FolderExists(strPath) Then
  fso.CreateFolder strPath
End If

Set fso = Nothing
End Sub

Private Sub Form_Load()
' Call CreateFolders("C:\Test\Test2\Test3")
' eller
' Call CreateFolders("C:\Test\Test2\Test3\")
End Sub

Doh - jeg har endda lige siddet og læst ovenstående for et par dage siden (det er et tidligere svar, du kar copy-pastet)

Takker

du kan da godt få den i API hvis du vil:

Option Explicit

Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10

Private Type FILETIME
      dwLowDateTime As Long
      dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
      dwFileAttributes As Long
      ftCreationTime As FILETIME
      ftLastAccessTime As FILETIME
      ftLastWriteTime As FILETIME
      nFileSizeHigh As Long
      nFileSizeLow As Long
      dwReserved0 As Long
      dwReserved1 As Long
      cFileName As String * MAX_PATH
      cAlternate As String * 14
End Type

Private Type SECURITY_ATTRIBUTES
      nLength As Long
      lpSecurityDescriptor As Long
      bInheritHandle As Long
End Type

Private Declare Function FindFirstFile Lib "kernel32" _
                Alias "FindFirstFileA" _
              (ByVal lpFileName As String, _
                lpFindFileData As WIN32_FIND_DATA) As Long
 
Private Declare Function FindClose Lib "kernel32" _
              (ByVal hFindFile As Long) As Long

Private Declare Function CreateDirectory Lib "kernel32" _
                Alias "CreateDirectoryA" _
              (ByVal lpPathName As String, _
                lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Function QualifyPath(ByVal strFolder As String) As String
strFolder = Trim$(strFolder)
If Right$(strFolder, 1) = "\" Then
      QualifyPath = Left$(strFolder, Len(strFolder) - 1)
Else: QualifyPath = strFolder
End If
End Function

Public Function FolderExists(ByVal strFolder As String) As Boolean
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
strFolder = QualifyPath(strFolder)
hFile = FindFirstFile(strFolder, WFD)
FolderExists = (hFile <> INVALID_HANDLE_VALUE) And _
                (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY)
Call FindClose(hFile)
End Function

Public Function CreateFolder(ByVal strFolder As String) As Boolean
Dim SA As SECURITY_ATTRIBUTES
strFolder = QualifyPath(strFolder)
  If Not FolderExists(strFolder) Then
    CreateFolder = CreateDirectory(strFolder, SA)
      Else
    CreateFolder = True
  End If
End Function

Public Sub CreateFolders(ByVal strPath As String)
Dim strSlash As Integer
Dim strFolderDir As String
strSlash = 1
Do While strSlash > 0
  strSlash = InStr(strSlash + 1, strPath, "\")
  If strSlash > 0 Then
    strFolderDir = Left(strPath, strSlash - 1)
    If Not FolderExists(strFolderDir) Then
      Call CreateFolder(strFolderDir)
    End If
  End If
Loop
If Not FolderExists(strPath) Then
  Call CreateFolder(strPath)
End If
End Sub

Private Sub Form_Load()
' Call CreateFolders("C:\Test\Test2\Test3")
' eller
' Call CreateFolders("C:\Test\Test2\Test3\")
End Sub

Holder mig til FSO, som jeg har gang i i forvejen. Tak - hvor i alverden kan du alt det API fra, er du programmør (jeg er jo bare hobby-VB'er)? Jeg har lagt mærke til, at du kan svare på alt hvad der har med API at gøre (og meget andet i øvrigt :o)

Jeg skulle gerne kunne lidt når jeg har arbejdet med vb i ca. 4 år 5-8 timer om dagen. :D

Ahhh - det er snyd :o)