取出目錄下所有子目錄的檔名,使用 VB6

最近為了整理文件,需要將某資料夾裡所有檔案各別列出說明,
雖然使用 DIR /s/o >> FileName.txt 的指令可以直接存成檔案,但輸出格式無法很方便使用,
所以昨天花了點時間,用 VB6 寫了個程式,可以列出指定目錄下的所有檔案為我自己要的格式。
主要是呼叫 Windows API 並用遞回的寫法,把檔名全都列出來

Call API 的寫法如下

'=================================
'=== Call API 的設定
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

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
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long

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
'=================================

Function OpenFolderPath() As String
    '=======================================
    '用 VB 呼叫出在【尋找：所有檔案】中的【瀏覽資料夾】問話框
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim szTitle As String
    Dim tBrowseInfo As BrowseInfo
    szTitle = "請選擇要開始搜尋的資料夾...."    '<-- 此標題可根據需要自行更改
    
    With tBrowseInfo
        .hWndOwner = Me.hWnd
        .lpszTitle = lstrcat(szTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
    End With
    
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        OpenFolderPath = sBuffer    '傳回路徑字串
    End If
End Function

遞回的寫法如下:

''=== 取該目錄下所有檔名
Private Function GetFileName(ByVal strFilePath As String, ByVal strInsertString As String) As String
    Dim retString As String
    Dim F1, fc
    Dim objF As Object  '定義開檔物件
    Dim objFs2 As Scripting.FileSystemObject

    strInsertString = gstrFileInsertString & strInsertString
    
    Set objFs2 = CreateObject("Scripting.FileSystemObject")
    Set objF = objFs2.GetFolder(strFilePath)
    Set fc = objF.Files
    '抓取要讀入的檔名資料
    For Each F1 In fc
        retString = retString & strInsertString & F1.Name & vbCrLf
    Next

    Set objFs2 = Nothing '釋放FileSystemObject 物件
    Set objF = Nothing
    
    GetFileName = retString
End Function

''=== 用遞回方式取出子目錄下所有檔名
Private Function GetSubFolder(ByVal strFolderPath As String, ByVal strFolderInsertString As String, ByVal strFileInsertString As String) As String
    '==================================按下儲存資料夾名稱時
    Dim F1, fc
    Dim objF As Object  '定義開檔物件
    Dim strFoldersName As String    '定義資料夾名稱為字串型態
    Dim objFs2 As Scripting.FileSystemObject
    Dim strInsertString As String
    Dim strLogString As String
    
    strFolderInsertString = gstrFolderInsertString & strFolderInsertString
    strInsertString = gstrFileInsertString & strFileInsertString


    Set objFs2 = CreateObject("Scripting.FileSystemObject")
    Set objF = objFs2.GetFolder(strFolderPath)
    Set fc = objF.SubFolders
    '抓取要讀入的資料夾名稱資料
    For Each F1 In fc
        strLogString = strLogString & vbCrLf & strFolderInsertString & "[" & F1.Name & "]" & vbCrLf
        strLogString = strLogString & GetFileName(strFolderPath & "\" & F1.Name, strInsertString)

        strLogString = strLogString & GetSubFolder(strFolderPath & "\" & F1.Name, strFolderInsertString, strInsertString)
        
        DoEvents
    Next
    
    Set objF = Nothing
    Set objFs2 = Nothing '釋放FileSystemObject 物件
    
    GetSubFolder = strLogString
End Function

由於這個程式只是臨時要用花個半天時間寫的,
很多細節沒有去 Handle,能用就好,
有需要的人自行下載程式碼回去修改。
執行檔下載(7.9K)
原始程式碼下載(3.3K)
程式畫面如下