vb6选择文件夹如何支持仅选择文件夹，并支持显示完整路径、新建文件夹 - 编程论坛

#2

wds12023-03-31 10:17

chatgpt生成的【vb6选择文件夹如何支持仅选择文件夹，并支持显示完整路径、新建文件夹】
'此代码假定您的表单上有一个名为CommonDialog1的CommonDialog控件。如果您没有此控件，则需要将其添加到您的表单中。
' 仅允许用户选择文件夹，使用以下代码：
Dim folderPath As String
With CommonDialog1
    .DialogTitle = "选择文件夹"
    .Filter = "文件夹|*.none"
    .InitDir = "C:\"
    .Flags = cdlOFNNoValidate '设置标志以仅允许选择文件夹
    .ShowOpen
    folderPath = .FileName
End With

' 显示所选文件夹的完整路径，使用以下代码：
MsgBox "所选文件夹: " & folderPath

' 允许用户创建新文件夹，使用以下代码：
Dim newFolderName As String
newFolderName = InputBox("输入新文件夹的名称:")
If newFolderName <> "" Then
    MkDir folderPath & "\" & newFolderName
End If

#3

foreach2023-03-31 14:39

回复 2楼 wds1

你好，你这些代码，我发贴之前也从ChatGPT得到过，实际上它是选择文件，返回文件夹地址。
假设文件夹内是空的，就无法返回文件夹地址了

#4

yuma2023-04-03 19:09

在VB6中，可以使用CommonDialog控件来实现选择文件夹的功能。以下是一份示例代码：

在窗体上添加一个CommandButton和一个CommonDialog控件。

在CommandButton的Click事件中添加以下代码：

Private Sub Command1_Click()
    With CommonDialog1
        .DialogTitle = "选择文件夹"
        .Filter = "文件夹|*.none"
        .Flags = cdlOFNNoValidate Or cdlOFNHideReadOnly Or cdlOFNExplorer Or cdlOFNPathMustExist Or cdlOFNEnableHook
        .ShowOpen
        If .FileName <> "" Then
            Text1.Text = .FileName
        End If
    End With
End Sub

在窗体上添加一个TextBox控件，用于显示选择的文件夹路径。

在窗体的Load事件中添加以下代码：

Private Sub Form_Load()
    CommonDialog1.FileName = ""
End Sub

这样就可以实现选择文件夹的功能，并且支持显示完整路径、新建文件夹。需要注意的是，CommonDialog控件的Filter属性需要设置为"文件夹|*.none"，这样才能只显示文件夹而不显示文件。同时，Flags属性需要设置为cdlOFNExplorer，这样才能显示地址栏和新建文件夹按钮。

#5

foreach2023-04-04 15:51

回复 4楼 yuma

这个也是无法单独选择文件夹的

#6

风吹过b2023-04-04 17:04

转自 https://
本次未测试，很早以前测试过类似的代码，但我不喜欢这种框框。

程序代码：

'---------------------------------------------------------------------------------------
' Module    : ModuleFile
' Author    : ROVAST
' Date      : 2014-4-22
' Purpose   : 文件相关操作模块
' Function  : 1、选取文件夹
'---------------------------------------------------------------------------------------

Option Explicit

Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const BIF_NEWDIALOGSTYLE = &H40
Const BIF_EDITBOX = &H10
Const BIF_USENEWUI = BIF_NEWDIALOGSTYLE Or BIF_EDITBOX
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long


'---------------------------------------------------------------------------------------
' Procedure : BrowseForFolder
' Author    : ROVAST
' Date      : 2014-4-22
' Purpose   : 选取文件夹（不含新建文件夹指令）返回BrowseForFolder
'---------------------------------------------------------------------------------------
'
Public Function BrowseForFolder(Optional sTitle As String = "请选择文件夹") As String
    Dim iNull As Integer, lpIDList As Long, lResult As Long
    Dim sPath As String, udtBI As BrowseInfo

    With udtBI
        .hWndOwner = 0 ' Me.hWnd
        .lpszTitle = lstrcat(sTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI
    End With
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
       sPath = String$(MAX_PATH, 0)
        SHGetPathFromIDList lpIDList, sPath
        CoTaskMemFree lpIDList
       iNull = InStr(sPath, vbNullChar)
        If iNull Then
          sPath = Left$(sPath, iNull - 1)
        End If
    End If

    BrowseForFolder = sPath
End Function


'---------------------------------------------------------------------------------------
' Procedure : BrowseForFolder1
' Author    : ROVAST
' Date      : 2014-4-22
' Purpose   : 选取文件夹路径（含新建文件夹）返回BrowseForFolder1 字符串
'---------------------------------------------------------------------------------------
'
Public Function BrowseForFolder1(Optional sTitle As String = "请选择文件夹") As String
    Dim iNull As Integer, lpIDList As Long, lResult As Long
    Dim sPath As String, udtBI As BrowseInfo

    With udtBI
        .hWndOwner = 0 ' Me.hWnd
        .lpszTitle = lstrcat(sTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList Then
       sPath = String$(MAX_PATH, 0)
        SHGetPathFromIDList lpIDList, sPath
        CoTaskMemFree lpIDList
       iNull = InStr(sPath, vbNullChar)
        If iNull Then
          sPath = Left$(sPath, iNull - 1)
        End If
    End If

    BrowseForFolder1 = sPath
End Function

在主窗体中可以插入按钮。添加下述代码，其中前一个没有新建文件夹功能，后一个有新建文件夹功能

程序代码：

Option Explicit

Private Sub Command1_Click()
Dim path1 As String
path1 = BrowseForFolder
MsgBox path1
End Sub

Private Sub Command2_Click()
Dim path As String
path = BrowseForFolder1
MsgBox path
End Sub

#7

小fisher2023-04-28 09:45

Private Sub Command1_Click()
    Dim sh, fd
    Set sh = CreateObject("shell.application")
    '第三个参数的说明见https://learn.关于ulFlags参数的说明
    Set fd = sh.BrowseForFolder(Me.hWnd, "选择文件夹", 1)
    If Not fd Is Nothing Then
        Debug.Print fd.Self.Path
    End If
End Sub