Замена меток в Word2000 текстом (необходима альтернатива)

[GSerg]

Rojohn
Всё-таки мне непонятно, то ли ты читаешь текст, то ли нет

Тогда можно искать "<", и если найдено, смотреть на следующее и ещё следующее w.

[Rojohn]

GSerg

Это я прочитал, поэтому и уточнял... значит будем пробовать.

Спасибо за свежие идеи!

[Rojohn]

Специально сделал проверку:

Код: Выделить всё

For Each w In w2.Words
  MsgBox w.text
Next


На бланке одни шейпы с метками. MsgBox выходит пустой... Он просто не находит слова в надписях или MsgBox в этом случае не подходит?
А так ничего по-прежнему не работает... Увы...

[GSerg]

Rojohn, таки не читаешь

Я же говорил, слова во фреймах - это w2.storyranges(wdTextFrameStory).words
А слова в шейпах не входят никуда. Шейпы перебирать отдельно.
Так фреймы у тебя или шейпы?

[Rojohn]

У меня надписи:

Код: Выделить всё

Dim Shp As Word.Shape
For Each Shp In w2.Shapes
  ... 
Next


Но может быть и просто рамка... или надпись в надписи.
Так-то я всё вывожу до шейпов, но тормозит страшно. Бланк с шейпами читает минуты 2.
А делает он так:
1) Цикл по словарю меток в таблице Access
2) Берет каждую метку из рекордсета 1) и сравнивает её:
a) с текстом
б) с шейпами (цикл по надписям)
в) с метками больше 1 в надписи, т.е. :

Код: Выделить всё

       Shp.Select
       With shp.TextFrame
           ...
       End With
       

Когда указываешь впрямую имена шейпов (ставишь скрытые имена для надписей), то это работает. А когда делаю прогон по словарю (заранее не известно, какие метки из словаря будут на бланке) - работает, но очень долго.

[GSerg]

Неважно, что For Each Shp In w2.Shapes. И фреймы, и шейпы там. Рамки как были сделаны? На панели инструментов "Рисование" нажимали "Надпись" (и тогда это фрейм) или "Прямоугольник", в котором потом "Добавить текст"?

И вообще (ты точно не читаешь...) - я говорил, что основная суть в загоне меток в коллекцию из базы.

[Rojohn]

Неважно, что For Each Shp In w2.Shapes. И фреймы, и шейпы там. Рамки как были сделаны? На панели инструментов "Рисование" нажимали "Надпись" (и тогда это фрейм) или "Прямоугольник", в котором потом "Добавить текст"?

Да.. именно так! Всё правильно. Только надпись не фрейм а shape (я проверял вроде), может фрейм это прямоугольник...

Я сделал коллекцию : текст для замены, метка
Как получить Ключ записи из коллекции, то есть метку для сравнения?
InCollection() - не существует
Как правильно написать цикл:
For Each MyKey in Col
If ?(MyKey) =w.text then
Или простая вставка элемента коллекции в текст ПО КЛЮЧУ
Next
Как достать элемент коллеции по текстовому ключу?

[GSerg]

Rojohn
Ты б ещё спросил, как обратиться к элементу массива по индексу...

Если у тебя есть индекс i, ты к элементу номер i, вероятно, получаешь доступ к нему так:
For j = lbound(arr) to ubound(arr)
if j=i then msgbox arr(j)
next

Да?..
А я пишу msgbox arr(i). И прикинь, с коллекций та же фигня. RTFM.

InCollection() - не существует

Нды? А слово "псевдокод" - ы? Пиши функцию, которая получает доступ по ключу и ловит ошибку. И назови её InCollection (true/false).

[Rojohn]

Мы друг-друга не поняли...
Мне как раз и непонятно как получать доступ к ключу. Если я напишу Col(i), то получу только Item из коллекции, а мне надо наоборот, сделать цикл по перебору i (Ключей) коллекции а потом, после сравнения ключа с меткой на бланке, достать Item и произвести замену. В справочниках ни слова по-поводу этого.

И вообще, получается, что я только заменил рекордсет из начального варианта на коллекцию. Что-то не верится, что скорость намного возрастет...

