Windows Folder Options Affecting Listing of Files (Shell.Application)

[Devin]

My goal is to get file sizes for XML files located in a ZIP folder. I have changed an Excel file’s extension to “.ZIP” and I am trying to only extract the .XML file names. FYI, this may only work on new versions of Windows and Excel. I am using Shell.Application to extract the file names. My problem is the full path—with the “.XML” extension—is only pulled when the folders settings are set to show the extensions (aka the folder options box “Hide extensions for known file types” must not be checked).

Is there a way to extract the file type (.XML) without having to make sure the folder’s settings are adjusted for this?

THANK YOU!

Sub GetSizes()
    Dim FName As String
    Dim MyPath, XMLZip As Variant
    Dim oApp As Object
    MyPath = Environ$("UserProfile") & "\Good.zip\xl\worksheets"
    
    FName = Dir(MyPath)
    Set oApp = CreateObject("Shell.Application")
    
    i = 3
    
    For Each XMLZip In oApp.Namespace(MyPath).Items
    
        If InStr(1, UCase(XMLZip), ".XML", vbTextCompare) > 0 Then
            Range("A" & i).Value = Left(XMLZip, Len(XMLZip) - 4)
            Range("B" & i).Value = XMLZip.Size / 1024
            i = i + 1
        End If
        
    Next
    
    Set oApp = Nothing
    
End Sub

 

[Devin]

I think I found a work around.

Sub GetSizes()
    Dim FName As String
    Dim MyPath, XMLZip As Variant
    Dim oApp As Object
    MyPath = Environ$("UserProfile") & "\Good.zip\xl\worksheets"
    
    FName = Dir(MyPath)
    Set oApp = CreateObject("Shell.Application")
    
    i = 3
    
    For Each XMLZip In oApp.Namespace(MyPath).Items
    
        If InStr(1, UCase(XMLZip), ".XML", vbTextCompare) > 0 Then
            Range("A" & i).Value = Left(XMLZip, Len(XMLZip) - 4)
            Range("B" & i).Value = XMLZip.Size / 1024
            i = i + 1

        Else

            If XMLZip.Type = "XML Document" Then
                Range("A" & i).Value = XMLZip
                Range("B" & i).Value = XMLZip.Size / 1024
                i = i + 1
            End If

        End If

    Next

    Set oApp = Nothing

End Sub