Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail


Донат для форума - использовать для поднятия настроения себе и модераторам

А ещё здесь можно купить рекламу за 25 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru

Ответ
 
Опции темы
Старый 22.09.2019, 06:53   #11
oleg4226
Пользователь
 
Регистрация: 20.04.2014
Сообщений: 28
Репутация: 10
По умолчанию

так вот пример - выше же прикладывал
дабы не вводить в заблуждение - сорри - имеется всегда в виду разрыв раздела а не разрыв страницы
Вложения
Тип файла: doc Пример9.doc (135.5 Кб, 10 просмотров)

Последний раз редактировалось oleg4226; 22.09.2019 в 09:17.
oleg4226 вне форума   Ответить с цитированием
Старый 22.09.2019, 09:51   #12
Вождь
Форумчанин
 
Аватар для Вождь
 
Регистрация: 29.09.2008
Сообщений: 374
Репутация: 223

icq: 397882017
По умолчанию

Тогда, будет посложнее
Код:
Option Explicit

Sub Test()
Dim RPages As Range
Dim RBreak As Range
Dim R As Range
    Set RPages = PAGES_GetRange(ActiveDocument, 2, 3) ' ВСТАВИТЬ СВОИ !!!
    Set RBreak = SECTION_GetFirstBreakNewPage(RPages)
    ' нет разрыва
    If RBreak Is Nothing Then
        RANGE_DeleteCutTable Rng:=RPages ' удаляем все
    ' есть разрыв
    Else
        ' удаляем до разрыва
        Set R = RPages.Duplicate
        R.SetRange RPages.Start, RBreak.Start
        RANGE_DeleteCutTable Rng:=R
        ' удаляем после разрыва
        Set R = RPages.Duplicate
        R.SetRange RBreak.End, RPages.End
        RANGE_DeleteCutTable Rng:=R
    End If
    Exit Sub
End Sub

' удаление области Rng с учетом таблиц по краям области
Function RANGE_DeleteCutTable(ByRef Rng As Range) As Boolean
Dim R As Range
    If Not (Rng Is Nothing) Then
        If Rng.Start < Rng.End Then
            ' ищем таблицу с края
            Set R = Rng.Characters.First
            If R.Information(wdWithInTable) Then
                If R.Tables(1).Range.Start < Rng.Start Then GoTo 1
            End If
            Set R = Rng.Characters.Last
            If R.Information(wdWithInTable) Then
                If R.Tables(1).Range.End > Rng.End Then GoTo 1
            End If
            ' обычное удаление
            Rng.Delete
            If Rng.Start < Rng.End Then Rng.Delete
        End If
    End If
    Exit Function
1:  ' удаление части таблицы
    If AscW(Rng.Next.Text) = 12 Then Rng.MoveEndWhile Cset:=vbCr, Count:=-1
    Rng.Select
    Selection.Cut
    RANGE_DeleteCutTable = True
End Function

' возвращает область первого разрыва раздела с новой страницы в области Rng
Function SECTION_GetFirstBreakNewPage(ByRef Rng As Range) As Range
Dim R As Range
    If Not (Rng Is Nothing) Then
        If Rng.Start < Rng.End Then
            Set R = Rng.Duplicate
            R.Collapse wdCollapseStart
            Do
                Set R = R.GoToNext(wdGoToSection)
                If R Is Nothing Then Exit Do
                If R.Start > Rng.Start Then
                    If R.Start > Rng.End Then Exit Do
                    ' раздел с новой страницы
                    Select Case R.Sections.First.PageSetup.SectionStart
                        Case wdSectionNewPage, wdSectionOddPage, wdSectionEvenPage
                            Set SECTION_GetFirstBreakNewPage = R.Previous
                            Exit Function ' нашли
                    End Select
                End If
                R.Collapse wdCollapseEnd
            Loop
        End If
    End If
End Function

' возвращает количество страниц в документе Doc
Function PAGES_Count(ByRef Doc As Document) As Long
Dim N As Long, N2 As Long
    Doc.Repaginate
    DoEvents
    N = Doc.ComputeStatistics(wdStatisticPages)
    DoEvents
    N2 = Doc.Characters.Last.Information(wdActiveEndPageNumber)
    If N2 > N Then PAGES_Count = N2 Else PAGES_Count = N
End Function

' возвращает область документа Doc, от начала страницы StartPageNo до конца страницы EndPageNo
Function PAGES_GetRange(ByRef Doc As Document, ByVal StartPageNo As Long, Optional ByVal EndPageNo As Long) As Range
    ' страниц в документе
Dim N As Long
    N = PAGES_Count(Doc)
    ' проверяем параметры
    If (StartPageNo < 1) Or (StartPageNo > N) Then Exit Function
    If (EndPageNo <= 0) Or (EndPageNo > N) Then
        EndPageNo = N
    ElseIf EndPageNo < StartPageNo Then
        Exit Function
    End If
    ' область страниц
Dim R As Range
    Set R = Doc.Range.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=StartPageNo)
    If EndPageNo >= N Then
        R.End = Doc.Range.StoryLength
    Else
        R.End = Doc.Range.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=EndPageNo + 1).Start
    End If
    ' результат
    Set PAGES_GetRange = R
End Function
__________________
Макросы на заказ и готовый пакет - http://mtdmacro.ru/
Вождь вне форума   Ответить с цитированием
Старый 22.09.2019, 11:12   #13
oleg4226
Пользователь
 
Регистрация: 20.04.2014
Сообщений: 28
Репутация: 10
По умолчанию

вы мастер своего дела - благодарю что учли если есть разрыв раздела в диапазоне - либо нет
готов с вами постоянно сотрудничать - токо куда и как mtdmacro.ru там авторизация нужна
и какие расценки будут или есть напишите мне в лк почту

Последний раз редактировалось oleg4226; 22.09.2019 в 11:26.
oleg4226 вне форума   Ответить с цитированием
Старый 22.09.2019, 11:30   #14
oleg4226
Пользователь
 
Регистрация: 20.04.2014
Сообщений: 28
Репутация: 10
По умолчанию

мой файл с вашим макросом - все четко отрабатывается
Вложения
Тип файла: doc Пример12.doc (130.0 Кб, 9 просмотров)

Последний раз редактировалось oleg4226; 22.09.2019 в 11:39.
oleg4226 вне форума   Ответить с цитированием
Старый 22.09.2019, 13:20   #15
oleg4226
Пользователь
 
Регистрация: 20.04.2014
Сообщений: 28
Репутация: 10
По умолчанию

направил вам на почту сообщение
oleg4226 вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Поиск ext2 разделов roman74 Общие вопросы Delphi 0 09.07.2011 17:52
Список разделов диска на Delphi Rock4se4 Помощь студентам 0 30.01.2010 08:17
Восстановление форматированых разделов... Witalyj_sk Софт 1 29.06.2009 01:21
Создание новых разделов PAVEL315 О форуме и сайтах клуба 14 21.01.2007 00:05


10:39.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.