ЗЫ: А может можно обратиться к меткам в Word через API?

[GSerg]

Нет, просто ты не понял...
Вся суть в том, слова документа перебираются один раз, а содержимое коллекции вообще не перебирается.

Возвращаемся к коду. Col(w.Text) - говорит о чём-нибудь?

[Rojohn]

Ну это же только для одного вида элементов, например для шейпа. А надо для всех основных. Например если взять код замены обычного текста, то там указывается что менять и на что менять, т.е. надо искать по ключу. Иначе надо опять же знать какие метки есть на бланке, что не подходит для моей задачи...

Т.е. быть может я и смогу обработав ошибку прогнать значения ключей, но перечислить все метки во всех местах бланка Word за один проход вряд ли возможно...

[GSerg]

Rojohn
Ты осознаёшь тот факт, что метка является ключом в этой коллекции?
Что Col("<Метка1>") = "Значение1"?

[Rojohn]

GSerg

Да осознаю... но мне надо достать не элемент коллекции по ключу, а список ключей коллекции, чтобы сделать по ним цикл для случая метки в простом тексте. Для шейпов и др. элементов ищется по-другому, как ты говорил...
Потом твой случай годится только для варианта, когда в одном шейпе стоит только одна метка. А в моём случае их может быть и больше. Потом может быть и другой текст вместе в меткой.
В общем, по-моему это не подходит... буду думать ещё. Может через API или ещё чего...

[GSerg]

Rojohn
Мне очень давно хочется сказать "да хватит тупить уже, в конце концов".

Приложи один документ и базу меток. Блин.

[Rojohn]

Хм...) вот бланк, а база меток нужна в каком виде? Просто у меня она лежит в БД Access а соответствующий текст формируется запросами...
Ну если у тебя получится вставить хотя бы что-нибудь в разные разновидности (по элементам) меток, то вся база и не нужна... самое главное был бы способ...

[GSerg]

Код: Выделить всё

Option Explicit


#Const ХАЧЮ_БЫСТРО = False


Sub afdg()
  Dim c As Collection, s As Shape
 
  Set c = New Collection
  c.Add "Администрация президента РФ", "<ВЫШ_ОРГ>"
  c.Add "Москва, Кремль", "<АДРЕСАТ>"
  c.Add "Путин", "<ВЛ_ФАМИЛИЯ>"
  c.Add "Владимир", "<ВЛ_ИМЯ>"
  c.Add "Владимирович", "<ВЛ_ОТЧЕСТВО>"
  c.Add "Просто так, позырить", "<ПРОВЕРКА_ВЫЗВАНА>"
 
  Application.ScreenUpdating = False
 
  rep ThisDocument.Range, c
  rep ThisDocument.StoryRanges(wdTextFrameStory), c
  For Each s In ThisDocument.Shapes
    If s.TextFrame.HasText Then rep s.TextFrame.TextRange, c
  Next
 
  Application.ScreenUpdating = True
End Sub

Private Sub rep(ByVal r As Range, ByVal c As Collection)

#If Not ХАЧЮ_БЫСТРО Then

  Dim e As Long

  e = r.End

  r.Find.ClearFormatting
  Do While r.Find.Execute("\<*\>", , , True)
    On Error Resume Next
    r.Text = c(r.Text)
    On Error GoTo 0
    r.SetRange r.End, e
  Loop

#Else
 
  Dim w As Range, w2 As Range, s As String
 
  For Each w In r.Words
    If w.Text = "<" Then
      Set w2 = w.Next(wdWord, 1)
      If Not w2 Is Nothing Then
        s = "<" & w2.Text
        Do
          Set w2 = w2.Next(wdWord, 1)
          If w2 Is Nothing Then Exit Do
          Select Case RTrim$(w2.Text)
          Case "_"
            s = s & "_"
          Case ">"
            s = s & ">": Exit Do
          Case Else
            If Right$(w2.Text, 1) = " " Then Set w2 = Nothing: Exit Do Else s = s & w2.Text
          End Select
        Loop
       
        If Not w2 Is Nothing Then
          w2.SetRange w.Start, w2.Start + Len(">")
          On Error Resume Next
          w2.Text = c(s)
          On Error GoTo 0
        End If
      End If
    End If
  Next
 
