Question

我希望获得所有照片的精选列表，以及一些exif数据（拍摄日期，相机制作和型号）。

我在大约3000个文件的文件夹中运行它，它完全适用于1796个文件。

我注意到“接下来的错误恢复”，看看发生了什么。

我在这一行收到错误6溢出：

objExif.Load objFile.Path

如果我将已处理的图片从文件夹中移出，则在检查剩余部分时，宏会立即出错。如果我针对新文件夹中已处理的图片运行宏，则不会抛出任何错误。

这导致得出结论，两组图片都有不同之处，但我无法看到。这两组都是未经编辑的数码照片，包含有效的exif数据。

我希望有人可以帮助我吗？

代码：

Private objFSO As Object, objTopFolder As Object, objSubFolder As Object, objFile As Object
Private i As Long
Private objExif As New ExifReader

Sub GetFiles()

    On Error Resume Next

    i = 2
    Worksheets("Filelist").Range("A2:G5000").Value = ""
    Worksheets("Paths").Range("A2:A5000").Value = ""
    Worksheets("Data").Range("E15:E5000").Value = ""

    If Sheets("Data").Range("B2").Value <> "" Then Call Filelist(Sheets("Data").Range("B2").Value, Sheets("Data").Range("C2").Value)
    If Sheets("Data").Range("B3").Value <> "" Then Call Filelist(Sheets("Data").Range("B3").Value, Sheets("Data").Range("C3").Value)
    If Sheets("Data").Range("B4").Value <> "" Then Call Filelist(Sheets("Data").Range("B4").Value, Sheets("Data").Range("C4").Value)
    If Sheets("Data").Range("B5").Value <> "" Then Call Filelist(Sheets("Data").Range("B5").Value, Sheets("Data").Range("C5").Value)
    If Sheets("Data").Range("B6").Value <> "" Then Call Filelist(Sheets("Data").Range("B6").Value, Sheets("Data").Range("C6").Value)
    If Sheets("Data").Range("B7").Value <> "" Then Call Filelist(Sheets("Data").Range("B7").Value, Sheets("Data").Range("C7").Value)
    If Sheets("Data").Range("B8").Value <> "" Then Call Filelist(Sheets("Data").Range("B8").Value, Sheets("Data").Range("C8").Value)
    If Sheets("Data").Range("B9").Value <> "" Then Call Filelist(Sheets("Data").Range("B9").Value, Sheets("Data").Range("C9").Value)
    If Sheets("Data").Range("B10").Value <> "" Then Call Filelist(Sheets("Data").Range("B10").Value, Sheets("Data").Range("C10").Value)
    If Sheets("Data").Range("B11").Value <> "" Then Call Filelist(Sheets("Data").Range("B11").Value, Sheets("Data").Range("C11").Value)

    Sheets("Filelist").Range("G1:G10000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Data").Range("E15"), Unique:=True
    Sheets("Filelist").Range("B2").Select
End Sub

Sub Filelist(TopFolder As String, includesub As String)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTopFolder = objFSO.GetFolder(TopFolder)
    If includesub = "yes" Then
        Call RecursiveFolder(objTopFolder, True)
    Else
        Call RecursiveFolder(objTopFolder, False)
    End If
End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)
    For Each objFile In objFolder.Files
        If Right(objFile.Name, 3) = "jpg" Or Right(objFile.Name, 3) = "JPG" Then
            objExif.Load objFile.Path
            txtDate = objExif.Tag(DateTimeOriginal)
            txtmake = objExif.Tag(Make)
            txtmodel = objExif.Tag(Model)
            Worksheets("Filelist").Cells(i, 1) = objFile.Path
            Worksheets("Paths").Cells(i, 1) = objFile.Path
            Worksheets("Filelist").Cells(i, 2) = objFile.Name
            Worksheets("Filelist").Cells(i, 3) = txtDate
            Worksheets("Filelist").Cells(i, 4) = txtmake
            Worksheets("Filelist").Cells(i, 5) = txtmodel
            Worksheets("Filelist").Cells(i, 7) = Left(txtDate, 4)
            i = i + 1
        End If
    Next objFile

    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
