Option Explicit

Declare Function StrCmpLogicalW Lib "shlwapi" (ByVal S1 As String, ByVal S2 As String) As Integer

'2.重命名
Public Sub Rename()

    '获取行数
    Dim L As Long
        L = MainSheet.Range("D1").End(xlDown).Row - 2
    
    If L < 0 Or Len(MainSheet.Range("D2").Value) = 0 Then Exit Sub '没有数据退出
    
    '重命名
    Dim F As Long, C As Long
        On Error GoTo ErrRename
        Call MainSheet.Range("E2:E50000").Clear
        For F = 0 To L
            If Len(MainSheet.Range("D2").Offset(F).Value) Then
                C = F
                MainSheet.Range("E2").Offset(F).Value = "OK"
                Name MainSheet.Range("B2").Offset(F).Value As MainSheet.Range("D2").Offset(F).Value
            End If
        Next
        GoTo EXT




ErrRename:
    MainSheet.Range("E2").Offset(C).Value = "错误:" & Err.Description

    Resume Next
EXT:
End Sub

'1.选择文件夹
Public Sub Start()
    '获取选择路径
    Dim OFD As FileDialog
        Set OFD = Excel.Application.FileDialog(msoFileDialogFolderPicker)
        
        Call OFD.Show
        If OFD.SelectedItems.Count = 0 Then Exit Sub
        
        Dim Path As String
        Path = OFD.SelectedItems(1) & "\"
    
    '获取文件,并排序
    Dim Files() As String
    
        On Error GoTo ErrGetDirFiles
        Files = GetDirFiles(Path)
        On Error GoTo 0
        
        Files = FilesOrderByLogical(Files)
    
    '输出
    Dim F As Long, L As Long
        Call MainSheet.Range("A2:E50000").Clear
        
        L = UBound(Files)
        For F = 0 To L
            MainSheet.Range("A2").Offset(F).Value = F + 1
            MainSheet.Range("B2").Offset(F).Value = Path & Files(F)
            MainSheet.Range("C2").Offset(F).Value = GetExName(Files(F))
            MainSheet.Range("D2").Offset(F).Value = Path & "1" & Right("000" & (F + 1), 4) & "." & GetExName(Files(F))
        Next
        GoTo EXT
        


ErrGetDirFiles:
        Call MsgBox("获取文件夹中文件发生错误,文件夹中可能没有文件", vbOKOnly)
        GoTo EXT
        
EXT:
End Sub

'取得文件名的扩展名
Public Function GetExName(ByVal S As String) As String
    Dim I As Long
    I = InStrRev(S, ".")
    If I = -1 Then Exit Function
    GetExName = Mid(S, I + 1)
End Function

'对数组中的字符串进行逻辑排序(升序)
Public Function FilesOrderByLogical(ByRef Files() As String) As String()
    Dim F1 As Long, F2 As Long
    Dim L As Long
    Dim T As String
    
    L = UBound(Files)

    For F1 = 0 To L - 1
        For F2 = F1 + 1 To L
            If StrCmpLogicalW(StrConv(Files(F1), vbUnicode), StrConv(Files(F2), vbUnicode)) > 0 Then
                T = Files(F1)
                Files(F1) = Files(F2)
                Files(F2) = T
            End If
        Next
    Next
    FilesOrderByLogical = Files
End Function

'取得文件夹中的文件,不包含子文件夹
Public Function GetDirFiles(ByVal Path As String) As String()
    
    Dim Files() As String
    Dim C As Long, MAXC As Long
    Dim S As String
    
    MAXC = 100
    ReDim Files(MAXC - 1)
    
    S = Dir(Path)           '第一个文件
    Do While (Len(S))
        Files(C) = S
        C = C + 1
        If C > MAXC Then    '超过数组范围,扩展数组
            MAXC = MAXC * 2
            ReDim Preserve Files(MAXC - 1)
        End If
        S = Dir
    Loop
    
    ReDim Preserve Files(C - 1)
    GetDirFiles = Files
End Function
复制代码