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

@alexan0308 · Регистрация: 07.06.2011

Author24 — интернет-сервис помощи студентам

Можно ли написать процедуру для поиска в Word текста с указанным шрифтом, например, Arial? В Word такой поиск есть, и макрос записал, но внутри макроса ничего такого (с Arial) нет...

@Mawrat · 22.01.2013, 10:04

Поиск частей текста с заданными параметрами шрифта. В данном случае - поиск частей текста с заданным именем шрифта. Найденные части помечаются жирным красным шрифтом.

Delphi

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;

@alexan0308 · 22.01.2013, 12:59 **[ТС]**

А поиск текста с шрифтом, НЕ равному заданному, точно уже невозможно наверно? То есть найти все участки с шрифтом, отличным от Times New Roman?

@Mawrat · 22.01.2013, 18:15

Такие участки можно методом исключения искать. Т. е., у нас есть исходный диапазон, ищем в нём текст со шрифтом 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

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". И эти участки помечаются жирным красным шрифтом.

@alexan0308 · 22.01.2013, 20:18 **[ТС]**

Спасибо, классно! Только "Последний участок со шрифтом, отличным от заданного шрифта." дает ошибку - значение лежит за пределами допустимого диапазона

@Mawrat · 22.01.2013, 21:01

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

Delphi

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;

@alexan0308 · 23.01.2013, 10:46 **[ТС]**

Ок, работает! =)

Добавлено через 13 часов 38 минут
Еще есть проблемка, часто попадается и в других случаях. Не может перепрыгнуть автоматическое оглавление, застревает в нем... Как его пропустить?

@Mawrat · 23.01.2013, 13:41

Сообщение от alexan0308

Не может перепрыгнуть автоматическое оглавление, застревает в нем...

Наверное там какая-то особенность есть. А можешь здесь опубликовать пример файла, где застревает поиск?

@alexan0308 · 23.01.2013, 15:09 **[ТС]**

А нет, все работает... Это мои поиски глючные, наверно потому, что я их делал с помощью Selection по Корнякову... Переделаю по твоему... голова правда распухла, спрошу в другой теме если не получится =)

@alexan0308 · 24.01.2013, 16:50 **[ТС]**

Все таки вроде поиск поглюкивает... Вот немножечко исправил, ищу текст, отличный от Times New Roman. Результат в richedit.

Delphi

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'

@Mawrat · 26.01.2013, 08:10

На этом файле проверил - в самом деле, почему-то два участка определяются как со шрифтом, отличным от Times New Roman, хотя для всего текста в документе установлен Times New Roman. Исключая объекты с формулами. Я сегодня вечером поразбираюсь с этим.

Добавлено через 20 часов 46 минут
Сейчас разбирался с поиском по имени шрифта. Добавил обработку следующих особенностей:
- Оказалось, что если во всём диапазоне поиска установлен искомый шрифт, то весь этот текст не обнаруживается.
- В диапазонах, пропущенных системой поиска, шрифт может не только отличаться от искомого, но и может оказаться равным искомому или неопределённым. По крайней мере, такие вещи происходят в обсуждаемом документе.
В результате, для исследования документа получился такой VBA код:

Visual Basic

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

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. Может там кто-то знает природу всех этих явлений.

@alexan0308 · 27.01.2013, 12:25 **[ТС]**

Долго разбирался, поскольку вылезла еще проблема. На некоторых файлах поиск зацикливается, то есть постоянно происходит шаг вперед потом шаг назад. Открыл файл, поискал вручную, такое же зацикливание.

Пришлось перескакивать такие участки и код модифицировать.

Delphi

  ... 
 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;

растет внутри цикла...

@alexan0308 · 21.04.2013, 13:50 **[ТС]**

В общем, я поменял все. Так как для трех и более шрифтов код не годится.
В итоге
1. сначала получаю список всех шрифтов (для этого просто просматриваю все символы текста и узнаю их шрифт).
2. делаю поиск по шрифтам из списка, отличных от Times New Roman.
Все. Зато код линеен и более понятен. Единственная проблема - на просмотр всех символов уходит значительное время. Немного оптимизировал, просматриваю только каждый 5 символ, и скорость более-менее.
Может есть более быстрый способ получения списка используемых именно в данном документе шрифтов?

@alexan0308 106 / 82 / 15 Регистрация: 07.06.2011 Сообщений: 584 Записей в блоге: 2
		1
	Поиск в Word участков текста с заданным шрифтом 22.01.2013, 08:45. Показов 7968. Ответов 12 Метки document, find, find.execute, microsoft word, ms word, ole, range, ворд, диапазон, документ, поиск в диапазоне, поиск в документе, поиск по типу шрифта (Все метки) Можно ли написать процедуру для поиска в Word текста с указанным шрифтом, например, Arial? В Word такой поиск есть, и макрос записал, но внутри макроса ничего такого (с Arial) нет... 0

@alexan0308 106 / 82 / 15 Регистрация: 07.06.2011 Сообщений: 584 Записей в блоге: 2
	22.01.2013, 12:59 [ТС]	3
	А поиск текста с шрифтом, НЕ равному заданному, точно уже невозможно наверно? То есть найти все участки с шрифтом, отличным от Times New Roman? 0

@alexan0308 106 / 82 / 15 Регистрация: 07.06.2011 Сообщений: 584 Записей в блоге: 2
	22.01.2013, 20:18 [ТС]	5
	Спасибо, классно! Только "Последний участок со шрифтом, отличным от заданного шрифта." дает ошибку - значение лежит за пределами допустимого диапазона 0

@alexan0308 106 / 82 / 15 Регистрация: 07.06.2011 Сообщений: 584 Записей в блоге: 2
	23.01.2013, 10:46 [ТС]	7
	Ок, работает! =) Добавлено через 13 часов 38 минут Еще есть проблемка, часто попадается и в других случаях. Не может перепрыгнуть автоматическое оглавление, застревает в нем... Как его пропустить? 0

@Mawrat 13104 / 5885 / 1706 Регистрация: 19.09.2009 Сообщений: 8,808
	23.01.2013, 13:41	8
	Сообщение от alexan0308 Не может перепрыгнуть автоматическое оглавление, застревает в нем... Наверное там какая-то особенность есть. А можешь здесь опубликовать пример файла, где застревает поиск? 0

@alexan0308 106 / 82 / 15 Регистрация: 07.06.2011 Сообщений: 584 Записей в блоге: 2
	23.01.2013, 15:09 [ТС]	9
	А нет, все работает... Это мои поиски глючные, наверно потому, что я их делал с помощью Selection по Корнякову... Переделаю по твоему... голова правда распухла, спрошу в другой теме если не получится =) 0

@alexan0308 106 / 82 / 15 Регистрация: 07.06.2011 Сообщений: 584 Записей в блоге: 2
	21.04.2013, 13:50 [ТС]	13
	В общем, я поменял все. Так как для трех и более шрифтов код не годится. В итоге 1. сначала получаю список всех шрифтов (для этого просто просматриваю все символы текста и узнаю их шрифт). 2. делаю поиск по шрифтам из списка, отличных от Times New Roman. Все. Зато код линеен и более понятен. Единственная проблема - на просмотр всех символов уходит значительное время. Немного оптимизировал, просматриваю только каждый 5 символ, и скорость более-менее. Может есть более быстрый способ получения списка используемых именно в данном документе шрифтов? 0