1

Тема: Количество страниц в каждом документе внутри каталога

Добрый день!
Имеется каталог  с множеством документов в подкаталогах.
Хочу получить список doc(x) файлов с числом страниц в каждом файле, т.е.

Файл1.doc - 44
Файл2.doc - 51
Файл3.doc - 12

Пытался воспользоваться найденной процедурой:

Private Sub CommandButton1_Click()
 Dim mySFO As FileSearch
 Dim foundFile
 Dim s As String
 Set mySFO = Application.FileSearch
 Dim filename  As String
 Dim n As Integer
 With mySFO
  .NewSearch
  .LookIn = "D:\мой каталог\"
  .SearchSubFolders = True
  .filename = "*.doc"
  .FileType = msoFileTypeWordDocuments
  If .Execute() > 0 Then
   For q = 1 To .FoundFiles.Count
    Documents.Open filename:=.FoundFiles(q)
    n = ActiveDocument.ComputeStatistics(wdStatisticPages)
    s = s & ActiveDocument.Name & "=" & n & Chr(13) & Chr(10)
    ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
   Next q
  End If
 End With
 MsgBox (s)
End Sub

Но при попытке выполнить вылетает с руганью, что команда  Set mySFO = Application.FileSearch не поддерживается в данной ОС

Стоит Office 2013 и Win 7 x64
Пробовал так же на 2003м офисе с той же ОС, результат такой-же.

Пождскажите пожалуйста, в чем ошибка?

2

Re: Количество страниц в каждом документе внутри каталога

Пишут, что в Office 2007 и старше  команда FileSearch не работает:
внешняя ссылка
Попробуйте использовать программы, которые размещены по указанному адресу.

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

3

Re: Количество страниц в каждом документе внутри каталога

Zmax пишет:

Пождскажите пожалуйста, в чем ошибка?

Ошибка в том, что метод FileSearch для объекта Application не поддерживается в версиях офиса 2010 (по некоторым данным, 2007) и более новых. Вместо FileSearch предлагают использовать альтернативные решения для поиска файла в папке (напр., циклы перебора файлов в папке по Dir с анализом имени очередного файла по маске). Например, внешняя ссылка

4

Re: Количество страниц в каждом документе внутри каталога

Огромное спасибо за ответы! smile
Проблема решена путём возвращения функционала FileSearch в 2013й офис:

Для начала создаём классовый модуль, который так и назовём "FileSearch"
Копируем в него код:
(коментарии автора сохранены)

'Version 1.2
'Andreas Killer
'12.10.09
'Attribute VB_Name = "FileSearch"

'Nachbildung des FileSearch-Objektes für Office 2007
'Property-Tests sind nicht implementiert!

Option Explicit

Public Enum msoSortBy
  msoSortByFileName = 1
  msoSortBySize = 2
  msoSortByFileType = 3
  msoSortByLastModified = 4
End Enum

Public Enum msoFileType
  msoFileTypeAllFiles = 1
  msoFileTypeOfficeFiles = 2
  msoFileTypeWordDocuments = 3
  msoFileTypeExcelWorkbooks = 4
  msoFileTypePowerPointPresentations = 5
  msoFileTypeBinders = 6
  msoFileTypeDatabases = 7
  msoFileTypeTemplates = 8
End Enum

Public Enum msoLastModified
  msoLastModifiedYesterday = 1
  msoLastModifiedToday = 2
  msoLastModifiedLastWeek = 3
  msoLastModifiedThisWeek = 4
  msoLastModifiedLastMonth = 5
  msoLastModifiedThisMonth = 6
  msoLastModifiedAnyTime = 7
End Enum

Private fsFileName As Variant
Public LookIn As String
Public SearchSubFolders As Boolean
Public FoundFiles As Collection
Private fsFileType As msoFileType
Private fsLastModified As msoLastModified

Private SortFiles As Collection
Private SortFilesBy As msoSortBy
Private fs As Object 'FileSystemObject

Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

Private Const FIND_FIRST_EX_CASE_SENSITIVE As Long = 1
Private Const FIND_FIRST_EX_LARGE_FETCH As Long = 2

Private Enum FINDEX_SEARCH_OPS
  FindExSearchNameMatch
  FindExSearchLimitToDirectories
  FindExSearchLimitToDevices
End Enum

Private Enum FINDEX_INFO_LEVELS
  FindExInfoStandard
  FindExInfoMaxInfoLevel
End Enum

Private Declare Function FindFirstFile Lib "kernel32" Alias _
  "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
  As WIN32_FIND_DATA) As Long
