[sf]

Как получить Список файлов в директории (поддиректорий)

[paha]

Насчет списка файлов - это к скриптам, делай что пожелаешь. Мучался примерно таким же вопросом, когда отправили к скриптам муки прошли.

[Miniril]

Да, тема конечно старая, но нигде не нашел, где бы был подходящий пример кода... вот, вдруг кому понадобится...
просто чуть доработал код с этой ссылки, добавив просмотр поддиректорий:
http://www.cad.dp.ua/stats/a_vba/acs...essAllDrawings

Код:

[Выделить все]

Option Explicit

' Пример запроса у пользователя папки с помощью
' API функции SHBrowseForFolder из файла shell32.dll
Public FileInfo() As String
Public Type BrowseInfo
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Const MAX_PATH = 260
Public colFiles As New Collection

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long

Declare Function SHGetPathFromIDList Lib _
"shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Public Function ReturnFolder(lngHwnd As Long) As String
  Dim Browser As BrowseInfo
  Dim lngFolder As Long
  Dim strPath As String
   
  With Browser
    .hOwner = lngHwnd
    .lpszTitle = "Select Directory to work in"
    .pszDisplayName = String(MAX_PATH, 0)
  End With
  strPath = String(MAX_PATH, 0) '<-- VERY Important!!
  lngFolder = SHBrowseForFolder(Browser)
  If lngFolder Then
    SHGetPathFromIDList lngFolder, strPath
    ReturnFolder = Left(strPath, InStr(strPath, vbNullChar) - 1)
  End If
End Function

Public Function ParseOut(strIn As String, strChar As String) As String
  Dim intCnt As Integer
  Dim strfile As String

  intCnt = 1
  Do
    If Mid(strIn, intCnt, 1) = strChar Then
      strfile = Mid(strIn, 1, intCnt - 1)
      strIn = Mid(strIn, intCnt + 1, Len(strIn))
      ParseOut = strfile
      Exit Function
    End If
    intCnt = intCnt + 1
  Loop
  End Function

Public Sub OpenAndProcessAllDrawings()
  Dim objSelSet As AcadSelectionSet
  Dim objDoc As AcadDocument
  Dim objEnt As AcadEntity
  Dim strFolder As String
  Dim intCnt As Integer
  Dim strName As String

  On Error GoTo Err_Control
  strFolder = ReturnFolder(0&)
  If Len(strFolder) > 0 Then
    FindFile colFiles, strFolder, "dwg"
    For intCnt = 1 To colFiles.Count
      Set objDoc = OpenAnyMode(colFiles(intCnt))
      objDoc.Activate
      Set objSelSet = vbdPowerSet("processall")
      objSelSet.Select acSelectionSetAll
      For Each objEnt In objSelSet
        'Call your procedure here
        'Выполнение процедуры над всеми 
        'объектами открытого файла
        bjEnt.Layer = 0 ' Перемещение объектов на слой 0
      Next objEnt
      'To save your changes uncomment this line
      'objDoc.Close True
      'To close without saving uncomment this line
      'objDoc.Close False
    Next intCnt
  End If
Exit_here:
  Exit Sub
Err_Control:
  'because error handling can be varied depending
  'on what you are doing, I have left this to simply
  'dump out if an error occurs.
  MsgBox Err.Description
  Resume Exit_here
End Sub

Public Function OpenAnyMode(strFileName As String) As AcadDocument
  Dim varMode As Variant
  Dim intCnt As Integer
  Dim objDoc As AcadDocument
  On Error GoTo Err_Control
  intCnt = Application.Documents.count
  If intCnt > 0 Then
  varMode = ThisDrawing.GetVariable("SDI")
    If varMode Then
      Set objDoc = ThisDrawing.Open(strFileName)
    Else
      Set objDoc = Application.Documents.Open(strFileName)
    End If
  Else
    Set objDoc = Application.Documents.Open(strFileName)
  End If
  Set OpenAnyMode = objDoc
Exit_here:
  Exit Function
Err_Control:
  MsgBox "Error opening " & strFileName & vbCrLf & _
  Err.Description
  Resume Exit_here
End Function

Public Sub FindFile(ByRef files As Collection, strDir, strExt)
  Dim strFileName As String
  Dim Dirs() As String
  Dim NumDirs As Long
  Dim i As Long
  
  If (Right(strDir, 1) <> "\") Then strDir = strDir & "\"
  
  strFileName = Dir(strDir & "*.*", vbDirectory)
  
  Do While Len(strFileName) <> 0
    If Left(strFileName, 1) <> "." Then 'Current dir
        If (GetAttr(strDir & strFileName) And vbDirectory) = vbDirectory Then
          'сохранение найденных подпапок
           'MsgBox (strFileName)
           ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = strDir & strFileName
           NumDirs = NumDirs + 1
        ElseIf (UCase(Right(strFileName, 3)) = UCase(strExt)) Then
          'Запись пути и имени файла в коллекцию
          colFiles.Add strDir & strFileName
        End If
    End If
    strFileName = Dir()
  Loop
    
  For i = 0 To NumDirs - 1
    FindFile files, Dirs(i), "dwg"
  Next i

End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = strName Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function