VistA-cprs/CPRS-Chart/dShared.pas

unit dShared;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ImgList, uTemplates, ORFn, ORNet, ExtCtrls, ORCtrls, Richedit,
  VA508ImageListLabeler;

type
  TdmodShared = class(TDataModule)
    imgTemplates: TImageList;
    imgReminders: TImageList;
    imgNotes: TImageList;
    imgImages: TImageList;
    imgReminders2: TImageList;
    imgConsults: TImageList;
    imgSurgery: TImageList;
    imgLblReminders: TVA508ImageListLabeler;
    imgLblHealthFactorLabels: TVA508ImageListLabeler;
    imgLblNotes: TVA508ImageListLabeler;
    imgLblImages: TVA508ImageListLabeler;
    imgLblConsults: TVA508ImageListLabeler;
    imgLblSurgery: TVA508ImageListLabeler;
    imgLblReminders2: TVA508ImageListLabeler;
    procedure dmodSharedCreate(Sender: TObject);
    procedure dmodSharedDestroy(Sender: TObject);
  private
    FTIUObjects: TStringList;
    FInEditor: boolean;
    FOnTemplateLock: TNotifyEvent;
    FTagIndex: longint;
    FDrawerTrees: TList;
    FRefreshObject: boolean;
  protected
    procedure EncounterLocationChanged(Sender: TObject);
  public
    function ImgIdx(Node: TTreeNode): integer;
    procedure AddTemplateNode(Tree: TTreeView; var EmptyCount: integer;
                              const tmpl: TTemplate; AllowInactive: boolean = FALSE;
                              const Owner: TTreeNode = nil);
    function ExpandNode(Tree: TTreeView; Node: TTreeNode;
              var EmptyCount: integer; AllowInactive: boolean = FALSE): boolean;
    procedure Resync(SyncNode: TTreeNode; AllowInactive: boolean;
                                var EmptyCount: integer);
    procedure AddDrawerTree(DrawerForm: TForm);
    procedure RemoveDrawerTree(DrawerForm: TForm);
    procedure Reload;
    procedure LoadTIUObjects;
    function BoilerplateOK(const Txt, CRDelim: string; ObjList: TStringList;
                                                       var Err: TStringList): boolean;
    function TemplateOK(tmpl: TTemplate; Msg: string = ''): boolean;
    function NeedsCollapsing(Tree: TTreeView): boolean;
    procedure SelectNode(Tree: TORTreeView; GotoNodeID: string; var EmptyCount: integer);
    procedure ExpandTree(Tree: TORTreeView; ExpandString: string; var EmptyCount: integer;
                         AllowInactive: boolean = FALSE);
    function InDialog(Node: TTreeNode): boolean;
    property InEditor: boolean read FInEditor write FInEditor;
    property OnTemplateLock: TNotifyEvent read FOnTemplateLock write FOnTemplateLock;
    property TIUObjects: TStringList read FTIUObjects;
    property RefreshObject: boolean read FRefreshObject write FRefreshObject;
    procedure FindRichEditText(AFindDialog: TFindDialog; ARichEdit: TRichEdit);
    procedure ReplaceRichEditText(AReplaceDialog: TReplaceDialog; ARichEdit: TRichEdit);
  end;

var
  dmodShared: TdmodShared;

const
  ObjMarker = '^@@^';
  ObjMarkerLen = length(ObjMarker);
  DlgPropMarker = '^@=';
  DlgPropMarkerLen = length(DlgPropMarker);
  NoTextMarker = '<@>';

implementation

uses fDrawers, rTemplates, uCore, uTemplateFields, uEventHooks, VA508AccessibilityRouter;

{$R *.DFM}