Private Declare Function FindFirstFileEx Lib "kernel32" Alias _
  "FindFirstFileExA" (ByVal lpFileName As String, ByVal _
  fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _
  ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal _
  dwAdditionalFlags As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias _
  "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As _
  WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal _
  hFindFile As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal _
  psString As Any) As Long

Private Type SYSTEMTIME
  wYear As Integer
  wMonth As Integer
  wDayOfWeek As Integer
  wDay As Integer
  wHour As Integer
  wMinute As Integer
  wSecond As Integer
  wMilliseconds As Integer
End Type

Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
  lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
  "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount _
  As Long)

Private Sub Class_Initialize()
  Set FoundFiles = New Collection
  Set SortFiles = New Collection
  Set fs = CreateObject("Scripting.FileSystemObject")
  FileType = msoFileTypeOfficeFiles
  LastModified = msoLastModifiedAnyTime
End Sub

Private Sub Class_Terminate()
  Set FoundFiles = Nothing
  Set SortFiles = Nothing
  Set fs = Nothing
End Sub

Public Sub NewSearch()
  Filename = ""
  LookIn = ""
  FileType = msoFileTypeOfficeFiles
  LastModified = msoLastModifiedAnyTime
  SearchSubFolders = False
  ClearCollections
End Sub

Private Sub ClearCollections()
  Dim I As Long
  With SortFiles
    For I = .Count To 1 Step -1
      .Remove I
    Next
  End With
  With FoundFiles
    For I = .Count To 1 Step -1
      .Remove I
    Next
  End With
End Sub

Property Let Filename(Value As Variant)
  If IsArray(Value) Then
    fsFileName = Value
  Else
    fsFileName = Array(Value)
  End If
  fsFileType = 0
End Property

Property Get Filename() As Variant
  Filename = Join(fsFileName, ", ")
End Property

Property Let FileType(Value As msoFileType)
  fsFileType = Value
  Select Case Value
    Case msoFileTypeAllFiles
      fsFileName = Array("*.*")
    Case msoFileTypeOfficeFiles
      fsFileName = Array("*.doc", "*.dot", "*.htm", "*.html", _
        "*.mdb", "*.mpd", "*.obd", "*.obt", "*.pot", "*.pps", "*.ppt", _
        "*.xls", "*.xlt")
    Case msoFileTypeWordDocuments
      fsFileName = Array("*.doc", "*.htm", "*.html")
    Case msoFileTypeExcelWorkbooks
      fsFileName = Array("*.xls")
    Case msoFileTypePowerPointPresentations
      fsFileName = Array("*.pps", "*.ppt")
    Case msoFileTypeBinders
      fsFileName = Array("*.obd")
    Case msoFileTypeDatabases
      fsFileName = Array("*.mdb", "*.mpd")
    Case msoFileTypeTemplates
      fsFileName = Array("*.dot", "*.obt", "*.pot", "*.xlt")
    Case Else
      fsFileType = 0
      fsFileName = Array("*.*")
  End Select
End Property

Property Get FileType() As msoFileType
  FileType = fsFileType
End Property

Property Let LastModified(Value As msoLastModified)
  If Value >= 1 And Value <= 7 Then
    fsLastModified = Value
  Else
    fsLastModified = msoLastModifiedAnyTime
  End If
End Property

Property Get LastModified() As msoLastModified
  LastModified = fsLastModified
End Property

Private Function MakeDecimal(ByVal Lo As Long, ByVal Hi As _
  Long, Optional ByVal wEx As Long = 0, Optional Minus As _
  Boolean = False) As Variant
  If Minus Then MakeDecimal = CDec(-1) Else MakeDecimal = CDec(1)
  CopyMemory ByVal VarPtr(MakeDecimal) + 8, Lo, 4
  CopyMemory ByVal VarPtr(MakeDecimal) + 12, Hi, 4
  If wEx <> 0 Then CopyMemory ByVal VarPtr(MakeDecimal) + 4, _
    Lo, 4
End Function

Private Function FirstWeek(ByVal Datum As Date) As Date
  'Liefert den 1. Tag der Woche in dem Datum liegt
  FirstWeek = Datum - Weekday(Datum, vbUseSystemDayOfWeek) + 1
End Function

