Форум программистов, компьютерный форум, киберфорум
Delphi для начинающих
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.76/29: Рейтинг темы: голосов - 29, средняя оценка - 4.76
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
1

Поиск в Word участков текста с заданным шрифтом

22.01.2013, 08:45. Просмотров 5595. Ответов 12


Можно ли написать процедуру для поиска в Word текста с указанным шрифтом, например, Arial? В Word такой поиск есть, и макрос записал, но внутри макроса ничего такого (с Arial) нет...
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
22.01.2013, 08:45
Ответы с готовыми решениями:

Вывод графических элементов: строки текста заданным цветом и шрифтом
Вывести на экран монитора горизонтальная строка текста длиной не более двадцати пяти символов...

Delphi 7 ClienSocket.Socket.SendText(Edt2), отправка текста на сервер с заданным шрифтом
Доброго времени суток, вопрос не корректен так как, я новичок, лишь 3 или 4 раз включаю Delphi 7,...

Поиск нужной таблицы и выделение текста по заданным условиям
подскажите пожалуйста Необходимо написать макрос в котором: 1)найти нужную таблицу (у каждой...

Поиск и замена текста в word
Как в тексте документа ворда заменить одно слово на другое? Dim DocWord = New...

12
13064 / 5850 / 1705
Регистрация: 19.09.2009
Сообщений: 8,807
22.01.2013, 10:04 2
Поиск частей текста с заданными параметрами шрифта. В данном случае - поиск частей текста с заданным именем шрифта. Найденные части помечаются жирным красным шрифтом.
Delphi
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
51
52
53
54
55
56
57
uses
  ComObj;
 
{Пояснение по поиску.
Объект wdFind связан с диапазоном wdRng. При каждом вызове wdFind.Execute
поиск продолжается в том диапазоне, который определял wdRng до первого
вызова wdFind.Execute. Т. е., поиск выполняется в одном и том же диапазоне.
Но сам объект wdRng изменяется при каждом обнаружении искомого текста - он
становится равным диапазону, который охватывает этот найденный текст.}
procedure TForm1.Button1Click(Sender: TObject);
const
  wdFindStop = 0; //Завершить поиск при достижении границы диапазона.
var
  wdApp, wdDoc, wdRng, wdFind : Variant;
  Od : TOpenDialog;
begin
  Od := OpenDialog1; //OpenDialog1 уже должен быть на форме.
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Od.Execute then Exit;
  if not FileExists(Od.FileName) then begin
    MessageBox(0, 'Файл с заданным именем не найден. Действие отменено.'
      ,'Файл не найден', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
 
  //Запуск MS Word и подключение к его корневому объекту.
  try
    wdApp := CreateOleObject('Word.Application');
  except
    MessageBox(0, 'Не удалось запустить MS Word. Действие отменено.',
      'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
 
  wdApp.Visible := True;
  wdDoc := wdApp.Documents.Open(Od.FileName);
  wdRng := wdDoc.Content; //Диапазон, охватывающий всё содержимое документа.
 
  //Настройка поиска.
  wdFind := wdRng.Find;
  wdFind.ClearFormatting;
  wdFind.Text := '';
  wdFind.Font.Name := 'Arial';
  //True - поиск вести от начала - к концу диапазона.
  wdFind.Forward := True;
  //wdFindStop - Завершить поиск при достижении границы диапазона.
  wdFind.Wrap := wdFindStop;
 
  //Поиск частей текста с заданным именем шрифта и пометка этих частей
  //жирным красным шрифтом.
  while wdFind.Execute do begin
    //Помечаем найденный текст жирным красным шрифтом.
    wdRng.Font.Bold := True;
    wdRng.Font.Color := RGB(255, 100, 100);
  end;
end;
1
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
22.01.2013, 12:59  [ТС] 3
А поиск текста с шрифтом, НЕ равному заданному, точно уже невозможно наверно? То есть найти все участки с шрифтом, отличным от Times New Roman?
0
13064 / 5850 / 1705
Регистрация: 19.09.2009
Сообщений: 8,807
22.01.2013, 18:15 4
Такие участки можно методом исключения искать. Т. е., у нас есть исходный диапазон, ищем в нём текст со шрифтом Times New Roman. Предположим, нашли такой участок. Тогда первый участок (диапазон) со шрифтом, отличным от Times New Roman, будет расположен от начала исходного диапазона до начала найденного диапазона. Потом продолжаем поиск участков со шрифтом Times New Roman. Если опять нашли такой участок, то его диапазон расположен от конца диапазона со шрифтом Times New Roman, который мы нашли на предыдущей итерации и до начала диапазона, который мы нашли на текущей итерации.
И в конце, когда при очередном поиске мы не нашли участок со шрифтом Times New Roman, то значит, последний участок со шрифтом, отличным от Times New Roman, будет расположен от конца найденного диапазона на предыдущей итерации и до конца исходного диапазона (в котором мы выполняем поиск).
Вот таким образом можно отыскать все участки, на которых шрифт отличен от заданного (отличен от Times New Roman, в данном случае).
---
Вот как это можно сделать. Только здесь я взял шрифт "Arial", а не "Times New Roman".
Delphi
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
uses
  ComObj;
 
{Пояснение по поиску.
Объект wdFind связан с диапазоном wdRngF1. При каждом вызове wdFind.Execute
поиск продолжается в том диапазоне, который определял wdRng до первого
вызова wdFind.Execute. Т. е., поиск выполняется в одном и том же диапазоне.
Но сам объект wdRngF1 изменяется при каждом обнаружении искомого текста - он
становится равным диапазону, который охватывает этот найденный текст.}
procedure TForm1.Button1Click(Sender: TObject);
const
  wdFindStop = 0; //Завершить поиск при достижении границы диапазона.
var
  wdApp, wdDoc, wdRng, wdRngF1, wdRngF2, wdFind : Variant;
  Start : Integer;
  Od : TOpenDialog;
begin
  Od := OpenDialog1; //OpenDialog1 уже должен быть на форме.
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Od.Execute then Exit;
  if not FileExists(Od.FileName) then begin
    MessageBox(0, 'Файл с заданным именем не найден. Действие отменено.'
      ,'Файл не найден', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
 
  //Запуск MS Word и подключение к его корневому объекту.
  try
    wdApp := CreateOleObject('Word.Application');
  except
    MessageBox(0, 'Не удалось запустить MS Word. Действие отменено.',
      'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
 
  wdApp.Visible := True;
  wdDoc := wdApp.Documents.Open(Od.FileName);
  //Диапазон поиска - охватывает всё содержимое документа.
  wdRng := wdDoc.Content;
  //Диапазон, который будет определять найденные участки с заданным шрифтом.
  wdRngF1 := wdDoc.Content;
  //Диапазон, который будет определять найденные участки со шрифтом, отличным
  //от заданного.
  VarClear(wdRngF2);
 
  //Настройка поиска.
  wdFind := wdRngF1.Find;
  wdFind.ClearFormatting;
  wdFind.Text := '';
  wdFind.Font.Name := 'Arial';
  //True - поиск вести от начала - к концу диапазона.
  wdFind.Forward := True;
  //wdFindStop - Завершить поиск при достижении границы диапазона.
  wdFind.Wrap := wdFindStop;
 
  //Поиск частей текста с заданным именем шрифта. Каждый раз при обнаружении
  //такого участка мы будем определять другой участок - на котором имя шрифта
  //отличается от заданного. И этот другой участок будем помечать красным жирным шрифтом.
  Start := wdRng.Start;
  while wdFind.Execute do begin
    //wdRngF1 - диапазон, охватывающий найденный участок текста с заданным шрифтом.
    //wdRngF2 - диапазон, охватывающий участок текста со шрифтом, отличным от заданного.
    wdRngF2 := wdDoc.Range(Start, wdRngF1.Start);
    wdRngF2.Font.Bold := True;
    wdRngF2.Font.Color := RGB(255, 100, 100);
    Start := wdRngF1.End;
  end;
  //Последний участок со шрифтом, отличным от заданного шрифта.
  wdRngF2 := wdDoc.Range(Start, wdRng.End);
  wdRngF2.Font.Bold := True;
  wdRngF2.Font.Color := RGB(255, 100, 100);
end;
Здесь находятся все участки со шрифтом, имя которого отличается от "Arial". И эти участки помечаются жирным красным шрифтом.
1
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
22.01.2013, 20:18  [ТС] 5
Спасибо, классно! Только "Последний участок со шрифтом, отличным от заданного шрифта." дает ошибку - значение лежит за пределами допустимого диапазона
0
13064 / 5850 / 1705
Регистрация: 19.09.2009
Сообщений: 8,807
22.01.2013, 21:01 6
Да, верно - ошибка в случаях, когда участок с заданным шрифтом расположен в самом начале или (и) в самом конце искомого диапазона. Тогда надо добавить проверку на пустой диапазон. Т. е., если позиция начала и конца совпадают, то такой диапазон не учитывать.
Исправленный код:
Delphi
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
uses
  ComObj;
 
{Пояснение по поиску.
Объект wdFind связан с диапазоном wdRngF1. При каждом вызове wdFind.Execute
поиск продолжается в том диапазоне, который определял wdRng до первого
вызова wdFind.Execute. Т. е., поиск выполняется в одном и том же диапазоне.
Но сам объект wdRngF1 изменяется при каждом обнаружении искомого текста - он
становится равным диапазону, который охватывает этот найденный текст.}
procedure TForm1.Button1Click(Sender: TObject);
const
  wdFindStop = 0; //Завершить поиск при достижении границы диапазона.
var
  wdApp, wdDoc, wdRng, wdRngF1, wdRngF2, wdFind : Variant;
  wdStart, wdEnd : Integer;
  Od : TOpenDialog;
begin
  Od := OpenDialog1; //OpenDialog1 уже должен быть на форме.
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Od.Execute then Exit;
  if not FileExists(Od.FileName) then begin
    MessageBox(0, 'Файл с заданным именем не найден. Действие отменено.'
      ,'Файл не найден', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
 
  //Запуск MS Word и подключение к его корневому объекту.
  try
    wdApp := CreateOleObject('Word.Application');
  except
    MessageBox(0, 'Не удалось запустить MS Word. Действие отменено.',
      'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
 
  wdApp.Visible := True;
  wdDoc := wdApp.Documents.Open(Od.FileName);
  //Диапазон поиска - охватывает всё содержимое документа.
  wdRng := wdDoc.Content;
  //Диапазон, который будет определять найденные участки с заданным шрифтом.
  wdRngF1 := wdDoc.Content;
  //Диапазон, который будет определять найденные участки со шрифтом, отличным
  //от заданного.
  VarClear(wdRngF2);
 
  //Настройка поиска.
  wdFind := wdRngF1.Find;
  wdFind.ClearFormatting;
  wdFind.Text := '';
  wdFind.Font.Name := 'Arial';
  //True - поиск вести от начала - к концу диапазона.
  wdFind.Forward := True;
  //wdFindStop - Завершить поиск при достижении границы диапазона.
  wdFind.Wrap := wdFindStop;
 
  //Поиск частей текста с заданным именем шрифта. Каждый раз при обнаружении
  //такого участка мы будем определять другой участок - на котором имя шрифта
  //отличается от заданного. И этот другой участок будем помечать красным жирным шрифтом.
  wdStart := wdRng.Start;
  while wdFind.Execute do begin
    //wdRngF1 - диапазон, охватывающий найденный участок текста с заданным шрифтом.
    //wdRngF2 - диапазон, охватывающий участок текста со шрифтом, отличным от заданного.
    wdEnd := wdRngF1.Start;
    if wdStart < wdEnd then begin
      wdRngF2 := wdDoc.Range(wdStart, wdEnd);
      wdRngF2.Font.Bold := True;
      wdRngF2.Font.Color := RGB(255, 100, 100);
    end;
    wdStart := wdRngF1.End;
  end;
  //Последний участок со шрифтом, отличным от заданного шрифта.
  wdEnd := wdRng.End;
  if wdStart < wdEnd then begin
    wdRngF2 := wdDoc.Range(wdStart, wdEnd);
    wdRngF2.Font.Bold := True;
    wdRngF2.Font.Color := RGB(255, 100, 100);
  end;
end;
0
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
23.01.2013, 10:46  [ТС] 7
Ок, работает! =)

Добавлено через 13 часов 38 минут
Еще есть проблемка, часто попадается и в других случаях. Не может перепрыгнуть автоматическое оглавление, застревает в нем... Как его пропустить?
0
13064 / 5850 / 1705
Регистрация: 19.09.2009
Сообщений: 8,807
23.01.2013, 13:41 8
Цитата Сообщение от alexan0308 Посмотреть сообщение
Не может перепрыгнуть автоматическое оглавление, застревает в нем...
Наверное там какая-то особенность есть. А можешь здесь опубликовать пример файла, где застревает поиск?
0
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
23.01.2013, 15:09  [ТС] 9
А нет, все работает... Это мои поиски глючные, наверно потому, что я их делал с помощью Selection по Корнякову... Переделаю по твоему... голова правда распухла, спрошу в другой теме если не получится =)
0
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
24.01.2013, 16:50  [ТС] 10
Все таки вроде поиск поглюкивает... Вот немножечко исправил, ищу текст, отличный от Times New Roman. Результат в richedit.
Delphi
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
procedure TForm1.Button12Click(Sender: TObject);
{Пояснение по поиску.
Объект wdFind связан с диапазоном wdRngF1. При каждом вызове wdFind.Execute
поиск продолжается в том диапазоне, который определял wdRng до первого
вызова wdFind.Execute. Т. е., поиск выполняется в одном и том же диапазоне.
Но сам объект wdRngF1 изменяется при каждом обнаружении искомого текста - он
становится равным диапазону, который охватывает этот найденный текст.}
const
  wdFindStop = 0; //Завершить поиск при достижении границы диапазона.
var
  wdApp, wdDoc, wdRng, wdRngF1, wdRngF2, wdFind : Variant;
  wdStart, wdEnd, Straniza : Integer;
  Od : TOpenDialog;
begin
  Od := OpenDialog1; //OpenDialog1 уже должен быть на форме.
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Od.Execute then Exit;
  if not FileExists(Od.FileName) then begin
    MessageBox(0, 'Файл с заданным именем не найден. Действие отменено.'
      ,'Файл не найден', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
 
  //Запуск MS Word и подключение к его корневому объекту.
  try
    wdApp := CreateOleObject('Word.Application');
  except
    MessageBox(0, 'Не удалось запустить MS Word. Действие отменено.',
      'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
 
  wdApp.Visible := True;
  wdDoc := wdApp.Documents.Open(Od.FileName);
  //Диапазон поиска - охватывает всё содержимое документа.
  wdRng := wdDoc.Content;
  //Диапазон, который будет определять найденные участки с заданным шрифтом.
  wdRngF1 := wdDoc.Content;
  //Диапазон, который будет определять найденные участки со шрифтом, отличным
  //от заданного.
  VarClear(wdRngF2);
 
  //Настройка поиска.
  wdFind := wdRngF1.Find;
  wdFind.ClearFormatting;
  wdFind.Text := '';
  wdFind.Font.Name := ';'Times New Roman
  //True - поиск вести от начала - к концу диапазона.
  wdFind.Forward := True;
  //wdFindStop - Завершить поиск при достижении границы диапазона.
  wdFind.Wrap := wdFindStop;
 
  //Поиск частей текста с заданным именем шрифта. Каждый раз при обнаружении
  //такого участка мы будем определять другой участок - на котором имя шрифта
  //отличается от заданного. И этот другой участок будем помечать красным жирным шрифтом.
  wdStart := wdRng.Start;
  while wdFind.Execute do begin
    //wdRngF1 - диапазон, охватывающий найденный участок текста с заданным шрифтом.
    //wdRngF2 - диапазон, охватывающий участок текста со шрифтом, отличным от заданного.
    wdEnd := wdRngF1.Start;
    if wdStart < wdEnd then begin
      wdRngF2 := wdDoc.Range(wdStart, wdRngF1.Start);
      Straniza:=wdRngF2.Information[3];   // определяем текущий номер страницы в Ворд
      sssr:=wdRngF2.Text;
      Richedit1.Lines.Add(sssr + 'на стр. ' + inttostr(Straniza));
      wdRngF2.Font.Bold := True;
      wdRngF2.Font.Color := RGB(255, 100, 100);
    end;
    wdStart := wdRngF1.End;
  end;
  //Последний участок со шрифтом, отличным от заданного шрифта.
  wdEnd := wdRng.End;
  if wdStart < wdEnd then begin
    wdRngF2 := wdDoc.Range(wdStart, wdEnd);
    wdRngF2.Font.Bold := True;
    wdRngF2.Font.Color := RGB(255, 100, 100);
  end;
  showmessage('ok');
end;
Вот на етом файле что то не так работает:
Курсовик.doc
Хотя текст вроде полностью 'Times New Roman'
0
13064 / 5850 / 1705
Регистрация: 19.09.2009
Сообщений: 8,807
26.01.2013, 08:10 11
На этом файле проверил - в самом деле, почему-то два участка определяются как со шрифтом, отличным от Times New Roman, хотя для всего текста в документе установлен Times New Roman. Исключая объекты с формулами. Я сегодня вечером поразбираюсь с этим.

Добавлено через 20 часов 46 минут
Сейчас разбирался с поиском по имени шрифта. Добавил обработку следующих особенностей:
- Оказалось, что если во всём диапазоне поиска установлен искомый шрифт, то весь этот текст не обнаруживается.
- В диапазонах, пропущенных системой поиска, шрифт может не только отличаться от искомого, но и может оказаться равным искомому или неопределённым. По крайней мере, такие вещи происходят в обсуждаемом документе.
В результате, для исследования документа получился такой VBA код:
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Sub sub1()
Dim wdDoc As Word.Document
  Dim wdRng As Word.Range
  Dim wdRngF1 As Word.Range
  Dim wdRngF2 As Word.Range
  Dim wdFind As Word.Find
  Dim wdStart As Long
  Dim wdEnd As Long
  'Заданный шрифт. Будем искать текст с этим шрифтом.
  Const FontNameF = "Times New Roman"
  
  Set wdDoc = ActiveDocument
  Set wdRng = wdDoc.Content
  Set wdRngF1 = wdDoc.Content
  Set wdFind = wdRngF1.Find
  
  With wdFind
    .ClearFormatting
    .Text = ""
    .Font.Name = FontNameF
    .Forward = True
    .Wrap = wdFindStop
  End With
  
  wdStart = wdRng.Start
  wdEnd = wdRng.End
  Debug.Print "------------------------------"
  Debug.Print "Дипазон поиска: " & wdStart & " - " & wdEnd
  Debug.Print "Заданный шрифт: " & FontNameF
  
  Do While wdFind.Execute
    'Сведения о шрифте в диапазоне, который пропущен системой поиска.
    wdEnd = wdRngF1.Start
    If wdStart < wdEnd Then 'Если пропущенный диапазон не пуст.
      Set wdRngF2 = wdDoc.Range(wdStart, wdEnd) 'Пропущенный диапазон.
      Select Case wdRngF2.Font.Name
        Case FontNameF: 'Если шрифт определён и равен искомому.
          Debug.Print "(+) " & FontNameF & ": " & wdStart & " - " & wdEnd
        Case "": 'Если шрифт не определён.
          Debug.Print "(!) ?: " & wdStart & " - " & wdEnd
        Case Else 'Если шрифт определён и не равен искомому.
          wdRngF2.Font.Color = RGB(255, 100, 100)
          wdRngF2.Font.Bold = True
          Debug.Print "(-) " & wdRngF2.Font.Name & ": " & wdStart & " - " & wdEnd
      End Select
    End If
    'Сведения о шрифте в диапазоне, найденном системой поиска.
    wdStart = wdEnd
    wdEnd = wdRngF1.End
    Debug.Print "(+) " & wdRngF1.Font.Name & ": " & wdStart & " - " & wdEnd
    wdStart = wdEnd
  Loop
  
  'Сведения о шрифте в последнем диапазоне, который пропущен системой поиска.
  wdEnd = wdRng.End
  If wdStart < wdEnd Then 'Если пропущенный диапазон не пуст.
    Set wdRngF2 = wdDoc.Range(wdStart, wdEnd) 'Пропущенный диапазон.
    Select Case wdRngF2.Font.Name
      Case FontNameF: 'Если шрифт определён и равен искомому.
        Debug.Print "(+) " & wdRngF2.Font.Name & ": " & wdStart & " - " & wdEnd
      Case "": 'Если шрифт не определён.
        Debug.Print "(!) ?: " & wdStart & " - " & wdEnd
      Case Else 'Если шрифт определён и неравен искомому.
        wdRngF2.Font.Color = RGB(255, 100, 100)
        wdRngF2.Font.Bold = True
        Debug.Print "(-) " & wdRngF2.Font.Name & ": " & wdStart & " - " & wdEnd
    End Select
  End If
End Sub
Этот код выводит сведения о диапазонах и шрифтах в окно Immediate (главное меню VBA редактора - View - Immediate Window). Кроме этого, участки текста, где шрифт определился и не равен заданному, помечаются красным жирным шрифтом.
В Delphi подобный код будет выглядеть так:
Delphi
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
uses
  ComObj;
 
{Пояснение по поиску.
Объект wdFind связан с диапазоном wdRngF1. При каждом вызове wdFind.Execute
поиск продолжается в том диапазоне, который определял wdRng до первого
вызова wdFind.Execute. Т. е., поиск выполняется в одном и том же диапазоне.
Но сам объект wdRngF1 изменяется при каждом обнаружении искомого текста - он
становится равным диапазону, который охватывает этот найденный текст.}
procedure TForm1.Button1Click(Sender: TObject);
const
  FontNameF = 'Times New Roman'; //Искомый шрифт.
  wdFindStop = 0; //Завершить поиск при достижении границы диапазона.
var
  wdApp, wdDoc, wdRng, wdRngF1, wdRngF2, wdFind : Variant;
  wdStart, wdEnd : Integer;
  FontName : String;
  Od : TOpenDialog;
begin
  Od := OpenDialog1; //OpenDialog1 уже должен быть на форме.
  if Od.InitialDir = '' then
    Od.InitialDir := ExtractFilePath( ParamStr(0) );
  if not Od.Execute then Exit;
  if not FileExists(Od.FileName) then begin
    MessageBox(0, 'Файл с заданным именем не найден. Действие отменено.'
      ,'Файл не найден', MB_OK + MB_ICONEXCLAMATION + MB_APPLMODAL);
    Exit;
  end;
 
  //Запуск MS Word и подключение к его корневому объекту.
  try
    wdApp := CreateOleObject('Word.Application');
  except
    MessageBox(0, 'Не удалось запустить MS Word. Действие отменено.',
      'Ошибка', MB_OK + MB_ICONERROR + MB_APPLMODAL);
    Exit;
  end;
 
  wdApp.Visible := True;
  wdDoc := wdApp.Documents.Open(Od.FileName);
  //Диапазон поиска - охватывает всё содержимое документа.
  wdRng := wdDoc.Content;
  //Диапазон, который будет определять участки, найденные системой поиска.
  wdRngF1 := wdDoc.Content;
  //Диапазон, который будет определять участки, пропущенные системой поиска.
  VarClear(wdRngF2);
 
  //Настройка поиска.
  wdFind := wdRngF1.Find;
  wdFind.ClearFormatting;
  wdFind.Text := '';
  wdFind.Font.Name := FontNameF;
  //True - поиск вести от начала - к концу диапазона.
  wdFind.Forward := True;
  //wdFindStop - Завершить поиск при достижении границы диапазона.
  wdFind.Wrap := wdFindStop;
 
  wdStart := wdRng.Start;
  wdEnd := wdRng.End;
  Memo1.Lines.Add('------------------------------');
  Memo1.Lines.Add('Дипазон поиска: ' + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
  Memo1.Lines.Add('Заданный шрифт: ' + FontNameF);
 
  //Поиск частей (диапазонов) текста с заданным именем шрифта. Каждый раз при
  //обнаружении такого участка мы будем определять также и другой участок - который
  //был пропущен системой поиска.
  while wdFind.Execute do begin
    //wdRngF1 - диапазон, охватывающий найденный участок текста.
    //wdRngF2 - диапазон, охватывающий пропущенный участок.
    //Сведения о шрифте в диапазоне, который пропущен системой поиска.
    wdEnd := wdRngF1.Start;
    if wdStart < wdEnd then begin //Если пропущенный диапазон не пуст.
      wdRngF2 := wdDoc.Range(wdStart, wdEnd); //Пропущенный диапазон.
      FontName := wdRngF2.Font.Name;
      if FontName = FontNameF then begin //Если шрифт определён и равен искомому.
        Memo1.Lines.Add('(+) ' + FontName + ': '
          + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
      end else if FontName = '' then begin //Если шрифт не определён.
        Memo1.Lines.Add('(!) ?: '
          + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
      end else begin //Если шрифт определён и не равен искомому.
        Memo1.Lines.Add('(-) ' + FontName + ': '
          + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
        wdRngF2.Font.Color := RGB(255, 100, 100);
        wdRngF2.Font.Bold := True;
      end;
    end;
    //Сведения о шрифте в диапазоне, найденном системой поиска.
    wdStart := wdEnd;
    wdEnd := wdRngF1.End;
    Memo1.Lines.Add('(+) ' + wdRngF1.Font.Name + ': '
      + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
    wdStart := wdRngF1.End;
  end;
 
  //Сведения о шрифте в последнем диапазоне, который пропущен системой поиска.
  wdEnd := wdRng.End;
  if wdStart < wdEnd then begin //Если пропущенный диапазон не пуст.
    wdRngF2 := wdDoc.Range(wdStart, wdEnd); //Пропущенный диапазон.
    FontName := wdRngF2.Font.Name;
    if FontName = FontNameF then begin //Если шрифт определён и равен искомому.
      Memo1.Lines.Add('(+) ' + FontName + ': '
        + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
    end else if FontName = '' then begin //Если шрифт не определён.
      Memo1.Lines.Add('(!) ?: '
        + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
    end else begin //Если шрифт определён и не равен искомому.
      Memo1.Lines.Add('(-) ' + FontName + ': '
        + IntToStr(wdStart) + ' - ' + IntToStr(wdEnd));
      wdRngF2.Font.Color := RGB(255, 100, 100);
      wdRngF2.Font.Bold := True;
    end;
  end;
end;
Что касается обсуждаемого документа. Представленный выше код распознаёт в нём шрифт на всех участках:
Код
------------------------------
Дипазон поиска: 0 - 6217
Заданный шрифт: Times New Roman
(+) Times New Roman: 0 - 1
(+) Times New Roman: 1 - 2
(+) Times New Roman: 2 - 3
(+) Times New Roman: 3 - 4
(+) Times New Roman: 4 - 5
(+) Times New Roman: 5 - 14
(+) Times New Roman: 14 - 686
(+) Times New Roman: 686 - 1306
(+) Times New Roman: 1306 - 1513
(+) Times New Roman: 1513 - 1626
(+) Times New Roman: 1626 - 1655
(+) Times New Roman: 1655 - 1772
(+) Times New Roman: 1772 - 2032
(+) Times New Roman: 2032 - 2127
(+) Times New Roman: 2127 - 2141
(+) Times New Roman: 2141 - 2176
(+) Times New Roman: 2176 - 2192
(+) Times New Roman: 2192 - 2209
(+) Times New Roman: 2209 - 2239
(+) Times New Roman: 2239 - 2281
(+) Times New Roman: 2281 - 2333
(+) Times New Roman: 2333 - 2376
(+) Times New Roman: 2376 - 2433
(+) Times New Roman: 2433 - 2667
(+) Times New Roman: 2667 - 2768
(+) Times New Roman: 2768 - 2779
(+) Times New Roman: 2779 - 2787
(+) Times New Roman: 2787 - 2813
(+) Times New Roman: 2813 - 2852
(+) Times New Roman: 2852 - 2974
(+) Times New Roman: 2974 - 3113
(+) Times New Roman: 3113 - 3311
(+) Times New Roman: 3311 - 3338
(+) Times New Roman: 3338 - 3470
(+) Times New Roman: 3470 - 3471
(+) Times New Roman: 3471 - 3717
(+) Times New Roman: 3717 - 3742
(+) Times New Roman: 3742 - 3800
(+) Times New Roman: 3800 - 3955
(+) Times New Roman: 3955 - 3959
(+) Times New Roman: 3959 - 3960
(+) Times New Roman: 3960 - 3961
(+) Times New Roman: 3961 - 3962
(+) Times New Roman: 3962 - 3963
(+) Times New Roman: 3963 - 3964
(+) Times New Roman: 3964 - 3965
(+) Times New Roman: 3965 - 3966
(+) Times New Roman: 3966 - 3967
(+) Times New Roman: 3967 - 3968
(+) Times New Roman: 3968 - 3969
(+) Times New Roman: 3969 - 3970
(+) Times New Roman: 3970 - 3971
(+) Times New Roman: 3971 - 3972
(+) Times New Roman: 3972 - 3973
(+) Times New Roman: 3973 - 3974
(+) Times New Roman: 3974 - 3975
(+) Times New Roman: 3975 - 3976
(+) Times New Roman: 3976 - 3977
(+) Times New Roman: 3977 - 3978
(+) Times New Roman: 3978 - 3979
(+) Times New Roman: 3979 - 3980
(+) Times New Roman: 3980 - 3981
(+) Times New Roman: 3981 - 3982
(+) Times New Roman: 3982 - 3983
(+) Times New Roman: 3983 - 4010
(+) Times New Roman: 4010 - 4035
(+) Times New Roman: 4035 - 4036
(+) Times New Roman: 4036 - 4317
(+) Times New Roman: 4317 - 4375
(+) Times New Roman: 4375 - 4442
(+) Times New Roman: 4442 - 4452
(+) Times New Roman: 4452 - 4485
(+) Times New Roman: 4485 - 4787
(+) Times New Roman: 4787 - 4905
(+) Times New Roman: 4905 - 4939
(+) Times New Roman: 4939 - 5073
(+) Times New Roman: 5073 - 5074
(+) Times New Roman: 5074 - 5111
(+) Times New Roman: 5111 - 5112
(+) Times New Roman: 5112 - 5452
(+) Times New Roman: 5452 - 5569
(+) Times New Roman: 5569 - 5598
(+) Times New Roman: 5598 - 5607
(+) Times New Roman: 5607 - 5632
(+) Times New Roman: 5632 - 5692
(+) Times New Roman: 5692 - 5950
(+) Times New Roman: 5950 - 5971
(+) Times New Roman: 5971 - 6068
(+) Times New Roman: 6068 - 6217
Но если выделить всё содержимое документа и задать шрифт Times New Roman (или любой другой), а потом обработать его кодом, то получим уже другой результат:
Код
------------------------------
Дипазон поиска: 0 - 6217
Заданный шрифт: Times New Roman
(!) ?: 0 - 6217
Т. е., во всём содержимом документа шрифт оказался не распознанным.
Если поизучать документ, то обнаруживается следующее:
- При выделении всего содержимого документа через CTRL+a, шрифт оказывается неопределённым - это видно в элементе, который показывает имя шрифта на панели инструментов.
- Если начать выделять содержимое документа сверху, то не доходя до конца 3-ей страницы, шрифт становится неопределённым.
- Если начать выделение снизу, то шрифт оказывается неопределённым тоже на 3-ей странице, но выше - ближе к её началу. - На том месте, где записана формула под номером 28.
---
За разъяснениями можно попробовать обратиться в разделы: VBA и MS Office Word. Может там кто-то знает природу всех этих явлений.
1
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
27.01.2013, 12:25  [ТС] 12
Долго разбирался, поскольку вылезла еще проблема. На некоторых файлах поиск зацикливается, то есть постоянно происходит шаг вперед потом шаг назад. Открыл файл, поискал вручную, такое же зацикливание.

Пришлось перескакивать такие участки и код модифицировать.
Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
  ... 
 dobavka:=500;
...
while wdFind.Execute do begin
         // если вдруг поиск зациклился, и вернулся к предыдущему месту
         if (wdFind.Parent.Start<wdFind_Parent_End_previous) then
             begin
              //    Form1.RichEdit1.Lines.Add('problem');
             wdRng := wdDoc.Range(wdFind_Parent_End_previous+ dobavka, wdDoc.Content.End);
             wdRngF1 := wdDoc.Range(wdFind_Parent_End_previous+dobavka, wdDoc.Content.End);
                dobavka:= dobavka + 500;  // пытаемся преодолеть притяжение и оторваться от места зацикливания
              wdFind := wdRngF1.Find;  // будем искать на новом участке
             wdStart := wdRng.Start;
             wdEnd := wdRng.End;
             continue;
             end;
 
     wdFind_Parent_End_previous:= wdFind.parent.end; dobavka:=500;
         // дальше как было
    //wdRngF1 - диапазон, охватывающий найденный участок текста.
    //wdRngF2 - диапазон, охватывающий пропущенный участок.
    //Сведения о шрифте в диапазоне, который пропущен системой поиска.
    wdEnd := wdRngF1.Start;
    if wdStart < wdEnd then begin //Если пропущенный диапазон не пуст.
Причем бывает, пока не уйти достаточно далеко вправо, не удается выйти из зацикливания. Поэтому добавка
Delphi
1
dobavka:= dobavka + 500;
растет внутри цикла...
1
105 / 81 / 15
Регистрация: 07.06.2011
Сообщений: 572
Записей в блоге: 2
21.04.2013, 13:50  [ТС] 13
В общем, я поменял все. Так как для трех и более шрифтов код не годится.
В итоге
1. сначала получаю список всех шрифтов (для этого просто просматриваю все символы текста и узнаю их шрифт).
2. делаю поиск по шрифтам из списка, отличных от Times New Roman.
Все. Зато код линеен и более понятен. Единственная проблема - на просмотр всех символов уходит значительное время. Немного оптимизировал, просматриваю только каждый 5 символ, и скорость более-менее.
Может есть более быстрый способ получения списка используемых именно в данном документе шрифтов?
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
21.04.2013, 13:50

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь или здесь.

Поиск и замена текста в Word
Коллеги, помогите как определить последовательность цифр в тексте. и если не трудно подскажите где...

Поиск текста в Word-документе
Не работает поиск в Word документе как исправить? Если берешь .txt файл и меняешь расширение то...

Поиск текста в Word документе
Всем привет. Нужен советь по такой теме. Дело обстоить так: Есть папка с Ворд документами. И есть...

Поиск текста в документах Word
Есть код ВБА. Он работает .. нигде не могу найти команды!!!! Может кто-то поможет ....Код для...


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

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

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