Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
Блоги Сообщество Поиск Заказать работу  
 
Рейтинг 4.64/11: Рейтинг темы: голосов - 11, средняя оценка - 4.64
6 / 6 / 3
Регистрация: 12.03.2014
Сообщений: 341
Word

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

02.07.2017, 19:26. Показов 2468. Ответов 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)
Programming
Эксперт
39485 / 9562 / 3019
Регистрация: 12.04.2006
Сообщений: 41,671
Блог
02.07.2017, 19:26
Ответы с готовыми решениями:

Заменить текст на текст в верхнем индексе
Sub test765() Set oDoc = Activedocument text = &quot;с_1 - предельно допустимая концентрация СО_2...

Есть форма два текст бокса и кнопка.В текст бокс 1 задаем номер слова, а в текст бокс 2 те
a = TextBox1.Value TextBox2.Text = ActiveDocument.Range.Words(a) Эти строки задают слово для...

Код не работает если заменить переменную на ссылку на ячейку
Добрый день! Прикрепил файл, в котом два простых примера. В одном я сначала задаю год из ячейки в...

6
 Аватар для Step_UA
1591 / 664 / 225
Регистрация: 09.06.2011
Сообщений: 1,334
02.07.2017, 22:12
Лучший ответ Сообщение было отмечено 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
6 / 6 / 3
Регистрация: 12.03.2014
Сообщений: 341
03.07.2017, 01:15  [ТС]
Цитата Сообщение от 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
1591 / 664 / 225
Регистрация: 09.06.2011
Сообщений: 1,334
03.07.2017, 10:41
Цитата Сообщение от Bolbine84455 Посмотреть сообщение
Запускаю Word из стороннего приложения через OLE.
Ругается, на строчке "Set R = ActiveDocument.Range" и пишет, что Range не является свойством.
Так покажите код запуска и открытия файла ...
1
6 / 6 / 3
Регистрация: 12.03.2014
Сообщений: 341
03.07.2017, 20:55  [ТС]
Цитата Сообщение от 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
1591 / 664 / 225
Регистрация: 09.06.2011
Сообщений: 1,334
03.07.2017, 23:54
Проверил код в экселе - все путем. В пошаговом режиме посмотрите на переменную 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
6 / 6 / 3
Регистрация: 12.03.2014
Сообщений: 341
04.07.2017, 23:58  [ТС]
Цитата Сообщение от Step_UA Посмотреть сообщение
Проверил код в экселе - все путем. В пошаговом режиме посмотрите на переменную objDoc при входе в процедуру replaceLink
... единственное, что изменил бы:
Спасибо. Разобрался.
Set R = objDoc.Range()
Do While R.Find.Execute()
Методы все же, а не свойства
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
inter-admin
Эксперт
29715 / 6470 / 2152
Регистрация: 06.03.2009
Сообщений: 28,500
Блог
04.07.2017, 23:58
Помогаю со студенческими работами здесь

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

Неверная ссылка вперед или ссылка на не откомпилированный тип
Привет всем, после обновления Windows 10 появилась ошибка: &quot;Неверная ссылка вперед или ссылка на...

Даны два числа. Большее из них заменить полусуммой, а меньшее заменить удвоенным произведением
Даны два числа. Большее из них заменить полусуммой, а меньшее заменить удвоенным произведением.

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

Сделать текст ссылкой
Добрый день! Подскажите пожалуйста, как сделать так, чтобы текст прописанный в одном столбце...


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

Или воспользуйтесь поиском по форуму:
7
Ответ Создать тему
Новые блоги и статьи
Архитектура слоя интернета для сервера-слоя.
Hrethgir 11.04.2026
В продолжение https:/ / www. cyberforum. ru/ blogs/ 223907/ 10860. html Знаешь что я подумал? Раз мы все источники пишем в голове ветки, то ничего не мешает добавить в голову такой источник, который сам. . .
Подстановка значения реквизита справочника в табличную часть документа
Maks 10.04.2026
Алгоритм из решения ниже реализован на примере нетипового документа "ПланированиеПерсонала", разработанного в конфигурации КА2. Задача: при выборе сотрудника (справочник Сотрудники) в ТЧ документа. . .
Очистка реквизитов документа при копировании
Maks 09.04.2026
Алгоритм из решения ниже применим как для типовых, так и для нетиповых документов на самых различных конфигурациях. Задача: при копировании документа очищать определенные реквизиты и табличную. . .
модель ЗдравоСохранения 8. Подготовка к разному выполнению заданий
anaschu 08.04.2026
https:/ / github. com/ shumilovas/ med2. git main ветка * содержимое блока дэлэй из старой модели теперь внутри зайца новой модели 8ATzM_2aurI
Блокировка документа от изменений, если он открыт у другого пользователя
Maks 08.04.2026
Алгоритм из решения ниже реализован на примере нетипового документа, разработанного в конфигурации КА2. Задача: запретить редактирование документа, если он открыт у другого пользователя. / / . . .
Система безопасности+живучести для сервера-слоя интернета (сети). Двойная привязка.
Hrethgir 08.04.2026
Далее были размышления о системе безопасности. Сообщения с наклонным текстом - мои. А как нам будет можно проверить, что ссылка наша, а не подделана хулиганами, которая выбросит на другую ветку и. . .
Модель ЗдрввоСохранения 7: больше работников, больше ресурсов.
anaschu 08.04.2026
работников и заданий может быть сколько угодно, но настроено всё так, что используется пока что только 20% kYBz3eJf3jQ
Дальние перспективы сервера - слоя сети с космологическим дизайном интефейса карты и логики.
Hrethgir 07.04.2026
Дальнейшее ближайшее планирование вывело к размышлениям над дальними перспективами. И вот тут может быть даже будут нужны оценки специалистов, так как в дальних перспективах всё может очень сильно. . .
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2026, CyberForum.ru