[VBA]列出資料夾下所有檔案編碼

2015-11-14

2249
0
VBA
2015-11-23

[VBA]列出資料夾下所有檔案編碼

紀錄一下過程。

問題描述

資料夾下的檔案有ANSI及unicode編碼的檔案，想要區分。

解決方式

撰寫Excel，列出檔案清單及編碼方式。

EncodingUtil.bas : 判斷檔案編碼。


'*************************************************************************************
'專案名稱: VBA專案
'功能描述:
'取得檔案編碼方式
'程式撰寫: Dunk
'撰寫日期：2015/11/11
'
'改版日期:
'改版備註:
'*************************************************************************************
Public Enum Encoding
ANSI
Unicode
UnicodeBigEndian
UTF8
End Enum
'取得編碼名稱
Public Function GetEncodingName(ByVal enc As Encoding) As String
    Select Case enc
        Case ANSI: GetEncodingName = "ANSI"
        Case Unicode: GetEncodingName = "Unicode"
        Case UnicodeBigEndian: GetEncodingName = "UnicodeBigEndian"
        Case UTF8: GetEncodingName = "UTF8"
    End Select
End Function
'從文字檔取得編碼方式
Public Function GetEncoding(FileName As String) As Encoding
Dim fBytes(1) As Byte, freeNum As Integer

freeNum = FreeFile

Open FileName For Binary Access Read As #freeNum
Get #freeNum, , fBytes(0)
Get #freeNum, , fBytes(1)
Close #freeNum

If fBytes(0) = &HFF And fBytes(1) = &HFE Then
    GetEncoding = Encoding.Unicode
ElseIf fBytes(0) = &HFE And fBytes(1) = &HFF Then
    GetEncoding = Encoding.UnicodeBigEndian
ElseIf fBytes(0) = &HEF And fBytes(1) = &HBB Then
    GetEncoding = Encoding.UTF8
Else
    GetEncoding = Encoding.ANSI
End If

End Function

FileIOUtility.bas : 檔案清單。



Sub WriteFile(ByVal FileName As String, ByVal content As String)
Open FileName For Output As #1
Print #1, content
Close #1
End Sub

Function ReadFile(ByVal infilename As String)
    'Microsoft Scripting Runtime設定引用項目
    Dim myFso As Scripting.FileSystemObject
    Dim myTxt As Scripting.TextStream
    Dim myStr As String
    Dim resultString() As Variant
    ReDim resultString(1048576)
    Dim rowNumber As Integer
    rowNumber = 0
    
    Set myFso = CreateObject("Scripting.FileSystemObject")
    '指定檔案名稱
    Set myTxt = myFso.OpenTextFile(FileName:=infilename, _
        IOMode:=ForReading)
    With myTxt
        Do Until .AtEndOfStream
            resultString(rowNumber) = CStr(.ReadLine)
            rowNumber = rowNumber + 1
        Loop
        .Close
    End With
    'Debug.Print rowNumber
    ReDim Preserve resultString(rowNumber)
    Set myTxt = Nothing                            '釋放物件
    Set myFso = Nothing
    ReadFile = resultString
    
End Function