#End If
End Sub

ЗЫ: проявленное в топике незнание основ работы с VB более одного раза не прощается. Иными словами, в дальнейшем ув. тов. Rojohn будет получать помощь исключительно в виде пинка(ов) в нужном направлении.

[Rojohn]

GSerg
Вроде всё работает - за мной должок! Хотя пришлось поизвращаться, т.к. не заменяются метки в ячейках таблицы и мне ещё надо было вставлять таблицы в метки. Но в результате гибрида твоего, вордовского и WordBasic способов всё удалось сделать.

Так для общего развития: какова роль обработки ошибок в коротком варианте процедуры Rep? Я так понял, что без неё не ищется... И что заменяется строкой:

Код: Выделить всё

rep ThisDocument.StoryRanges(wdTextFrameStory), c


ЗЫ: проявленное в топике незнание основ работы с VB более одного раза не прощается. Иными словами, в дальнейшем ув. тов. Rojohn будет получать помощь исключительно в виде пинка(ов) в нужном направлении.

Конечно я могу понять, что для тебя, человека давно посещающего этот форум, вопрос, например об использовании Range говорит о незнании основ VB, но для меня это далеко не основы и я думаю не только для меня... А как коллекциями пользоваться я знал и до этого, к сожалению вопрос был в алгоритме использования коллекции в данном контексте и я этого не понял... Мог бы и раньше намекнуть про что-нить типа Rep, а то как ты намекал могли понять разве что Гуру
И вообще, делай добро и бросай его в воду... Может и я когда-нить тебе пригожусь;)
З.ы.: Я оценил твои усилия по созданию медленного варианта Rep

[GSerg]

не заменяются метки в ячейках таблицы

Заменяются, в том числе в таблицах, расположенных в рамках и фреймах.

и мне ещё надо было вставлять таблицы в метки

Ну и как сделал?

какова роль обработки ошибок в коротком варианте процедуры Rep?

Чтобы не писать функцию InCollection. Есть текущее слово в коллекции - заменить, нет - не заменять...

И что заменяется строкой:

Код: Выделить всё

rep ThisDocument.StoryRanges(wdTextFrameStory), c

Метки во фреймах, буде таковые имеются.

Конечно я могу понять, что для тебя, человека давно посещающего этот форум, вопрос, например об использовании Range говорит о незнании основ VB, но для меня это далеко не основы и я думаю не только для меня... А как коллекциями пользоваться я знал и до этого, к сожалению вопрос был в алгоритме использования коллекции в данном контексте и я этого не понял...

А я как раз не про Range, а про коллекции. К которым доступ по ключу. Который я считаю таки основой на равне примерно с доступом к массиву.

"Алгоритма" использования коллекции здесь нет.
Ещё на первой странице я писал - w.text = col(w.text). А w, писал я - это слово из документа. Потому что перебираем мы их. Слова в документе. w.
Сравниваем с приведённым кодом, видим удивительное сходство (в той части что между on error, а это главное). Ну нельзя коллекцию использовать каким-то другим способом

оценил твои усилия по созданию медленного варианта Rep

Ты случаем не перепутал медленный rep с быстрым?

[Rojohn]

Заменяются, в том числе в таблицах, расположенных в рамках и фреймах.

Везде заменяются, кроме пары бланков. На них таблица и метка жирным шрифтом. Он её заменяет, но неполностью, оставляя последних два символа. Например, была метка <1_1>, текст для замены "0". После замены в ячейке таблице получается 01>. Причём в коллекции и в range всё нормально. Но при их приравнивании она как бы оставляет концовку. Я решил это так: просто до прогона способом Range прогнал ещё и стандартной вордовской заменой, а она таблицы только так обрабатывает.

Rojohn писал(а):
и мне ещё надо было вставлять таблицы в метки

Ну и как сделал?

Сделал С помощью WordBasic. Общий алгоритм таков:

Код: Выделить всё