Private Sub SearchPrim(ByVal Path As String)
  Dim hFindFile As Long, hFoundFile As WIN32_FIND_DATA
  Dim FName As String, STime As SYSTEMTIME, FTime As Date, _
    ETime As Date, LTime As Date
  Dim I As Integer, AddIt As Boolean
   If fsLastModified <> msoLastModifiedAnyTime Then
    Select Case fsLastModified
      Case msoLastModifiedYesterday
        ETime = Date - 1
        LTime = Date - 1
      Case msoLastModifiedToday
        ETime = Date
        LTime = Date
      Case msoLastModifiedLastWeek
        ETime = FirstWeek(Date) - 7
        LTime = ETime + 6
      Case msoLastModifiedThisWeek
        ETime = FirstWeek(Date)
        LTime = ETime + 6
      Case msoLastModifiedLastMonth
        ETime = DateSerial(Year(Date), Month(Date) - 1, 1)
        LTime = DateSerial(Year(Date), Month(Date), 0)
      Case msoLastModifiedThisMonth
        ETime = DateSerial(Year(Date), Month(Date), 1)
        LTime = DateSerial(Year(Date), Month(Date) + 1, 0)
    End Select
  End If
   'Sicherstelen das ein Backslash dran ist
  If Right(Path, 1) <> "\" Then Path = Path & "\"
  'Suche nach den Dateien
  For I = LBound(fsFileName) To UBound(fsFileName)
    'hFindFile = FindFirstFile(Path & fsFileName(I) & Chr(0), _
      hFoundFile)
    hFindFile = FindFirstFileEx(Path & fsFileName(I) & Chr(0), _
      FindExInfoStandard&, hFoundFile, FindExSearchNameMatch&, 0&, 0&)
    If hFindFile <> INVALID_HANDLE_VALUE Then
      Do
        With hFoundFile
          'Die Verzeichnisse ausschließen
          If Not (.dwFileAttributes And vbDirectory) = _
            vbDirectory Then
            If fsLastModified = msoLastModifiedAnyTime Then
              AddIt = True
            Else
              'Konvertiere Dateizeit zu Systemzeit
              FileTimeToSystemTime .ftLastWriteTime, STime
              'Generiere VBA-Datum
              With STime
                FTime = DateSerial(.wYear, .wMonth, .wDay)
              End With
              AddIt = FTime >= ETime And FTime <= LTime
            End If
             If AddIt Then
              FName = Mid$(.cFileName, 1, lstrlenA(.cFileName))
              'Problem *.htm findet auch *.html
              AddIt = FName Like fsFileName(I)
            End If
             If AddIt Then
              FoundFiles.Add Path & FName
               'Sollen wir sortieren?
              Select Case SortFilesBy
                Case msoSortByFileName
                  'Pfad, dann Name
                  SortFiles.Add FName & Path
                Case msoSortByFileType
                  'Extension, dann Pfad, dann Name
                  SortFiles.Add fs.GetExtensionName(FName) & _
                    Path & FName
                Case msoSortByLastModified
                  'Konvertiere Dateizeit zu Systemzeit
                  FileTimeToSystemTime .ftLastWriteTime, STime
                  'Generiere VBA-Datum
                  With STime
                    FTime = DateSerial(.wYear, .wMonth, .wDay) _
                      + TimeSerial(.wHour, .wMinute, .wSecond)
                  End With
                  SortFiles.Add FTime
                Case msoSortBySize
                  SortFiles.Add MakeDecimal(.nFileSizeLow, _
                    .nFileSizeHigh)
              End Select
            End If
          End If
        End With
      Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
      FindClose hFindFile
    End If
  Next
   If SearchSubFolders Then
    'Suche nach einem Verzeichnis
    'hFindFile = FindFirstFile(Path & "*." & Chr(0), hFoundFile)
    'hFindFile = FindFirstFileEx(Path & "*." & Chr(0), _
      FindExInfoStandard&, hFoundFile, _
      FindExSearchLimitToDirectories&, 0&, FIND_FIRST_EX_LARGE_FETCH)
    hFindFile = FindFirstFileEx(Path & "*." & Chr(0), _
      FindExInfoStandard&, hFoundFile, _
      FindExSearchLimitToDirectories&, 0&, 0&)
    If hFindFile <> INVALID_HANDLE_VALUE Then
      Do
        With hFoundFile
          'Die Verzeichnisse "." und ".." ausschließen
          If Left$(.cFileName, 1) <> "." And ( _
            .dwFileAttributes And vbDirectory) = vbDirectory Then
            FName = Mid$(.cFileName, 1, lstrlenA(.cFileName))
            'Starte rekursive Suche
            SearchPrim Path & FName
          End If
        End With
      Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
      FindClose hFindFile
    End If
  End If
End Sub

