Core/DBDWordReaderMSs.pas - master - YakuninAV/Convertors

Core/DBDWordReaderMSs.pas
350 строк11 KB
YakuninAV
begin with gitflick
31 июл 2026, 15:21
31 июл 2026, 15:211dc0fc6
/// модуль реализует класс для чтения ворда
unit DBDWordReaderMSs;

{$I Synopse.inc} // define HASINLINE USETYPEINFO CPU32 CPU64 OWNNORMTOUPPER

interface

uses
  SysUtils, Classes, ComObj, ActiveX, Variants, Windows, Messages,
  OleServer, Word2000,
  SynCommons,
  DBDStrUtils, DBDIntfs;

type

  TDBDWordReaderOle = class(TDBDBaseWordReader)
  strict private
    iHeader: Integer;
    WRD: OleVariant;
    DOC: OleVariant;
    tab: OleVariant;
    tabRowsCount, tabColsCount: Integer;
    function ParseTableName(const Txt: string; out TabID: string; out TabName: string): Boolean;
    function GetTableNameAboveTable(tbl: OleVariant; out TabID: string; out TabName: string): Boolean; overload;
  public
    /// Проверить наличие установленного в системе MSWord
    class function CheckWordInstall: Boolean;
    /// Проверить запущен ли Word
    function CheckWordRun: Boolean;
    /// Запустить Word
    function RunWord(DisableAlerts:Boolean=True; Visible: Boolean=False): Boolean;
    /// Закрыть документ Word
    procedure Close; override;
    /// Получить из текста название документа (используя стиль)
    function GetDocumentTitle: string; override;
    /// Функция извлекает из текста первый заголовок или возвращает false
    function GetFirstHeader(var Lvl: Integer; var BegPos: Integer; out S: string): Boolean; override;
    /// Функция извлекает из текста очередной заголовок или возвращает false
    function GetNextHeader(var Lvl: Integer; var BegPos: Integer; out S: string): Boolean; override;
    /// Функция возвращает количетсво таблиц в документе
    function TablesCount: Integer; override;
    /// Открыть документ Word
    function OpenWordDocument(const aFileName: TFileName): Integer; override;
    /// Функция возвращает содержимое таблицы
    function GetTable(const Index: Integer; out Table: Variant; out ID: string; out Name: string): Boolean; override;
    /// Функция возвращает идентификатор и наименование таблицы
    function GetTableName(const SeqNo: Integer; out ID: string; out Name: string): Boolean; override;
    /// Функция премещает указатель на таблицу, если не удалось, то возвращает false
    function GoToTable(const Index: integer; out ID: string; out Name: string; out tabPos: Integer): Boolean; override;
    /// Функция возвращает значение из ячейки текущей таблицы
    function GetCellAsText(const Row, Col: Integer; out Text: string): Boolean; override;
    /// Функция возвращает значение из ячейки текущей таблицы
    function GetCellAsUTF8(const Row, Col: Integer; out Text: RawUTF8): Boolean; override;
    /// Количество строк в текущей таблице
    function RowsCount: Integer; override;
    /// Количество колонок в текущей таблице
    function ColsCount: Integer; override;
   /// Конструктор
    constructor Create(FileName: TFileName; const aNotifier: IDBDNotifierV1 = nil);
    destructor Destroy; override;
  end;

const
  WordApp = 'Word.Application';
  lcid = LOCALE_USER_DEFAULT;

implementation

{ TTDBWordReaderOle }

function TDBDWordReaderOle.CheckWordRun: Boolean;
begin
  try
    WRD:=GetActiveOleObject(WordApp);
    Result:=True;
  except
    Result:=false;
  end;
end;

class function TDBDWordReaderOle.CheckWordInstall: Boolean;
var ClassID: TCLSID;
begin
  Result:=CLSIDFromProgID(PWideChar(WideString(WordApp)), ClassID) = S_OK;
end;

procedure TDBDWordReaderOle.Close;
begin
   tab:=Unassigned;
   DOC:=Unassigned;
end;

function TDBDWordReaderOle.ColsCount: Integer;
begin
  Result:= tabColsCount;
end;

constructor TDBDWordReaderOle.Create(FileName: TFileName; const aNotifier: IDBDNotifierV1);
begin
  inherited Create(aNotifier);
end;

