mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Загрузка информации из файлов Word (перебор страниц в документе)

Результат обработки файла Word - вывод данных по каждой странице

Функция предназначена для вывода информации (статистики) по всем листам документа 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

Комментарии

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
 __  __      _          ___         ____  
\ \/ / | | ___ |_ _| ____ | __ )
\ / _ | | / __| | | |_ / | _ \
/ \ | |_| | | (__ | | / / | |_) |
/_/\_\ \___/ \___| |___| /___| |____/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.