'列出檔案清單
'depth=0
Function RetrivalFileList(ByVal strDir As String, ByRef myRange As Range, ByRef depth As Integer)
    Dim thePath As String
    Dim strSdir As String
    Dim theDirs As Scripting.Folders
    Dim theDir As Scripting.Folder
    Dim theFile As Scripting.File
    Dim myFso As Scripting.FileSystemObject
    Dim subFolderCount As Integer
    
    Set myFso = New Scripting.FileSystemObject
    If Right(strDir, 1) <> "" Then strDir = strDir & ""
    thePath = thePath & strDir
        
    '列出第一層根目錄的檔案
    If depth = 0 Then
            For Each theFile In myFso.getfolder(strDir).Files
                myRange = theFile.Path
                myRange.Hyperlinks.Add Anchor:=myRange, Address:= _
        theFile.Path, _
        TextToDisplay:= _
        theFile.Path
                myRange.Next = theFile.Size
                myRange.Next.Next = theFile.DateCreated
                myRange.Next.Next.Next = theFile.DateLastModified
                Set myRange = myRange.Offset(1, 0)
            Next
            depth = 1
    End If
        
    '尋找所有子目錄的檔案
    Set theDirs = myFso.getfolder(strDir).SubFolders
    For Each theDir In theDirs
        For Each theFile In theDir.Files
            myRange = theFile.Path
            myRange.Hyperlinks.Add Anchor:=myRange, Address:= _
        theFile.Path, _
        TextToDisplay:= _
        theFile.Path
            myRange.Next = theFile.Size
            myRange.Next.Next = theFile.DateCreated
            myRange.Next.Next.Next = theFile.DateLastModified
            Set myRange = myRange.Offset(1, 0)
        Next
        RetrivalFileList strDir:=theDir.Path, myRange:=myRange, depth:=depth
    Next
    Set myFso = Nothing
End Function

'列出檔案編碼清單
'depth=0
Function RetrivalFileEncodingList(ByVal strDir As String, ByRef myRange As Range, ByRef depth As Integer)
    Dim thePath As String
    Dim strSdir As String
    Dim theDirs As Scripting.Folders
    Dim theDir As Scripting.Folder
    Dim theFile As Scripting.File
    Dim myFso As Scripting.FileSystemObject
    Dim subFolderCount As Integer
    
    Set myFso = New Scripting.FileSystemObject
    If Right(strDir, 1) <> "" Then strDir = strDir & ""
    thePath = thePath & strDir
        
    '列出第一層根目錄的檔案
    If depth = 0 Then
            For Each theFile In myFso.getfolder(strDir).Files
                myRange = theFile.Path
                myRange.Hyperlinks.Add Anchor:=myRange, Address:= _
        theFile.Path, _
        TextToDisplay:= _
        theFile.Path
                'myRange.Next = theFile.Size
                myRange.Next = EncodingUtil.GetEncodingName(EncodingUtil.GetEncoding(theFile.Path))
                myRange.Next.Next = theFile.DateCreated
                myRange.Next.Next.Next = theFile.DateLastModified
                Set myRange = myRange.Offset(1, 0)
            Next
            depth = 1
    End If
        
    '尋找所有子目錄的檔案
    Set theDirs = myFso.getfolder(strDir).SubFolders
    For Each theDir In theDirs
        For Each theFile In theDir.Files
            myRange = theFile.Path
            myRange.Hyperlinks.Add Anchor:=myRange, Address:= _
        theFile.Path, _
        TextToDisplay:= _
        theFile.Path
            'myRange.Next = theFile.Size
            myRange.Next = EncodingUtil.GetEncodingName(EncodingUtil.GetEncoding(theFile.Path))
            myRange.Next.Next = theFile.DateCreated
            myRange.Next.Next.Next = theFile.DateLastModified
            Set myRange = myRange.Offset(1, 0)
        Next
        RetrivalFileList strDir:=theDir.Path, myRange:=myRange, depth:=depth
    Next
    Set myFso = Nothing
End Function


'列出所有子目錄名稱大小及最後修改日期
Function RetrivalAllSubFolderList(ByVal strDir As String, ByRef myRange As Range)
    Dim thePath As String
    Dim strSdir As String
    Dim theDirs As Scripting.Folders
    Dim theDir As Scripting.Folder
    Dim theFile As Scripting.File
    Dim myFso As Scripting.FileSystemObject
    Dim subFolderCount As Integer
    
    Set myFso = New Scripting.FileSystemObject
    If Right(strDir, 1) <> "" Then strDir = strDir & ""
    thePath = thePath & strDir
                  
    '尋找所有子目錄
    Set theDirs = myFso.getfolder(strDir).SubFolders
    For Each theDir In theDirs
        myRange = theDir.Path
        myRange.Hyperlinks.Add Anchor:=myRange, Address:= _
        theDir.Path, _
        TextToDisplay:= _
        theDir.Path
        myRange.Next = theDir.Size
        myRange.Next.Next = theDir.DateCreated
        myRange.Next.Next.Next = theDir.DateLastModified
        Set myRange = myRange.Offset(1, 0)
        RetrivalAllSubFolderList strDir:=theDir.Path, myRange:=myRange
    Next
    Set myFso = Nothing
