|
Функция предназначена для вывода информации (статистики) по всем листам документа Word.
В качестве параметра, функция получает ссылку на открытый документ Word.
Результат работы функции представлен на скриншоте.
Код функции WordDocumentProperties:
Function DocumentProperties(ByRef doc As Object) As Variant
On Error Resume Next: Err.Clear
' формирует статистику по документу Word
' возвращает двумерный массив из 3 столбцов,
' а строк в массиве столько, сколько страниц в документе DOC.
' 1 столбец: номер страницы + статистика (количество абзацев, слов и букв)
' 2 столбец - текст, с которого начинается страница
' 3 столбец - текст, которым заканчивается страница
Dim pg As Object, oRng As Object, pos1&, pos2&
pc& = doc.Range.Information(4)
ReDim arr(1 To pc&, 1 To 3)
For n = 1 To pc&
pos1& = doc.Range.GoTo(1, 2, , n).Start ' wdGoToPage = 1, wdGoToNext = 2
If n = pc& Then
pos2& = doc.Range.End
Else
pos2& = doc.Range.GoTo(1, 2, , n + 1).Start
End If
Set oRng = Nothing: Set oRng = doc.Range(pos1&, pos2& - 1)
arr(n, 1) = "Страница: " & n & vbLf & _
" абзацев: " & oRng.Paragraphs.Count& & vbLf & _
" символов: " & (pos2& - pos1& - 1)
txt = "": txt = Replace(oRng.Text, vbNewLine, " ")
txt1$ = Left(txt, 50): sp& = 0: sp& = InStrRev(txt1, " ")
If sp& > 1 Then txt1 = Left(txt1, sp& - 1)
txt2$ = Right(txt, 50): sp& = 0: sp& = InStr(1, txt2, " ")
If sp& > 1 Then txt2 = Mid(txt2, sp& + 1)
arr(n, 2) = Trim(Application.Trim(Application.Clean(txt1)))
arr(n, 3) = Trim(Application.Trim(Application.Clean(txt2))) 'Replace(txt2, Chr(13), vbLf)
Next
DocumentProperties = arr
End Function
Пример вызова функции из другого макроса:
' загружаем данные из файла Word
Set doc = Nothing
Set doc = WA.Documents.Open(filename$, , True)
If doc Is Nothing Then ' если документ не открылся
cell.Resize(, 5).Value = Array(index&, ShortFilename$, subfolder$, DateCreated, FileSize&)
cell.Offset(, 5) = "Не удалось открыть файл DOC"
Else ' документ успешно открыт
arr = "": arr = DocumentProperties(doc)
If IsArray(arr) Then ' если удалось загрузить данные из документа Word
cell.Resize(UBound(arr), 5).Value = Array(index&, ShortFilename$, subfolder$, DateCreated, FileSize&)
cell.Offset(, 5).Resize(UBound(arr), 3).Value = arr ' выводим результаты на лист
Else
cell.Resize(, 5).Value = Array(index&, ShortFilename$, subfolder$, DateCreated, FileSize&)
cell.Offset(, 5) = "Не удалось загрузить данные из файла"
End If
doc.Close False ' закрываем файл DOC
End If
|
