优化VBA批量提取PNG文件名及尺寸的效率问题

原代码使用Shell.Application读取文件元数据并逐个写入单元格，处理大量PNG时速度极慢——核心原因是Shell接口本身性能低下，且频繁的单元格交互会大幅拖慢执行效率。以下是针对性的优化方案：

核心优化思路 #

1. 直接读取PNG文件头获取尺寸：PNG的宽高信息存储在文件开头固定位置，无需解析整个文件，速度远快于读取元数据。
2. 批量写入Excel单元格：先将数据存入数组，再一次性写入工作表，大幅减少VBA与Excel的交互次数。
3. 过滤目标文件：仅处理PNG格式文件，避免遍历无关文件消耗资源。

优化后的完整代码 #

读取PNG尺寸的辅助函数 #

Private Function GetPNGDimensions(filePath As String) As String
    Dim fileNum As Integer
    Dim widthBytes(3) As Byte, heightBytes(3) As Byte
    Dim width As Long, height As Long
    
    On Error GoTo ErrorHandler
    fileNum = FreeFile
    Open filePath For Binary Access Read As #fileNum
    ' PNG文件头后，第16-19字节为宽度，20-23字节为高度（大端字节序）
    Seek #fileNum, 17
    Get #fileNum, , widthBytes
    Seek #fileNum, 21
    Get #fileNum, , heightBytes
    
    ' 转换大端字节序为长整型
    width = (widthBytes(0) * 256 ^ 3) + (widthBytes(1) * 256 ^ 2) + (widthBytes(2) * 256) + widthBytes(3)
    height = (heightBytes(0) * 256 ^ 3) + (heightBytes(1) * 256 ^ 2) + (heightBytes(2) * 256) + heightBytes(3)
    
    GetPNGDimensions = width & " x " & height
    Close #fileNum
    Exit Function
    
ErrorHandler:
    GetPNGDimensions = "读取失败"
    If fileNum > 0 Then Close #fileNum
End Function

主程序 #

Sub Get_Properties_Men_Optimized()
    Dim fso As Object
    Dim folderClubs As Object, folderComps As Object
    Dim file As Object
    Dim clubData As Variant, compData As Variant
    Dim clubCount As Long, compCount As Long
    Dim i As Long
    
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folderClubs = fso.GetFolder("W:\Gegenpress Graphics\-- Crests Master\Clubs")
    Set folderComps = fso.GetFolder("W:\Gegenpress Graphics\-- Crests Master\Competitions")
    
    ' 统计两个文件夹内的PNG文件数量
    clubCount = 0
    For Each file In folderClubs.Files
        If LCase(fso.GetExtensionName(file.Name)) = "png" Then clubCount = clubCount + 1
    Next
    compCount = 0
    For Each file In folderComps.Files
        If LCase(fso.GetExtensionName(file.Name)) = "png" Then compCount = compCount + 1
    Next
    
    ' 初始化存储数据的数组
    ReDim clubData(1 To clubCount, 1 To 2)
    ReDim compData(1 To compCount, 1 To 2)
    
    ' 收集俱乐部PNG文件数据
    i = 1
    For Each file In folderClubs.Files
        If LCase(fso.GetExtensionName(file.Name)) = "png" Then
            clubData(i, 1) = fso.GetBaseName(file.Name) ' 获取不含扩展名的文件名
            clubData(i, 2) = GetPNGDimensions(file.Path)
            i = i + 1
        End If
    Next
    
    ' 收集赛事PNG文件数据
    i = 1
    For Each file In folderComps.Files
        If LCase(fso.GetExtensionName(file.Name)) = "png" Then
            compData(i, 1) = fso.GetBaseName(file.Name)
            compData(i, 2) = GetPNGDimensions(file.Path)
            i = i + 1
        End If
    Next
    
    ' 批量写入工作表，关闭屏幕更新加速
    Application.ScreenUpdating = False
    If clubCount > 0 Then
        Range(Cells(4, 1), Cells(4 + clubCount - 1, 2)).Value = clubData
    End If
    If compCount > 0 Then
        Range(Cells(4, 4), Cells(4 + compCount - 1, 5)).Value = compData
    End If
    Application.ScreenUpdating = True
    
    MsgBox "Men's crests and competitions added."
    
    ' 释放对象
    Set file = Nothing
    Set folderClubs = Nothing
    Set folderComps = Nothing
    Set fso = Nothing
End Sub

优化效果说明 #

• 读取PNG尺寸的速度提升：直接读取文件头的方式，处理单张PNG的时间几乎可以忽略，相比原方法的元数据读取，效率提升数十倍。
• 写入效率提升：数组批量写入避免了逐单元格操作的开销，尤其在处理大量数据时，这部分优化效果非常明显。
• 资源消耗降低：仅处理目标PNG文件，减少不必要的遍历和计算。

内容的提问来源于stack exchange，提问作者ffc2004