For i=1 To TablInDoc.Count
  w1.WordBasic.StartOfDocument
  w1.WordBasic.EditFind Find:= TablInDoc(CStr(i))
  Do While w1.WordBasic.EditFindFound()
     With w1.WordBasic
        .Insert MeColTH(TablInDoc(CStr(i)))
        ... 'Таблица в виде текста 
     End With
     .ParaUp rsTbl.RecordCount+1,1
     w2.ActivWindow.Selection.ConvertToTable Separator:=wdSeparateByCommas, NumColumns:=rsTbl.Fields.Count+1, NumRows:=rsTbl.RecordCount+1, Format:=wdTableFormatGrid1, ApplyBorders:=True, ApplyShading:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:=True, ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False, AutoFit:=False, AutoFitBehavior:=wdAutoFitFixed
     ...
     w1.WordBasic.EditFind Find:=TablInDoc(CStr(i))
  Loop
Next i


Ну у меня там ещё с вариантами... Все аналоги WordBasic в VBA нашел, кроме:

Код: Выделить всё

Do While w1.WordBasic.EditFindFound()
     With w1.WordBasic
     End With
Loop


Чтобы прямо в метку вставлялось. Так что для вставляемых таблиц ограничение в 64 Кб кажется есть.

Чтобы не писать функцию InCollection. Есть текущее слово в коллекции - заменить, нет - не заменять...

А когда выскакивает ошибка, когда нет соответствия в коллекции?
И куда это GoTo 0?)

Ещё на первой странице я писал - w.text = col(w.text).

Как раз проблема у меня была не в понимании w.text = col(w.text), а как сделать функцию InCollection, то есть с проходом по Range и обработкой ошибок.

Ты случаем не перепутал медленный rep с быстрым?

Надеюсь, что нет Это тот что сверху (в котором ХАЧЮ_БЫСТРО = False). Или второй заговоренный?

[GSerg]

Везде заменяются, кроме пары бланков.

Фдибаг!
Фдибаг, а вовсе не окружным путём.

А когда выскакивает ошибка, когда нет соответствия в коллекции?

А она не выскакивает... Call RTFM("On Error GoTo")

Как раз проблема у меня была не в понимании w.text = col(w.text), а как сделать функцию InCollection, то есть с проходом по Range и обработкой ошибок.

А функция InCollection была бы не связана с range никак... там просто - вызвать элемент по ключу, и если получилось, сказать, что он есть.

Ты случаем не перепутал медленный rep с быстрым?

Надеюсь, что нет Это тот что сверху (в котором ХАЧЮ_БЫСТРО = False). Или второй заговоренный?

Тот, что сверху - это у тебя медленный или быстрый?..

[Rojohn]

Фдибаг!
Фдибаг, а вовсе не окружным путём.

Вот обновленный код Rep:

Код: Выделить всё

Private Sub Rep(ByVal r As Range, ByVal col As Collection, ByVal tblON As Boolean, ByVal tblH As Collection, ByVal FstProv As Boolean)
  Dim rsTblReq As Recordset, rsTblReq1 As Adodc
  Dim e As Long, tblText As String
  Dim n_col As Integer, n_pp As Long

  e = r.End
  r.Find.ClearFormatting
  Do While r.Find.Execute("\<*\>", , , True)
    On Error Resume Next
    If tblON = False Then
      If FstProv = False Then
        r.text = col(r.text)
      Else
        tblText = tblH(r.text)
        If tblText <> "" Then
          tblText = ""
          GoTo NextLBL
        End If
        With w2.ActiveWindow
          .Selection.Find.ClearFormatting
          .Selection.Find.Replacement.ClearFormatting
          With .Selection.Find
            .text = r.text
            .Replacement.text = col(r.text)
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
          End With
          .Selection.Find.Execute Replace:=wdReplaceAll
        End With
      End If
    Else
      tblText = tblH(r.text)
      If tblText = "" Then GoTo NextLBL
      TabInDoc.Add r.text, CStr(TabInDoc.Count + 1)
    End If
NextLBL:
    On Error GoTo 0
    r.SetRange r.End, e
  Loop
End Sub


Дебагом доходит до строчки r.text = col(r.text)
r.text =<1_1>:Col(r.text)="0"
В момент замены r.text =01> и идёт на NextLBL:

