Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.67/6: Рейтинг темы: голосов - 6, средняя оценка - 4.67
Bolbine84455
5 / 5 / 3
Регистрация: 12.03.2014
Сообщений: 339
1

Word. Заменить текст на ссылку

02.07.2017, 19:26. Просмотров 1069. Ответов 6
Метки нет (Все метки)

Имеется следующий код:

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
Dim link As String
Dim tip As String
 
'RegExp Init
Dim selText As String
Dim RA As Range
Dim regExp As Object
Set regExp = CreateObject("vbscript.regexp")
'/RegExp Init
 
'Ïåðåõîä íà ïåðâóþ ñòðîêó
Selection.GoTo What:=wdGoToHeading, Which:=wdGoToFirst
Selection.GoTo What:=wdGoToHeading, Which:=wdGoToAbsolute, Count:=1
 
'Êîëè÷åñòâî ñòðîê (íå ïàðàãðàôîâ)
Dim lines As Integer
lines = ActiveDocument.BuiltInDocumentProperties(wdPropertyLines)
 
'Ïåðåõîä íà ñëåäóþùóþ ñòðîêó è âûäåëåíèå å¸ ñîäåðæèìîãî (òåêñòà)
Dim i As Integer
For i = 1 To lines
    If (i > 1) Then
        Selection.MoveEnd Unit:=wdLine, Count:=1 'Âûäåëÿåì ñëåäóþùóþ ñòðîêó
    End If
    
    If (Selection.Type = wdSelectionNormal) Then 'Òîëüêî òåêñò
        If (Len(Selection.Text) > 2) Then 'Äëèíà ñòðîêè áîëüøå 2
            If (Asc(Selection.Text) <> 13 And Asc(Selection.Text) <> 11) Then 'Íåò ïåðåõîäà íà íîâóþ ñòðîêó
                Selection.HomeKey Unit:=wdLine
                Selection.EndKey Unit:=wdLine, Extend:=wdExtend
                With regExp
                    .Pattern = "\[\[(\w+)\|([^\]]+)\]\]"
                    .Global = True
                    Selection.Text = .Replace(Selection.Text, "[URL=""http://myservice.ru/linkId?id=$1""]$2[/URL]")
                    'tip = "Çàãîëîâîê"
                    'link = "Ññûëêà"
                    'Selection.Range.Hyperlinks.Add Anchor:=Selection.Range, Address:=link, SubAddress:="", ScreenTip:="", TextToDisplay:=tip
                End With
            End If
        End If
    End If
    
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    'Application.Selection.Move 'Ñíèìàåì âûäåëåíèå
Next i
 
'RegExp DeInit
Set RA = Nothing
Set regExp = Nothing
'/RegExp DeInit


Обрабатывается каждая строка и в каждой строке регулярным выражением проверяется совпадение и если совпадение есть, тогда меняю текст.

Убил не один час, чтобы добавить ссылку, но ничего не вышло.

Необходимо вместо замены текста подставить замену текста на ссылку, но когда я это делаю (снять комментарии), у меня начинает ругаться на нехватку памяти.
0
Лучшие ответы (1)
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
02.07.2017, 19:26
Ответы с готовыми решениями:

Word: заменить текст в названиях на ссылки
Здравствуйте! Можно ли заменить текст на поля SEQ в документе применительно к названиям таблиц и...

MS Word(2010) Заменить текст в кавычках
Здравствуйте, помогите с макросом замены текста заключенного в &quot; &quot; на все заглавные. Текст может...

Как заменить текст в word с php?
Есть большой документ, нужно заменить некоторые слова из текста, как это сделать с помощью php?

Word 2007: найти текст и заменить
Здравствуйте, помогите с макросом, найти текст допустим (собака, лось, волк, лиса и т. д.) и...