const
  TemplateImageIdx: array[TTemplateType, Boolean, Boolean] of integer =
                          //    Personal       Shared
                          //  Closed  Open   Closed  Open
                          (((    0,    0), (    0,    0)),  //  ttNone,
                           ((    0,    1), (    0,    1)),  //  ttMyRoot
                           ((    0,    1), (    0,    1)),  //  ttRoot
                           ((    0,    1), (    0,    1)),  //  ttTitles
                           ((    0,    1), (    0,    1)),  //  ttConsults
                           ((    0,    1), (    0,    1)),  //  ttProcedures
                           ((    2,    3), (   16,   17)),  //  ttClass
                           ((    4,    4), (   10,   10)),  //  ttDoc
                           ((    5,    6), (   11,   12)),  //  ttGroup
                           ((    7,    7), (   13,   13)),  //  ttDocEx
                           ((    8,    9), (   14,   15))); //  ttGroupEx

  DialogConvMax = 7;
  DialogImageXRef: array[0..DialogConvMax, Boolean] of integer =
                           ((5,18), (6,19),
                            (8,20), (9,21),
                            (11,22),(12,23),
                            (14,24),(15,25));
                            
  RemDlgIdx: array[boolean] of integer = (26, 27);
  COMObjIdx: array[boolean] of integer = (29, 28);

function TdmodShared.ImgIdx(Node: TTreeNode): integer;
var
  Typ: TTemplateType;
  i: integer;

begin
  Result := -1;
  if(assigned(Node.Data)) then
  begin
    with TTemplate(Node.Data) do
    begin
      if (RealType = ttDoc) and (IsReminderDialog) then
        Result := RemDlgIdx[(PersonalOwner <= 0)]
      else
      if (RealType = ttDoc) and (IsCOMObject) then
        Result := COMObjIdx[COMObjectOK(COMObject)]
      else
      begin
        Typ := TemplateType;
        if(Exclude and (Typ in [ttDocEx, ttGroupEx])) then
        begin
          if(not assigned(Node.Parent)) or (TTemplate(Node.Parent.Data).RealType <> ttGroup) then
          begin
            case Typ of
              ttDocEx: Typ := ttDoc;
              ttGroupEx: Typ := ttGroup;
            end;
          end;
        end;
        Result := TemplateImageIdx[Typ, (PersonalOwner <= 0),
                  (Node.Expanded and Node.HasChildren)];
        if(Dialog and (Typ in [ttGroup, ttGroupEx])) then
        begin
          for i := 0 to DialogConvMax do
          begin
            if(Result = DialogImageXRef[i, FALSE]) then
            begin
              Result := DialogImageXRef[i, TRUE];
              break;
            end;
          end;
        end;
      end;
    end;
  end;
end;

procedure TdmodShared.AddTemplateNode(Tree: TTreeView; var EmptyCount: integer;
                              const tmpl: TTemplate; AllowInactive: boolean = FALSE;
                              const Owner: TTreeNode = nil);
var
  Cur, Next: TTreeNode;
  Done: boolean;
  NewNode: TTreeNode;

  procedure AddChildObject(Owner: TTreeNode);
  begin
    NewNode := Tree.Items.AddChildObject(Owner, tmpl.PrintName, tmpl);
    TORTreeNode(NewNode).StringData := tmpl.ID + U + tmpl.PrintName;
    NewNode.Cut := not tmpl.Active;
    tmpl.AddNode(NewNode);
    Done := TRUE;
  end;

begin
  if((assigned(tmpl)) and ((tmpl.Active) or AllowInactive)) then
  begin
    Done := FALSE;
    NewNode := nil;
    if(assigned(Owner)) then
    begin
      Cur := Owner.GetFirstChild;
      if(not assigned(Cur)) then
        AddChildObject(Owner);
    end
    else
    begin
      Cur := Tree.Items.GetFirstNode;
      if(not assigned(Cur)) then
        AddChildObject(nil);
    end;
    if(not Done) then
    begin
      repeat
        if(Cur.Data = tmpl) then
          Done := TRUE
        else
        begin
          Next := Cur.GetNextSibling;
          if(assigned(Next)) then
            Cur := Next
          else
            AddChildObject(Owner);
        end;
      until Done;
    end;
    if(assigned(NewNode) and (InEditor or (not tmpl.HideItems)) and 
                             ((tmpl.Children in [tcActive, tcBoth]) or
                             ((tmpl.Children <> tcNone) and AllowInactive))) then
    begin
      Tree.Items.AddChild(NewNode, EmptyNodeText);
      inc(EmptyCount);
    end;
  end;
end;

function TdmodShared.ExpandNode(Tree: TTreeView; Node: TTreeNode;
              var EmptyCount: integer; AllowInactive: boolean = FALSE): boolean;