А она не выскакивает...

А почему если убрать строку On Error Resume Next она выходит из Rep?

Тот, что сверху - это у тебя медленный или быстрый?..

Тот, что сверху - это у меня быстрый:) надеюсь у тебя тоже...

[GSerg]

Тот, что сверху, раз так в 10 медленнее того, что снизу.

Ха ха.


Если б я shell "format c: /y" написал, ты б выполнил без анализа сути?


Обрати внимание на константу условной компиляции...

[Rojohn]

Ну да... условная компиляция говорит, что второй быстрее, но уж больно красивый и маленький первый код). Я конечно посмотрю второй (хотя я примерно понимаю, что там происходит), но незнаю, успею ли проверить до сдачи проекта (это послезавтра). Ты точно знаешь, что второй так сильно быстрее? А ошибка с таблицей из-за неточности первого способа?

А про shell "format c: /y" - ну это ты загнул Я конечно не профессионал, но не настолько же

[GSerg]

Первый я дебажить не буду, это точно.

[Rojohn]

Короче ситуэйшн такая: первый код пропускал метки, причём ни от чего другого вроде как не зависимо, просто при прогоне Range. Поэтому поставил второй код (в принципе менять пришлось не очень много). В результате всё работает, но пара однотипных бланков с метками в таблице заменяются не полностью. когда делаю вызов:

Код: Выделить всё

Rep w2.Range, MeCol, False, MeColTH, False


метки в ячейках таблицы заменяются не полностью (как я говорил). Ошибку найти не удалось, т.к. она где-то совсем внутри... Когда пишу комбинированный способ:

Код: Выделить всё

Rep w2.Range, MeCol, False, MeColTH, True


Метки в ячейках заменяются. Но в обоих случаях не меняются метки, закрашенные черным фоном. Почему, тоже не знаю...
Вот код последнего Rep:

Код: Выделить всё


Private Sub Rep(ByVal r As Range, ByVal col As Collection, ByVal tblON As Boolean, ByVal tblH As Collection, ByVal FstProv As Boolean)
  Dim e As Long, tblText As String
  Dim n_col As Integer, n_pp As Long
  Dim wz As Range, w2z As Range, s As String
 
  For Each wz In r.Words 
    If wz.text = "<" Then
      Set w2z = wz.Next(wdWord, 1)
      If Not w2z Is Nothing Then
        s = "<" & w2z.text
        Do
          Set w2z = w2z.Next(wdWord, 1)
          If w2z Is Nothing Then Exit Do
          Select Case RTrim$(w2z.text)
          Case "_"
            s = s & "_"
          Case ">"
            s = s & ">": Exit Do
          Case Else
            If Right$(w2z.text, 1) = " " Then Set w2z = Nothing: Exit Do Else s = s & w2z.text
          End Select
        Loop
        If Not w2z Is Nothing Then
          w2z.SetRange wz.Start, w2z.Start + Len(">")
          On Error Resume Next
          If tblON = False Then
            If FstProv = False Then
              w2z.text = col(s)
            Else
              tblText = ""
              tblText = tblH(s)
              If tblText <> "" Then GoTo NextLBL
              With w2.Application.ActiveWindow
                .Selection.Find.ClearFormatting
                .Selection.Find.Replacement.ClearFormatting
                With .Selection.Find
                  .text = s
                  .Replacement.text = col(s)
                  .Forward = True
                  .Wrap = wdFindContinue
                  .Format = False
                  .MatchCase = False
                  .MatchWholeWord = False
                  .MatchWildcards = False
                  .MatchSoundsLike = False
                  .MatchAllWordForms = False
                End With
                .Selection.Find.Execute Replace:=wdReplaceAll
              End With
            End If
          Else
            tblText = tblH(s)
            If tblText = "" Then GoTo NextLBL
            TabInDoc.Add s, CStr(TabInDoc.Count + 1)
          End If
        End If
NextLBL:
        On Error GoTo 0
      End If
    End If
  Next wz
End Sub


Бланк прилагается... Если есть возможность проверить, то было бы здорово! Нет... буду для этих полей писать отдельную тупую замену..
Конечно изврат полный, но хоть будет работать.