Private Sub QuickSortCollection(ByRef Liste As Collection, _
  ByRef Data As Collection, Optional Start, Optional Ende, _
  Optional Compare As vbCompareMethod = vbDatabaseCompare, _
  Optional SortOrder As MsoSortOrder = msoSortOrderAscending)
  'Sortiert eine Collection mit beliebigen Werten im Bereich _
    Start..Ende, führt die Data-Collection parallel mit
  'vbDatabaseCompare sortiert Zahlen, ansonsten werden Texte _
    sortiert
  Dim I As Long, J As Long, C As Integer, Pivot As Variant
   If Liste.Count <= 1 Then Exit Sub
  If IsMissing(Start) Then Start = 1
  If IsMissing(Ende) Then Ende = Liste.Count
  If SortOrder = msoSortOrderAscending Then C = 1 Else C = -1
   I = Start: J = Ende
  Pivot = Liste((Start + Ende) \ 2)
  Do
    If Compare = vbDatabaseCompare Then
      'Zahlen sortieren
      If SortOrder = msoSortOrderAscending Then
        While (Liste(I) < Pivot): I = I + 1: Wend
        While (Liste(J) > Pivot): J = J - 1: Wend
      Else
        While (Liste(I) > Pivot): I = I + 1: Wend
        While (Liste(J) < Pivot): J = J - 1: Wend
      End If
    Else
      'Texte sortieren
      Do While (StrComp(Liste(I), Pivot, Compare) = -C): I = I _
        + 1: Loop
      Do While (StrComp(Liste(J), Pivot, Compare) = C): J = J - _
         1: Loop
    End If
    If (I <= J) Then
      If I < J Then
        Liste.Add Liste(I), After:=J
        Liste.Add Liste(J), After:=I
        Liste.Remove I
        Liste.Remove J
        Data.Add Data(I), After:=J
        Data.Add Data(J), After:=I
        Data.Remove I
        Data.Remove J
      End If
      I = I + 1: J = J - 1
    End If
  Loop Until (I > J)
  If (Start < J) Then QuickSortCollection Liste, Data, Start, _
    J, Compare, SortOrder
  If (I < Ende) Then QuickSortCollection Liste, Data, I, Ende, _
    Compare, SortOrder
End Sub

Public Function Execute(Optional SortBy As msoSortBy = 0, _
  Optional SortOrder As MsoSortOrder = msoSortOrderAscending, _
  Optional AlwaysAccurate As Boolean = True) As Long
  Dim I As Long
  'Beginnt die Suche nach den angegebenen Dateien.
  'SortBy:
  '  Die für die Sortierung der zurückgegebenen Dateien _
    verwendete Methode. Dies kann eine der folgenden MsoSortBy- _
    Konstanten sein: msoSortbyFileName, msoSortbyFileType, _
    msoSortbyLastModified oder msoSortbySize. Ist SortBy = 0 wird _
    nicht sortiert
  'SortOrder:
  '  Die Reihenfolge, in der die zurückgegebenen Dateien _
    sortiert werden sollen. Dies kann eine der folgenden _
    MsoSortOrder-Konstanten sein: msoSortOrderAscending oder _
    msoSortOrderDescending.
  'AlwaysAccurate:
  '  Ohne Funktion, nur aus Kompatiblitätsgründen
   ClearCollections
  SortFilesBy = SortBy
  SearchPrim LookIn
  Execute = FoundFiles.Count
  Select Case SortBy
    Case msoSortByFileName, msoSortByFileType
      QuickSortCollection SortFiles, FoundFiles, Compare:= _
        vbTextCompare, SortOrder:=SortOrder
    Case msoSortByLastModified, msoSortBySize
      QuickSortCollection SortFiles, FoundFiles, Compare:= _
        vbDatabaseCompare, SortOrder:=SortOrder
  End Select
End Function

Затем в своём модуле объявляем глобальную переменную

Public ApplicationFileSearch As New FileSearch

И выполняем поиск как обычно:

Private Sub CommandButton1_Click()
 Dim foundFile
 Dim s As String
 Dim filename  As String
 Dim n As Integer
 With ApplicationFileSearch
  .NewSearch
  .LookIn = "С:\" ' Путь к каталогу
  .SearchSubFolders = True ' Поиск в подкаталогах
  .filename = "*.doc" ' Тип искомых файлов
  .FileType = msoFileTypeWordDocuments
  If .Execute() > 0 Then
   For q = 1 To .FoundFiles.Count
    Documents.Open filename:=.FoundFiles(q)
    n = ActiveDocument.ComputeStatistics(wdStatisticPages)
    s = s & ActiveDocument.Name & "=" & n & Chr(13) & Chr(10)
    ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
   Next q
  End If
 End With
 MsgBox (s)
End Sub