Word 2007: найти текст и заменить шрифт
Здравствуйте, помогите с макросом, найти текст, в конкретном случае &quot;(&quot; скобка, и изменить ей шрифт...

6
Step_UA
1527 / 613 / 212
Регистрация: 09.06.2011
Сообщений: 1,264
02.07.2017, 22:12 2
Лучший ответ Сообщение было отмечено Bolbine84455 как решение

Решение

имхо, при небольшом количестве текста требующего замены на ссылки (относительно всего документа) штатный поиск будет побыстрее ...
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
  Dim R As Range, tmp$()
  'Dim Start As Integer: Start = 0
    Set R = ActiveDocument.Range
    With R.Find
        .ClearFormatting
        .Text = "[[]{2}[a-zA-Z0-9]{1;}|[!]]{1;}[]]{2}"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Application.ScreenUpdating = False
    Do While R.Find.Execute
        'If R.Start < Start Then Exit Do
        tmp = Split(R.Text, "|")
        R.Hyperlinks.Add R, "http://myservice/linkid?id=" & Mid(tmp(0), 3), , , Left(tmp(1), Len(tmp(1)) - 2)
        'Start = R.End
    Loop
    Application.ScreenUpdating = True
2
Bolbine84455
5 / 5 / 3
Регистрация: 12.03.2014
Сообщений: 339
03.07.2017, 01:15  [ТС] 3
Цитата Сообщение от Step_UA Посмотреть сообщение
Dim R As Range, tmp$()
* 'Dim Start As Integer: Start = 0
* *Set R = ActiveDocument.Range
* * With R.Find
* * * * .ClearFormatting
* * * * .Text = "[[]{2}[a-zA-Z0-9]{1;}|[!]]{1;}[]]{2}"
* * * * .Replacement.Text = ""
* * * * .Forward = True
* * * * .Wrap = wdFindContinue
* * * * .Format = False
* * * * .MatchCase = False
* * * * .MatchWholeWord = False
* * * * .MatchAllWordForms = False
* * * * .MatchSoundsLike = False
* * * * .MatchWildcards = True
* * End With
* * Application.ScreenUpdating = False
* * Do While R.Find.Execute
* * * * 'If R.Start < Start Then Exit Do
* * * *tmp = Split(R.Text, "|")
* * * * R.Hyperlinks.Add R, "http://myservice/linkid?id=" & Mid(tmp(0), 3), , , Left(tmp(1), Len(tmp(1)) - 2)
* * * * 'Start = R.End
* *Loop
* * Application.ScreenUpdating = True
Макрос рабочий.
Запускаю Word из стороннего приложения через OLE.
Ругается, на строчке "Set R = ActiveDocument.Range" и пишет, что Range не является свойством.
Вычитал, что необходимо активировать документ. Для этого применял ActivateMicrosoftApp, но оно не существует. Пробовал GetObject c CreateObject. Во всех случаях пишет, что Range не является свойством.
Можно данный момент как-то обойти?
0
Step_UA
1527 / 613 / 212
Регистрация: 09.06.2011
Сообщений: 1,264
03.07.2017, 10:41 4
Цитата Сообщение от Bolbine84455 Посмотреть сообщение
Запускаю Word из стороннего приложения через OLE.
Ругается, на строчке "Set R = ActiveDocument.Range" и пишет, что Range не является свойством.
Так покажите код запуска и открытия файла ...
1
Bolbine84455
5 / 5 / 3
Регистрация: 12.03.2014
Сообщений: 339
03.07.2017, 20:55  [ТС] 5
Цитата Сообщение от Step_UA Посмотреть сообщение
Так покажите код запуска и открытия файла ...
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'... Генерирую содержимое, сохраняю, удаляю объекты и затем заново открываю
Set objWord = CreateObject("Word.Application")
    If (objWord Is Nothing) Then
        MsgBox "Не удалось содать объект: Word.Application. Убедитесь, что у вас установлен MS Word."
        Exit Sub
    End If
    Set objDoc = objWord.Documents.Open(filePath)
    objWord.Visible = True
    objDoc.ActiveWindow.Activate
    Const wdWindowStateMaximize = 1
    Const wdWindowStateNormal = 0
    objDoc.ActiveWindow.WindowState = wdWindowStateMaximize
    objDoc.ActiveWindow.WindowState = wdWindowStateNormal
    '
    'Теперь сохраненный документ открыт, Word находится поверх всех окон (фокус на ворде), курсор стоит в самом начале строки. Далее вызывается функция замены ссылки (её код ниже). 
    
    Call replaceLink(objWord, objDoc)
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub replaceLink(objWord As Variant, objDoc As Variant)
    Const wdFindContinue = 1
    Dim R As Variant
    Dim tmp As Variant
    Set R = objDoc.Range
    R.Find.ClearFormatting
    R.Find.Text = "[[]{2}[a-zA-Z0-9]{1;}|[!]]{1;}[]]{2}"
    R.Find.Replacement.Text = ""
    R.Find.Forward = True
    R.Find.Wrap = wdFindContinue
    R.Find.Format = False
    R.Find.MatchCase = False
    R.Find.MatchWholeWord = False
    R.Find.MatchAllWordForms = False
    R.Find.MatchSoundsLike = False
    R.Find.MatchWildcards = True
    objWord.ScreenUpdating = False
    Do While R.Find.Execute
        tmp = Split(R.Text, "|")
        Call R.Hyperlinks.Add(R, "http://myservice/linkid?id=" & Mid(tmp(0), 3), , , Left(tmp(1), Len(tmp(1)) - 2))
    Loop
    objWord.ScreenUpdating = True
End Sub
В самом конце получаю ошибку:
Microsoft Word: "Range" не является свойством.
Указывает на строчку "Set R = objDoc.Range" в функции replaceLink
0
Step_UA
1527 / 613 / 212
Регистрация: 09.06.2011
Сообщений: 1,264
03.07.2017, 23:54 6
Проверил код в экселе - все путем. В пошаговом режиме посмотрите на переменную objDoc при входе в процедуру replaceLink
... единственное, что изменил бы:
Visual Basic
1
2
3
4
5
' в основной процедуре
Dim objWord As Object, objDoc As Object
 
' заголовок replaceLink
Sub replaceLink(ByRef objWord As Object, ByRef objDoc As Object)
0
Bolbine84455
5 / 5 / 3
Регистрация: 12.03.2014
Сообщений: 339
04.07.2017, 23:58  [ТС] 7
Цитата Сообщение от Step_UA Посмотреть сообщение
Проверил код в экселе - все путем. В пошаговом режиме посмотрите на переменную objDoc при входе в процедуру replaceLink
... единственное, что изменил бы:
Спасибо. Разобрался.
Set R = objDoc.Range()
Do While R.Find.Execute()
Методы все же, а не свойства
0
04.07.2017, 23:58
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
04.07.2017, 23:58

Работа с MS WORD. Найти текст и заменить его на картинку.
Добрый день. В программа необходимо обратиться к вордовскому документу и заменить в нем некоторый...

Как заменить некоторый текст написанный в word при помощи C++Builder
Народ подскажите кто знает, имеется шаблон в word документе (fam 1,fam2 и т.д) вообщем нужно что бы...

Считать текст из Word посредством Microsoft.Office.Interop.Word
Необходимо считать форматированный текст из Word посредством Microsoft.Office.Interop.Word. По...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
7
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.