destructor TDBDWordReaderOle.Destroy;
begin
  Close;
  WRD.Quit;
  WRD:=Unassigned;
  inherited;
end;

function TDBDWordReaderOle.GetCellAsText(const Row, Col: Integer; out Text: string): Boolean;
var s: string;
begin
  Text:=''; Result:=False;
  if (Row<1) or (Col<1) or (Row>tabRowsCount) or (Col>tabColsCount) then Exit;
  try
    s:=tab.Cell(Row,Col).Range.Text;
    if DBDWordTabCellTrim then begin
      Text:=DBDCorrectString(s, [dbdSCARemoveExtaBlanks]);
      Text:=SysUtils.Trim(Text);
    end else Text:=s;
    Result:=True;
  except on E: Exception do begin
    if E.HelpContext<>25421 then Log(dmkCrashInfo, E.HelpContext, E.Message)
                            else Result := True;  // объединённые ячейки
  end;
  end;
end;

function TDBDWordReaderOle.GetCellAsUTF8(const Row, Col: Integer; out Text: RawUTF8): Boolean;
var s: string;
begin
  Result:=GetCellAsText(Row,Col,s); if Result then Text:=StringToUTF8(s);
end;

function TDBDWordReaderOle.GetDocumentTitle: string;
var rng: OleVariant;
begin
  try
    rng := Doc.Content;
    rng.Find.ClearFormatting;
    rng.Find.Text := '';
    rng.Find.Replacement.ClearFormatting;
    rng.Find.Format := True;
    rng.Find.Style := wdStyleTitle;
    rng.Find.Forward := True;
//    rng.Find.Wrap := wdFindContinue;
//    rng.Find.MatchCase := wrfMatchCase in Flags;
//    rng.Find.MatchWholeWord := False;
//    rng.Find.MatchWildcards := wrfMatchWildcards in Flags;
//    rng.Find.MatchSoundsLike := False;
//    rng.Find.MatchAllWordForms := False;
    if rng.Find.Execute then result := rng.Text else result := '';
  except
    result := '';
  end;
  rng:=Unassigned;
end;

function TDBDWordReaderOle.GetFirstHeader(var Lvl: Integer; var BegPos: Integer; out S: string): Boolean;
var oRng: OleVariant;
begin
  try
    iHeader:=1;
    oRng := Doc.Goto(wdGoToHeading, wdGoToAbsolute, 1);
    Result := oRng.Expand(wdParagraph)>0;
    if Result then begin
      BegPos := oRng.Start;
      S := oRng.Text;
      Lvl := oRng.Paragraphs.First.OutlineLevel;
    end else begin
      S:=''; iHeader:=-1;
    end;
  except
    result:=False;
    S:='Exception';
  end;
  oRng:=Unassigned;
end;

function TDBDWordReaderOle.GetNextHeader(var Lvl: Integer; var BegPos: Integer; out S: string): Boolean;
var oRng: OleVariant; i: Integer;
begin
  Result:=False; S:='';
  if iHeader<=0 then Log(dmkErrorInfo,-1, 'Не выполнен поиск первого заголовка')
  else if iHeader>1000 then Log(dmkErrorInfo,1000, 'Слишком много заголовков (>1000)')
  else begin
    Inc(iHeader);
    try
      oRng := Doc.GoTo(wdGoToHeading, wdGoToNext, iHeader);
      i := oRng.Expand(wdParagraph);
      Result := i>0;
      if Result then begin
        BegPos := oRng.Start;
        S := oRng.Text;
        Lvl := oRng.Paragraphs.First.OutlineLevel;
        Result := Lvl<10;
      end else begin
        iHeader:=-1;
      end;
    except
      Result:=False;
      S:='Exception';
    end;
    oRng:=Unassigned;
  end;
end;

function TDBDWordReaderOle.GetTable(const Index: Integer; out Table: Variant; out ID, Name: string): Boolean;
var s: string; i: Integer; o: OleVariant;
begin
  if Index<=0 then Result := False
  else begin
    i:=DOC.Tables.Count;
    if (i<1) or (i<Index) then Result:=False
    else begin
      try
        o:=DOC.Tables.Item[Index];
        s:=o.Descr;
        Name:=s;
        Log(dmkDebugInfo, Index, s);
        Table:=o.Range.Value;
        Result:=True;
      except on E: Exception do
        Result:=False;
      end;
      o:=Unassigned;
    end;
  end;