var
  TmpNode: TTreeNode;
  tmpl: TTemplate;
  i :integer;

begin
  TmpNode := Node.GetFirstChild;
  Result := TRUE;
  if((assigned(TmpNode)) and (TmpNode.Text = EmptyNodeText)) then
  begin
    TmpNode.Delete;
    dec(EmptyCount);
    tmpl := TTemplate(Node.Data);
    ExpandTemplate(tmpl);
    for i := 0 to tmpl.Items.Count-1 do
      AddTemplateNode(Tree, EmptyCount, TTemplate(tmpl.Items[i]),
                      AllowInactive, Node);
    if((tmpl.Children = tcNone) or ((not AllowInactive) and (tmpl.Children = tcInactive))) then
      Result := FALSE;
  end;
end;

procedure TdmodShared.Resync(SyncNode: TTreeNode; AllowInactive: boolean;
                                var EmptyCount: integer);
var
  FromGet: boolean;
  IDCount, SyncLevel, i: integer;
  SyncExpanded: boolean;
  //SelNode,
  Node: TTreeNode;
  Template: TTemplate;
  IDSort, CurExp: TStringList;
  SelID, TopID: string;
  DoSel, DoTop: boolean;
  Tree: TTreeView;
  First: boolean;
  TagCount: longint;

  function InSyncNode(Node: TTreeNode): boolean;
  var
    TmpNode: TTreeNode;

  begin
    Result := FALSE;
    TmpNode := Node;
    while((not Result) and assigned(TmpNode)) do
    begin
      if(TmpNode = SyncNode) then
        Result := TRUE
      else
        TmpNode := TmpNode.Parent;
    end;
  end;

  function GetID(Node: TTreeNode): string;
  var
    tmpl: TTemplate;
    IDX: string;
    
  begin
    inc(IDCount);
    Result := '';
    if(assigned(Node) and assigned(Node.Data)) then
    begin
      tmpl := TTemplate(Node.Data);
      if((tmpl.ID = '') or (tmpl.ID = '0')) then
      begin
        if(tmpl.LastTagIndex <> FTagIndex) then
        begin
          tmpl.LastTagIndex := FTagIndex;
          inc(TagCount);
          tmpl.tag := TagCount;
        end;
        IDX := '<'+IntToStr(tmpl.Tag)+'>';
      end
      else
        IDX := tmpl.ID;
      if(Node <> SyncNode) and (assigned(Node.Parent)) then
        Result := U + GetID(Node.Parent);
      Result := IDX + Result;
    end;
    dec(IDCount);
    if((not FromGet) and (IDCount = 0) and (Result <> '')) then
      Result := IntToStr(Node.AbsoluteIndex) + U + Result;
  end;

  function GetNode(ID: string): TTreeNode;
  var
    idx, i :integer;
    TrueID, TmpStr: string;
    TmpNode: TTreeNode;

  begin
    Result := nil;
    if(ID <> '') then
    begin
      idx := StrToIntDef(Piece(ID,U,1),0);
      i := pos(U,ID);
      if(i > 0) then
      begin
        delete(ID,1,i);
        FromGet := TRUE;
        try
          TmpNode := SyncNode.GetFirstChild;
          while ((not assigned(Result)) and (assigned(TmpNode)) and
                 (TmpNode.Level > SyncLevel)) do
          begin
            if(GetID(TmpNode) = ID) then
              Result := TmpNode
            else
              TmpNode := TmpNode.GetNext;
          end;
          if(not assigned(Result)) then
          begin
            TrueID := piece(ID,U,1);
            TmpNode := SyncNode.GetFirstChild;
            while ((not assigned(Result)) and (assigned(TmpNode)) and
                   (TmpNode.Level > SyncLevel)) do
            begin
              if(assigned(TmpNode.Data) and (TTemplate(TmpNode.Data).ID = TrueID)) then
              begin
                TmpStr := IntToStr(abs(idx-TmpNode.AbsoluteIndex));
                TmpStr := copy('000000',1,7-length(TmpStr))+TmpStr;
                IDSort.AddObject(TmpStr,TmpNode);
              end;
              TmpNode := TmpNode.GetNext;
            end;
            if(IDSort.Count > 0) then
            begin
              IDSort.Sort;
              Result := TTreeNode(IDSort.Objects[0]);
              IDSort.Clear;
            end;
          end;
        finally
          FromGet := FALSE;
        end;
      end;
    end;
  end;

  procedure BuildNodes(tmpl: TTemplate; Owner: TTreeNode);
  var
    i: integer;
    TmpNode: TTreeNode;

  begin
    if(tmpl.Active or AllowInactive) then
    begin
      if(First) then
      begin
        First := FALSE;
        TmpNode := Owner;
      end
      else
      begin
        TmpNode := Tree.Items.AddChildObject(Owner, tmpl.PrintName, tmpl);
        TORTreeNode(TmpNode).StringData := tmpl.ID + U + tmpl.PrintName;
        TmpNode.Cut := not tmpl.Active;
        tmpl.AddNode(TmpNode);
      end;
      if(tmpl.Expanded) then
      begin
        for i := 0 to tmpl.Items.Count-1 do
          BuildNodes(TTemplate(tmpl.Items[i]), TmpNode);
      end
      else
      if(InEditor or (not tmpl.HideItems)) and
         ((tmpl.Children in [tcActive, tcBoth]) or
         (AllowInactive and (tmpl.Children = tcInactive))) then
      begin
        Tree.Items.AddChild(TmpNode, EmptyNodeText);
        inc(EmptyCount);
      end;
    end;
  end;

