'The code works as I need it to other than the the error trap "On Error GoTo ThusError" fails. I have set Tools\Options\General to "Break in Class Module" as recommended in https://www.fmsinc.com/free/newtips/VBA/BasicErrorHandling.asp#:~:text=Verify%20Error%20Trapping%20Setting&text=From%20the%20module%20editor%20(IDE,%22On%20Error%20Resume%20Next%22. I also tried "Break on Unhandled Errors" but both settings have no effect.'
Sub ListFiles(fldObj As Object, Mask As String)
Dim fl As Object 'File
Dim db As DAO.Database
Set db = CurrentDb
Dim rst As DAO.Recordset
Set rst = db.OpenRecordset("FileNames", dbOpenDynaset)
For Each fl In fldObj.files
For i = 1 To 16
Extn = Right(fl, i)
If InStr(Extn, ".") > 0 Then
Extn = Right(Extn, i - 1)
i = 16
End If
Next i
On Error GoTo ThisError
If InStr(fl, "$") > 0 _
Or Extn = "lnk" _
Or Extn = "ppm" _
Or InStr(fl, ".") = 0 _
Or Len(Extn) > 4 _
Or Extn = "dat" _
Or CLng(fl.Size / 1024) < 64 _
Or Extn = "sst" _
Or Extn = "ldb" _
Or Extn = "log" _
Or Extn = "WMF" _
Or Extn = "json" Then
SetAttr fl, vbNormal
Kill fl
GoTo LoopOut
End If
ThisError:
If fl.Name Like Mask Then
rst.AddNew
rst("File").Value = Left(fl.Name, Len(fl.Name) - (Len(Extn) + 1))
If (CStr(Err.Number)) = 0 Then rst("ErrNum&Description").Value = " " Else
rst("ErrNum&Description").Value = CStr((Err.Number) & " " & Err.Description)
rst("KB Size").Value = CLng(fl.Size / 1024)
'https://stackoverflow.com/questions/69432605/get-file-size-filelen-of-a-file-that'
'-has-unicode-characters-in-the-name-exce'
rst("Ext").Value = Extn
rst("Home").Value = fldObj
rst.Update
End If
Err.Clear
LoopOut:
Next
End Sub
Your code is riddled with errors. To begin with, variable fl is an object. The FOR...NEXT loop that searches for an extension will fail because you cannot reference part of an object with a keyword that is expecting a string, Right(fl, i) in this case. You need to reference a string property within fl. For example Right(fl.Name, i). That error will not be trapped because the On Error Goto ThisError has not yet been defined. You have the same string related issue with If InStr(fl, "$") > 0, InStr(fl, "."), SetAttr fl, vbNormal, Kill fl, and rst("Home").Value = fldObj. If (CStr(Err.Number)) = 0 should read If Err.Number = 0. There is no need to convert it to a string. The use of the Goto statement to control program flow should be avoided at all costs. Never ever use punctuation or spaces in field names. rst("ErrNum&Description") and rst("KB Size") is asking for no end of trouble.
You should also have Option Explicit as the first line in every module. This will force variable declarations and avoid syntax errors.
I have thrown together a revision of your code to give you an idea of where you should be heading and there is still much more room for improvement. It is NOT error free as the content of your objects is unknown and it has NOT been tested:
Option Explicit
Sub ListFiles(fldObj As Object, Mask As String)
Dim fl As Object 'File
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim i As Integer
Dim Extn As String
Set db = CurrentDb
Set rst = db.OpenRecordset("FileNames", dbOpenDynaset)
On Error GoTo ThisError
For Each fl In fldObj.files
' For i = 1 To 16
' Extn = Right(fl, i)
' If InStr(Extn, ".") > 0 Then
' Extn = Right(Extn, i - 1)
' i = 16
' End If
' Next i
' A simpler way of finding the extension
i = InStrRev(fl.Name, ".")
If i > 0 Then
Extn = Right(Extn, i + 1)
End If
If InStr(fl.Name, "$") > 0 _
Or Extn = "lnk" _
Or Extn = "ppm" _
Or InStr(fl.Name, ".") = 0 _
Or Len(Extn) > 4 _
Or Extn = "dat" _
Or CLng(fl.Size / 1024) < 64 _
Or Extn = "sst" _
Or Extn = "ldb" _
Or Extn = "log" _
Or Extn = "WMF" _
Or Extn = "json" Then
SetAttr fl.Name, vbNormal
Kill fl.Name
End If
LoopOut:
Next
rst.Close
Exit Sub
' Error handling
ThisError:
If fl.Name Like Mask Then
rst.AddNew
rst("File").Value = Left(fl.Name, Len(fl.Name) - (Len(Extn) + 1))
If Err.Number = 0 Then
rst("ErrNum&Description").Value = " "
Else
rst("ErrNum&Description").Value = Err.Number & " " & Err.Description
rst("KB Size").Value = CLng(fl.Size / 1024)
'https://stackoverflow.com/questions/69432605/get-file-size-filelen-of-a-file-that'
'-has-unicode-characters-in-the-name-exce'
rst("Ext").Value = Extn
rst("Home").Value = fldObj.Home '<<< Don't know what Home is.
End If
rst.Update
End If
Err.Clear
' The use of Resume here will let you keep processing all file names if an.
' error occurs. Remove it if you want the routine to end on the first error.
Resume LoopOut
End Sub