end;

function TDBDWordReaderOle.GetTableName(const SeqNo: Integer; out ID, Name: string): Boolean;
var s: string;
begin
  Result := DOC.Tables.Count>0;
  if Result then begin
    s := DOC.Tables.Descr;
    if s <> '' then begin
      Name:=s;
    end else Name:='';
  end;
end;

function TDBDWordReaderOle.GetTableNameAboveTable(tbl: OleVariant; out TabID, TabName: string): Boolean;
var rng: OleVariant; s: string;
begin
  rng := Tbl.Range.Previous(wdParagraph, 1); s := rng.Text;
  Result := ParseTableName(s, TabID, TabName); if Result then Exit;
  rng := rng.Previous(wdParagraph, 1); s := rng.Text; Result := ParseTableName(s, TabID, TabName);
  if Result then begin if TabName='' then TabName := rng.Next(wdParagraph, 1); Exit; end;
  rng := rng.Previous(wdParagraph, 1); s := rng.Text; Result := ParseTableName(s, TabID, TabName);
  if Result and (TabName='') then TabName := rng.Next(wdParagraph, 1);
  rng:=Unassigned;
end;

function TDBDWordReaderOle.GoToTable(const Index: integer; out ID: string; out Name: string; out tabPos: Integer): Boolean;
var s: string; i: Integer;
begin
  tabRowsCount:=-1; tabColsCount:=-1;
  if Index<=0 then Result := False
  else begin
   i:=DOC.Tables.Count;
    if (i<1) or (i<Index) then Result:=False
    else
      try
        tab:=DOC.Tables.Item(Index);
        tabRowsCount:=tab.Rows.Count;
        tabColsCount:=tab.Columns.Count;
        tabPos:=tab.Range.Start;
        s := tab.Title;
        if s<>'' then ParseTableName(s, ID, Name)
                 else GetTableNameAboveTable(tab, ID, Name);
        Result:=True;
      except on E: Exception do begin
        Result:=False;
        Log(dmkCrashInfo, 0, E.Message);
        end;
      end;
  end;
end;

function TDBDWordReaderOle.OpenWordDocument(const aFileName: TFileName): Integer;
begin
  if (aFileName='') then Result := -1
  else if not FileExists(aFileName) then Result := -2
  else if not CheckWordInstall then Result := -3
  else begin
    if (not CheckWordRun) { and (AutoRun) } then RunWord;
    if CheckWordRun then begin
      try
        DOC:=WRD.Documents.Open(aFileName,0,True);
        Result:=DOC.Tables.Count;
      except
        Result := -5;
      end;
    end else Result := -6;
  end;
end;

function TDBDWordReaderOle.ParseTableName(const Txt: string; out TabID, TabName: string): Boolean;
var i,j: integer; s: string; f: Boolean; ds: TDBDString;
begin
  TabID:='0'; TabName:=''; i:=1;
  Result := DBDReadWord(Txt, i, s); if not Result then Exit;
  ds:=TDBDString.Create(Txt);
  ds.ReadWord(s);
  s := AnsiUpperCase(s);
  Result := (s = 'ТАБЛИЦА');
  if (not Result) and ((s = 'ПРОДОЛЖЕНИЕ') or (s = 'ОКОНЧАНИЕ')) then begin
    ds.ReadWord(s);
    Result := (AnsiUpperCase(s) = 'ТАБЛИЦЫ');
  end;
  if not Result then Exit;
  // извлечь номер таблицы и идентификатор
  ds.ReadWord(TabID);
  TabName:=ds.Remainder;
end;

function TDBDWordReaderOle.RowsCount: Integer;
begin
  Result:=tabRowsCount;
end;

function TDBDWordReaderOle.RunWord(DisableAlerts, Visible: Boolean): Boolean;
begin
  try
    if CheckWordInstall then begin
      WRD:=CreateOleObject(WordApp);
      //показывать/не показывать системные сообщения Excel (лучше не показывать)
      WRD.Application.EnableEvents:=DisableAlerts;
      WRD.Visible:=Visible;
      Result:=True;
    end else begin
      Result:=False;
    end;
  except
    Result:=False;
  end;
end;

function TDBDWordReaderOle.TablesCount: Integer;
begin
  try
    Result:=DOC.Tables.Count;
  except
    Result:=-1;
  end;
end;

end.