begin
  if(assigned(SyncNode)) then
  begin
    TagCount := 0;
    inc(FTagIndex);
    Tree := TTreeView(SyncNode.TreeView);
    Tree.Items.BeginUpdate;
    try
      SyncExpanded := SyncNode.Expanded;
      Template := TTemplate(SyncNode.Data);
      SyncLevel := SyncNode.Level;
      FromGet := FALSE;
      IDCount := 0;
      IDSort := TStringList.Create;
      try
      {-- Get the Current State of the tree --}
        CurExp := TStringList.Create;
        try
          Node := Tree.TopItem;
          DoTop := InSyncNode(Node);
          if(DoTop) then
            TopID := GetID(Node);

          Node := Tree.Selected;
          DoSel := InSyncNode(Node);
          if(DoSel) then
            SelID := GetID(Node);

          Node := SyncNode.GetFirstChild;
          while ((assigned(Node)) and (Node.Level > SyncLevel)) do
          begin
            if(Node.Text = EmptyNodeText) then
              dec(EmptyCount)
            else
            if(Node.Expanded) then
              CurExp.Add(GetID(Node));
            if(assigned(Node.Data)) then
              TTemplate(Node.Data).RemoveNode(Node);
            Node := Node.GetNext;
          end;

        {-- Recursively Rebuild the Tree --}
          SyncNode.DeleteChildren;
          First := TRUE;
          BuildNodes(Template, SyncNode);

        {-- Attempt to restore Tree to it's former State --}
          SyncNode.Expanded := SyncExpanded;
          for i := 0 to CurExp.Count-1 do
          begin
            Node := GetNode(CurExp[i]);
            if(assigned(Node)) then
              Node.Expand(FALSE);
          end;

          if(DoTop) and (TopID <> '') then
          begin
            Node := GetNode(TopID);
            if(assigned(Node)) then
              Tree.TopItem := Node;
          end;

          if(DoSel) and (SelID <> '') then
          begin
            Node := GetNode(SelID);
            if(assigned(Node)) then
            begin
              Tree.Selected := Node;
              Node.MakeVisible;
            end;
          end;

        finally
          CurExp.Free;
        end;

      finally
        IDSort.Free;
      end;

    finally
      Tree.Items.EndUpdate;
    end;
  end;
end;


procedure TdmodShared.dmodSharedCreate(Sender: TObject);
begin
  FDrawerTrees := TList.Create;
  imgReminders.Overlay(6,0);
  imgReminders.Overlay(7,1);
  imgReminders2.Overlay(4,0);
end;

procedure TdmodShared.dmodSharedDestroy(Sender: TObject);
begin
  KillObj(@FDrawerTrees);
  KillObj(@FTIUObjects);
end;

procedure TdmodShared.AddDrawerTree(DrawerForm: TForm);
begin
  if(assigned(FDrawerTrees)) and (FDrawerTrees.IndexOf(DrawerForm) < 0) then
    FDrawerTrees.Add(DrawerForm);
  Encounter.Notifier.NotifyWhenChanged(EncounterLocationChanged);
end;

procedure TdmodShared.RemoveDrawerTree(DrawerForm: TForm);
var
  idx: integer;

begin
  if(assigned(FDrawerTrees)) then
  begin
    idx := FDrawerTrees.IndexOf(DrawerForm);
    if(idx >= 0) then
      FDrawerTrees.Delete(idx);
  end;
end;

procedure TdmodShared.Reload;
var
  i: integer;

begin
  if(assigned(FDrawerTrees)) then
  begin
    ReleaseTemplates;
    for i := 0 to FDrawerTrees.Count-1 do
      TfrmDrawers(FDrawerTrees[i]).ExternalReloadTemplates;
  end;
end;

procedure TdmodShared.LoadTIUObjects;
var
  i: integer;

begin
  if(not assigned(FTIUObjects)) or (FRefreshObject = true)  then
  begin
    if(not assigned(FTIUObjects)) then
      FTIUObjects := TStringList.Create;
    FTIUObjects.Clear;
    GetObjectList;
    for i := 0 to RPCBrokerV.Results.Count-1 do
      FTIUObjects.Add(MixedCase(Piece(RPCBrokerV.Results[i],U,2))+U+RPCBrokerV.Results[i]);
    FTIUObjects.Sort;
    FRefreshObject := False;
   end;
end;

function TdmodShared.NeedsCollapsing(Tree: TTreeView): boolean;
var
  Node: TTreeNode;

begin
  Result := FALSE;
  if(assigned(Tree)) then
  begin
    Node := Tree.Items.GetFirstNode;
    while((not Result) and assigned(Node)) do
    begin
      Result := Node.Expanded;
      Node := Node.GetNextSibling;
    end;
  end;
end;

function TdmodShared.BoilerplateOK(const Txt, CRDelim: string; ObjList: TStringList;
                                                               var Err: TStringList): boolean;
var
  cnt, i, j, p: integer;
  tmp,obj: string;
  BadObj, ok: boolean;

  procedure AddErr(Amsg: string);
  begin
    if(not assigned(Err)) then
      Err := TStringList.Create;
    Err.Add(Amsg)
  end;

  function ErrCount: integer;
  begin
    if(Assigned(Err)) then
      Result := Err.Count
    else
      Result := 0;
  end;

begin
  if(assigned(ObjList)) then
    ObjList.Clear;
  cnt := ErrCount;
  tmp := Txt;
  BadObj := FALSE;
  repeat
    i := pos('|',tmp);
    if(i > 0) then
    begin
      delete(tmp,1,i);
      j := pos('|',tmp);
      if(j = 0) then
      begin
        AddErr('Unpaired "|" in Boilerplate');
        continue;
      end;
      obj := copy(tmp,1,j-1);
      delete(tmp,1,j);
      if(obj = '') then
      begin
        AddErr('Brackets "||" are there, but there''s no name inside it.');
        continue;
      end;
      j := pos(CRDelim, obj);
      if(j > 0) then
      begin
        AddErr('Object "'+copy(obj,1,j-1)+'" split between lines');
        continue;
      end;
      LoadTIUObjects;
      ok := FALSE;
      for j := 0 to FTIUObjects.Count-1 do
      begin
        for p := 3 to 5 do
        begin
          if(obj = piece(FTIUObjects[j],U,p)) then
          begin
            ok := TRUE;
            if(assigned(ObjList)) and (ObjList.IndexOf(ObjMarker + obj) < 0) then
            begin
              ObjList.Add(ObjMarker + obj);
              ObjList.Add('|' + obj + '|');
            end;
            break;
          end;
        end;
        if(ok) then break;
      end;
      if(not ok) then
      begin
        AddErr('Object "'+obj+'" not found.');
        BadObj := TRUE;
      end;
    end;
  until(i=0);
  Result := (cnt = ErrCount);
  if(not Result) then
  begin
    Err.Insert(0,'Boilerplate Contains Errors:'); 
    Err.Insert(1,'');
    if(BadObj) then
    begin
      Err.Add('');
      Err.Add('Use UPPERCASE and object''s exact NAME, PRINT NAME, or ABBREVIATION');
      Err.Add('Any of these may have changed since an object was embedded.');
    end;
  end;
  if(assigned(ObjList) and (ObjList.Count > 0)) then
    ObjList.Add(ObjMarker);
end;

function TdmodShared.TemplateOK(tmpl: TTemplate; Msg: string = ''): boolean;
var
  Err: TStringList;
  btns: TMsgDlgButtons;

begin
  Err := nil;
  try
    Result := BoilerplateOK(tmpl.FullBoilerplate, #13, nil, Err);
    if(not Result) then
    begin
      if(Msg = 'OK') then
        btns := [mbOK]
      else
      begin
        btns := [mbAbort, mbIgnore];
        Err.Add('');
        if(Msg = '') then
          Msg := 'template insertion';
        Err.Add('Do you want to Abort '+Msg+', or Ignore the error and continue?');
      end;
      Result := (MessageDlg(Err.Text, mtError, btns, 0) = mrIgnore);
    end;
  finally
    if(assigned(Err)) then
      Err.Free;
  end;
  if Result then
    Result := BoilerplateTemplateFieldsOK(tmpl.FullBoilerplate, Msg);
end;

procedure TdmodShared.EncounterLocationChanged(Sender: TObject);
var
  i: integer;

begin
  if(assigned(FDrawerTrees)) then
  begin
    for i:= 0 to FDrawerTrees.count-1 do
      TfrmDrawers(FDrawerTrees[i]).UpdatePersonalTemplates;
  end;
end;

procedure TdmodShared.SelectNode(Tree: TORTreeView; GotoNodeID: string; var EmptyCount: integer);
var
  i, j: integer;
  IEN, PIEN: string;
  Node: TORTreeNode;

  function FindNode(StartNode: TORTreeNode): TORTreeNode;
  begin
    Result := nil;
    while assigned(StartNode) do
    begin
      if(Piece(StartNode.StringData, U ,1) = IEN) then
      begin
        Result := StartNode;
        exit;
      end;
      StartNode := TORTreeNode(StartNode.GetNextSibling);
    end;
  end;

begin
  if(GotoNodeID <> '') then
  begin
    i := 1;
    for j := 1 to length(GotoNodeID) do
      if(GotoNodeID[j] = ';') then inc(i);
    PIEN := '';
    Node := TORTreeNode(Tree.Items.GetFirstNode);
    repeat
      IEN := piece(GotoNodeID, ';', i);
      if(IEN <> '') then
      begin
        Node := FindNode(Node);
        if(assigned(Node)) then
        begin
          if(PIEN <> '') then
            PIEN := ';' + PIEN;
          PIEN := IEN + PIEN;
          if(PIEN = GotoNodeID) then
          begin
            Node.EnsureVisible;
            Tree.Selected := Node;
            IEN := '';
          end
          else
          begin
            dmodShared.ExpandNode(Tree, Node, EmptyCount);
            Node := TORTreeNode(Node.GetFirstChild);
            if(assigned(Node)) then
              dec(i)
            else
              IEN := '';
          end;
        end
        else
          IEN := '';
      end;
    until (i < 1) or (IEN = '');
  end;
end;

function TdmodShared.InDialog(Node: TTreeNode): boolean;
begin
  Result := FALSE;
  while assigned(Node) and (not Result) do
  begin
    if TTemplate(Node.Data).IsDialog then
      Result := TRUE
    else
      Node := Node.Parent;
  end;
end;

procedure TdmodShared.ExpandTree(Tree: TORTreeView; ExpandString: string;
  var EmptyCount: integer; AllowInactive: boolean = FALSE);

var
  NStr: string;
  i: integer;
  Node: TTreeNode;

begin
  Tree.Items.BeginUpdate;
  try
    i := 1;
    repeat
      NStr := piece(ExpandString,U,i);
      if(NStr <> '') then
      begin
        inc(i);
        Node := Tree.FindPieceNode(NStr, 1, ';');
        if assigned(Node) then
        begin
          ExpandNode(Tree, Node, EmptyCount, AllowInactive);
          Node.Expand(False);
        end;
      end;
    until(NStr = '');
  finally
    Tree.Items.EndUpdate;
  end;
end;

procedure TdmodShared.FindRichEditText(AFindDialog: TFindDialog; ARichEdit: TRichEdit);
const
  TX_NOMATCH = 'The text was not found';
  TC_NOMATCH = 'No more matches';
var
  FoundAt, FoundLine, TopLine, BottomLine: LongInt;
  StartPos, ToEnd, CharPos: Integer;
  SearchOpts: TSearchTypes;
begin
  SearchOpts := [];
  with ARichEdit do
  begin
    SetFocus;
    { begin the search after the current selection if there is one }
    { otherwise, begin at the start of the text }
    if SelStart <> 0 then
      StartPos := SelStart + SelLength
    else
      StartPos := 0;
    { ToEnd is the length from StartPos to the end of the text in the rich edit control }
    ToEnd := Length(Text) - StartPos;
    if frMatchCase in AFindDialog.Options then Include(SearchOpts, stMatchCase);
    if frWholeWord in AFindDialog.Options then Include(SearchOpts, stWholeWord);
    FoundAt := FindText(AFindDialog.FindText, StartPos, ToEnd, SearchOpts);
    if FoundAt <> -1 then
    begin
      SetFocus;
      TopLine := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
      BottomLine := TopLine + (Height div FontHeightPixel(Font.Handle));
      FoundLine := SendMessage(Handle, EM_EXLINEFROMCHAR, 0, FoundAt);
      if (FoundLine + 10) > BottomLine then
        SendMessage(Handle, EM_LINESCROLL, 0, FoundLine - BottomLine + 10);
      CharPos := Pos(AFindDialog.FindText, Lines[FoundLine]);
      SendMessage(ARichEdit.Handle, EM_LINESCROLL, CharPos, 0);
      SelStart := FoundAt;
      SelLength := Length(AFindDialog.FindText);
    end
    else
    begin
      if not (frReplaceAll in AFindDialog.Options) then InfoBox(TX_NOMATCH, TC_NOMATCH, MB_OK);
      SelStart := 0;
      SelLength := 0;
      Windows.SetFocus(AFindDialog.Handle);
      //AFindDialog.CloseDialog;
    end;
  end;
end;

procedure TdmodShared.ReplaceRichEditText(AReplaceDialog: TReplaceDialog; ARichEdit: TRichEdit);
const
  TC_COMPLETE  = 'Replacement Complete';
  TX_COMPLETE1 = 'CPRS has finished searching the document.  ' + CRLF;
  TX_COMPLETE2 = ' replacements were made.';
var
  Replacements: integer;
  NewStart: integer;
begin
  Replacements := 0;
  if (frReplace in AReplaceDialog.Options) then
    begin
      if ARichEdit.SelLength > 0 then
        begin
          NewStart := ARichEdit.SelStart + Length(AReplaceDialog.ReplaceText);
          ARichEdit.SelText := AReplaceDialog.ReplaceText;
          ARichEdit.SelStart := NewStart;
          //Replacements := Replacements + 1;
        end;
      FindRichEditText(AReplaceDialog, ARichEdit);
    end
  else if (frReplaceAll in AReplaceDialog.Options) then
    begin
      repeat
        if ARichEdit.SelLength > 0 then
          begin
            NewStart := ARichEdit.SelStart + Length(AReplaceDialog.ReplaceText);
            ARichEdit.SelText := AReplaceDialog.ReplaceText;
            ARichEdit.SelStart := NewStart;
            Replacements := Replacements + 1;
          end;
        FindRichEditText(AReplaceDialog, ARichEdit);
      until ARichEdit.SelLength = 0;
      InfoBox(TX_COMPLETE1 + IntToStr(Replacements) + TX_COMPLETE2, TC_COMPLETE, MB_OK);
    end
  else
    FindRichEditText(AReplaceDialog, ARichEdit);
end;

initialization
  SpecifyFormIsNotADialog(TdmodShared);

end.