End Sub

Answer 1

好的，经过多次挖掘后发现了它。

我将“on error”语句移动到另一个sub（实际完成所有工作的那个），因此在出错时，会加载下一个文件，而不是完全跳过sub。

现在处理除了一个以外的所有文件。

该文件被证明已损坏。

Private objFSO As Object, objTopFolder As Object, objSubFolder As Object, objFile As Object
Private i As Long
Private objExif As New ExifReader

Sub GetFiles()
    i = 2
    Worksheets("Filelist").Range("A2:G5000").Value = ""
    Worksheets("Paths").Range("A2:A5000").Value = ""
    Worksheets("Data").Range("E15:E5000").Value = ""

    If Sheets("Data").Range("B2").Value <> "" Then Call Filelist(Sheets("Data").Range("B2").Value, Sheets("Data").Range("C2").Value)
    If Sheets("Data").Range("B3").Value <> "" Then Call Filelist(Sheets("Data").Range("B3").Value, Sheets("Data").Range("C3").Value)
    If Sheets("Data").Range("B4").Value <> "" Then Call Filelist(Sheets("Data").Range("B4").Value, Sheets("Data").Range("C4").Value)
    If Sheets("Data").Range("B5").Value <> "" Then Call Filelist(Sheets("Data").Range("B5").Value, Sheets("Data").Range("C5").Value)
    If Sheets("Data").Range("B6").Value <> "" Then Call Filelist(Sheets("Data").Range("B6").Value, Sheets("Data").Range("C6").Value)
    If Sheets("Data").Range("B7").Value <> "" Then Call Filelist(Sheets("Data").Range("B7").Value, Sheets("Data").Range("C7").Value)
    If Sheets("Data").Range("B8").Value <> "" Then Call Filelist(Sheets("Data").Range("B8").Value, Sheets("Data").Range("C8").Value)
    If Sheets("Data").Range("B9").Value <> "" Then Call Filelist(Sheets("Data").Range("B9").Value, Sheets("Data").Range("C9").Value)
    If Sheets("Data").Range("B10").Value <> "" Then Call Filelist(Sheets("Data").Range("B10").Value, Sheets("Data").Range("C10").Value)
    If Sheets("Data").Range("B11").Value <> "" Then Call Filelist(Sheets("Data").Range("B11").Value, Sheets("Data").Range("C11").Value)

    Sheets("Filelist").Range("G1:G10000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Data").Range("E15"), Unique:=True
    Sheets("Filelist").Range("B2").Select
End Sub

Sub Filelist(TopFolder As String, includesub As String)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTopFolder = objFSO.GetFolder(TopFolder)
    If includesub = "yes" Then
        Call RecursiveFolder(objTopFolder, True)
    Else
        Call RecursiveFolder(objTopFolder, False)
    End If
End Sub

Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)
    On Error Resume Next
    For Each objFile In objFolder.Files
        If Right(objFile.Name, 3) = "jpg" Or Right(objFile.Name, 3) = "JPG" Then
            objExif.Load objFile.Path
            txtDate = objExif.Tag(DateTimeOriginal)
            txtmake = objExif.Tag(Make)
            txtmodel = objExif.Tag(Model)
            Worksheets("Filelist").Cells(i, 1) = objFile.Path
            Worksheets("Paths").Cells(i, 1) = objFile.Path
            Worksheets("Filelist").Cells(i, 2) = objFile.Name
            Worksheets("Filelist").Cells(i, 3) = txtDate
            Worksheets("Filelist").Cells(i, 4) = txtmake
            Worksheets("Filelist").Cells(i, 5) = txtmodel
            Worksheets("Filelist").Cells(i, 7) = Left(txtDate, 4)
            i = i + 1
        End If
    Next objFile

    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder(objSubFolder, True)
        Next objSubFolder
    End If
End Sub

处理文件夹中的某些文件时出现溢出错误6

1 个答案: