Hello ebarlevi Happy New Year here is a VBA Code for Excel is for extract file name into spreadsheet, maybe this code it will be helpfully for you. Copy and paste on Excel Module, then review if help you. I don't know what is exactly do you want to do but i think this help you.With this code I get DXF files and then open one by one and apply some changes to the drawings.
Public h As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
Public NewSht As Worksheet
Public FolderSelection As String
Public Col As Integer
Public ColConfig As Integer
Public zz As Integer
Public TextToSearch As String
Public Sub MainExtractData()
Dim x As Integer
Col = 13
zz = 5
ColConfig = 12
FolderSelection = "Selecciona el Directorio Principal de los DXF"
Dim MainFolderName As String
MainFolderName = BrowseForFolder()
h = 5
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
'Here you can select or change the kind of files do you want for example here is a DXF file from autocad.
If UCase(Fil.Name) Like "*.DXF" Then
' On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(h, ColConfig) = UCase(Fil.Name)
' On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(h, Col) = oFolder.Path
h = h + 1
End If
Next
Call RecursiveFolder(oFolder)
zz = zz + 1
If IsEmpty(ActiveWorkbook.Worksheets(1).Cells(5, 1)) = True Then
MsgBox "No hay archivos DXF 😞 de la configuración en este folder: " & oFolder.Path
End If
Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.ScreenUpdating = True
End Sub
Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
'Set objFolder = objShell.Namespace(SubFld.Path)
For Each Fil In SubFld.Files
Set objFolder = FSO.GetFolder(oFolder.Path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
'Set objFolderItem = objFolder.ParseName(Fil.Name)
If UCase(Fil.Name) Like "*.DXF" Then
On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(h, ColConfig) = UCase(Fil.Name)
On Error Resume Next
ActiveWorkbook.Worksheets(1).Cells(h, Col) = oFolder.Path
h = h + 1
End If
Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld)
Next
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, FolderSelection, 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