End Function

FileInfo.bas : 工作頁與畫面設定。



Sub 列出檔案相關資訊()
    Dim selectFolder As String
    Dim myFd As FileDialog
    Set myFd = Application.FileDialog(msoFileDialogFolderPicker)  '[選擇檔案]
        With myFd
        .Title = "請選擇資料夾路徑"
        .ButtonName = "確定"
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = True Then            '顯示
            selectFolder = .SelectedItems(1)
        Else
            Call 設定標題(1)
            ActiveWorkbook.Worksheets("檔案清單").Columns.AutoFit
            MsgBox "已取消"
            Exit Sub
        End If
    End With
    
    Application.ScreenUpdating = False
    
    '清除排序設定
    ActiveWorkbook.Worksheets("檔案清單").ListObjects("檔案清單_表格").Sort.SortFields.Clear
    
    Call 列出檔案清單(selectFolder)
    
    MsgBox "列出檔案資訊完畢!"
    Application.ScreenUpdating = True
    
End Sub


Sub 設定標題(ByVal sheetIndex As Integer)
    '清除內容並將將儲存格格式設為文字格式
    Dim pt As Range
    Dim myRange As Range
    Dim i As Integer
    Set pt = ThisWorkbook.Sheets(sheetIndex).Range("a2")
    For i = 1 To 4
        pt.Worksheet.Columns(i).ClearContents
    Next
    Set myRange = ThisWorkbook.Sheets(sheetIndex).Range("A1:B1048576")
    myRange.NumberFormatLocal = "@"
    
    Set myRange = ThisWorkbook.Sheets(sheetIndex).Range("c2:d1048576")
    myRange.NumberFormatLocal = "yyyy/mm/dd h:mm;@"
            
    '設定標題
    ThisWorkbook.Sheets(sheetIndex).Range("A1").Value = "檔案路徑"
    ThisWorkbook.Sheets(sheetIndex).Range("B1").Value = "編碼"
    ThisWorkbook.Sheets(sheetIndex).Range("C1").Value = "建立時間"
    ThisWorkbook.Sheets(sheetIndex).Range("D1").Value = "修改時間"
End Sub

Sub 列出檔案清單(ByVal theDir As String)
    Dim pt As Range
                
    Set pt = Sheet1.Range("a2")
    Call 設定標題(1)
                
    If Len(Dir(theDir, vbDirectory)) > 0 Then
        If (GetAttr(theDir) And vbDirectory) = vbDirectory Then
            Call FileIOUtility.RetrivalFileEncodingList(theDir, pt, 0)
        End If
    End If
    
    pt.Worksheet.Columns("A:D").AutoFit
End Sub

Sub 列出子目錄清單(ByVal theDir As String)
    Dim pt As Range
                    
    Set pt = Sheet2.Range("a2")
    Call 設定標題(2)
    
    If Len(Dir(theDir, vbDirectory)) > 0 Then
        If (GetAttr(theDir) And vbDirectory) = vbDirectory Then
        Call FileIOUtility.RetrivalAllSubFolderList(theDir, pt)
        End If
    End If
    
    pt.Worksheet.Columns("A:D").AutoFit
End Sub

結果畫面

注意事項

檔案是根據檔頭前兩碼判斷編碼，如果檔案有位元組順序記號（byte-order mark，BOM），可能會造成誤判，會自動歸類到ANSI。

參考資料

Unicode 與 UTF

UTF-8

Can you reference an enum value as a string

位元組順序記號

[VBA]檔案清單

回首頁