VB6 - 是否可以创建完整路径目录？

Question

我想创建一个完整的路径目录，例如："C:\temp1\temp2\temp2"，而不需要为每个目录都执行多次 "MakeDir"。 这是否有可能？

是否有任何可以添加到我的项目中具有此类功能的参考资料？

谢谢。

- RSilva

Answer 1

您可以使用以下函数使任务变得更容易：

Const PATH_SEPARATOR As String = "\"

'"' Creates a directory and its parent directories '''

Public Sub MakeDirectoryStructure(strDir As String)
    Dim sTemp As String

    If Right$(strDir, 1) = PATH_SEPARATOR Then
        sTemp = Left$(strDir, Len(strDir) - 1)
    Else
        sTemp = strDir
    End If
    If Dir(strDir, vbDirectory) <> "" Then
        ' Already exists.'
    Else
        'We have to create it'
        On Error Resume Next
        MkDir strDir
        If Err > 0 Then
        ' Create parent subdirectory first.'
            Err.Clear
            'New path'
            sTemp = ExtractPath(strDir)
            'Recurse'
            MakeDirectoryStructure sTemp
        End If
        MkDir strDir
    End If
End Sub  


Public Function ExtractPath(strPath As String) As String
    ExtractPath = MiscExtractPathName(strPath, True)
End Function


Private Function MiscExtractPathName(strPath As String, ByVal bFlag) As String
    'The string is treated as if it contains                   '
    'a path and file name.                                     '
    ''''''''''''''''''''''''''''''­''''''''''''''''''''''''''''''
    ' If bFlag = TRUE:                                         '
    '                   Function extracts the path from        '
    '                   the input string and returns it.       '
    ' If bFlag = FALSE:                                        '
    '                   Function extracts the File name from   '
    '                   the input string and returns it.       '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim lPos As Long
    Dim lOldPos As Long
    'Shorten the path one level'
    lPos = 1
    lOldPos = 1
    Do
        lPos = InStr(lPos, strPath, PATH_SEPARATOR)
        If lPos > 0 Then
            lOldPos = lPos
            lPos = lPos + 1
        Else
            If lOldPos = 1 And Not bFlag Then
                lOldPos = 0
            End If
            Exit Do
        End If
    Loop
    If bFlag Then
        MiscExtractPathName = Left$(strPath, lOldPos - 1)
    Else
        MiscExtractPathName = Mid$(strPath, lOldPos + 1)
    End If
End Function            ' MiscExtractPathName'

我不确定这段代码是从哪里来的。

- Jay Riggs

---

我稍微编辑了一下代码，以使语法高亮正常工作。 - Mike Spross

Answer 2

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

Dim mF As String

mF = FolderPath

If Right(mF, 1) <> "\" Then 
    mF = mF & "\"
    MakeSureDirectoryPathExists mF
End If

- Pine Pet

Answer 3

此前已有人提出并回答了类似问题：

equivalent-of-directory-createdirectory-in-vb6

- George Mastros

Answer 4

'//Create nested folders in one call

Public Function MkDirs(ByVal PathIn As String) _
   As Boolean
   Dim nPos As Long
   MkDirs = True  'assume success
   If Right$(PathIn, 1) <> "\" Then PathIn = PathIn + "\"    nPos = InStr(1, PathIn, "\")

   Do While nPos > 0
       If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then
           On Error GoTo Failed
               MkDir Left$(PathIn, nPos)
           On Error GoTo 0
       End If
       nPos = InStr(nPos + 1, PathIn, "\")
   Loop

   Exit Function
Failed:
   MkDirs = False
End Function 

- Robert French