source: cprs/branches/tmg-cprs/CPRS-Chart/rHTMLTools.pas@ 736

unit rHTMLTools;
(*This entire unit was created by K. Toppenberg, starting on 5/27/05
  It will hold additional functions to support HTML display of notes
  and printing of HTML notes.                                           *)

interface

  uses Windows, SysUtils, Classes, Printers, ComCtrls,
       ShDocVw, {//kt added ShDocVw 5-2-05 for TWebBrowser access}
       Dialogs,
       Forms,
       Registry, {elh   6/19/09}
       ORFn;    {//kt for RedrawActivate}

  var
    DesiredHTMLFontSize : byte;       
     
  procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string; 
                            PtName, DOB, VisitDate, Location:string; Application : TApplication);  //kt added 5-2-05
  function  IsHTML(Lines : TStrings): boolean; overload;
  function  IsHTML(Line : String): boolean; overload;
  function  HasHTMLTags(Text: string) : boolean;
  procedure FixHTML(Lines : TStrings); 
  function  FixHTMLCRLF(Text : String) : string;
  procedure SplitToArray (HTMLText: string; Lines : TStrings);
  procedure StripBeforeAfterHTML(Lines,OutBefore,OutAfter : TStrings);
  function  UnwrapHTML(HTMLText : string) : string; 
  function  WrapHTML(HTMLText : string) : string; 
//  function  WaitForBrowserOK(MaxSecDelay: integer; Application : TApplication) : boolean;
  function  CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
  function  ProtectHTMLSpaces(Text : String) : string;
  function  Text2HTML(Lines : TStrings) : String; overload;
  function  Text2HTML(text : string) : String;    overload;
  procedure SetRegHTMLFontSize(Size: byte);
  procedure RestoreRegHTMLFontSize;
  procedure SetupHTMLPrinting(Name,DOB,VisitDate,Location,Institution : string);
  procedure RestoreIEPrinting;
  function ExtractDateOfNote(Lines : TStringList) : string;
  Procedure ScanForSubs(Lines : TStrings);

implementation

  uses fNotes,
       fImages,
       Messages,
       Graphics, //For color constants
       fTMGPrintingAnimation,
       ExtCtrls,
       uTemplateFields,
       fTemplateDialog,
       StrUtils; 

  type
    TPrinterEvents = class
    public
      SavedDefaultPrinter : string;
      LastChosenPrinterName : string;
      RestorePrinterTimer : TTimer;       
      PrintingNow : boolean;
      procedure HandleRestorePrinting (Sender: TObject);
      Constructor Create;
      Destructor Destroy; override;
    end;  
   
  var
    PrinterEvents : TPrinterEvents;

  const CRLF = #$0D#$0A;

  
  function GetCurrentPrinterName : string;
   //var ResStr: array[0..255] of Char;
  begin
  //GetProfileString('Windows', 'device', '', ResStr, 255);
  //Result := StrPas(ResStr);
    if (Printer.PrinterIndex > 0)then begin
      Result := Printer.Printers[Printer.PrinterIndex];
    end else begin
      Result := '';
    end;
  end;

  procedure SetDefaultPrinter(PrinterName: String) ;
  var
      j                    : Integer;
      Device, Driver, Port : PChar;
      HdeviceMode          : THandle;
      aPrinter             : TPrinter;
  begin    
     Printer.PrinterIndex := -1;
     getmem(Device, 255) ;
     getmem(Driver, 255) ;
     getmem(Port, 255) ;
     aPrinter := TPrinter.create;
     j := Printer.Printers.IndexOf(PrinterName);
     if j >= 0 then begin
       aprinter.printerindex := j;
       aPrinter.getprinter(device, driver, port, HdeviceMode) ;
       StrCat(Device, ',') ;
       StrCat(Device, Driver ) ;
       StrCat(Device, Port ) ;
       WriteProfileString('windows', 'device', Device) ;
       StrCopy( Device, 'windows' ) ;
       //SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@Device)) ;
     end;
     Freemem(Device, 255) ;
     Freemem(Driver, 255) ;
     Freemem(Port, 255) ;
     aPrinter.Free;
  end;    


  procedure Wait(Sec : byte; Application : TApplication);
  var   StartTime : TDateTime; 
  const OneSec = 0.000012;  
  begin
    StartTime := GetTime; 
    repeat
      Application.ProcessMessages;
    until (GetTime-StartTime) > (OneSec*Sec);
  end;

  
  procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string; 
                            PtName, DOB, VisitDate, Location:string;
                            Application : TApplication);
  //      Web browser printing options:
  //        OLECMDEXECOPT_DODEFAULT       Use the default behavior, whether prompting the user for input or not.
  //        OLECMDEXECOPT_PROMPTUSER      Execute the command after obtaining user input.
  //        OLECMDEXECOPT_DONTPROMPTUSER  Execute the command without prompting the user.

  {Notice:  When IE is asked to print, it immediately returns from the function,
           but the printing has not yet occured.  If UI is requested, then the
          printing will not start until after the user selects a printer and
         presses [OK].  I could not find any reliable way to determine when the
        print job had been created.  I had to know this event because I need to
       restore some IE settings AFTER the printing has finished.  I even tried to
      get the active windows and see if it was a print dialog.  But IE print dlg
     apparently is owned by another thread than CPRS, because GetActiveWindow would
     not bring back a handle to the printer dialog window.  I therefore told IE
     to print WITHOUT asking which printer via UI.  In that case it prints to the
     system wide default printer.  So I have to set the default printer to the 
     user's choice, and then change it back again.  This is bit of a kludge,
     but I couldn't figure out any other way after hours of trial and error.
     NOTE: I tried to query IE to see if it was able to print, thinking that it
     would return NO if in the process of currently printing.  It didn't work, 
     and would return OK immediately.      
     
     ADDENDUM:  I was getting errors and inconsistent behavior with this, so I
       have decided to try to let the user click a button when the printer has
       been selected.                                         }    
  
  var
    UseUI          : OleVariant;   
    //NewPrinterName : string;    
    //dlgWinPrinter  : TPrintDialog;
  begin
    //if PrinterEvents.RestorePrinterTimer.Enabled = false then begin
    //  PrinterEvents.SavedDefaultPrinter := GetCurrentPrinterName;
    //end;  
    if PrinterEvents.PrintingNow then exit; // prevent double printing (it has happened)

    try
      rHTMLTools.ScanForSubs(Lines);    //Added to correct Printing issue  elh
      frmNotes.SetDisplayToHTMLvsText([vmView,vmHTML],Lines);  //ActivateHtmlViewer(Lines);
      if frmNotes.HtmlViewer.WaitForDocComplete = false then begin
        ErrMsg := 'The web browser timed out trying to set up document.';
        exit;
      end;
      PrinterEvents.PrintingNow := true;
      SetupHTMLPrinting(PtName,DOB,VisitDate,Location,' ');  {elh 6/19/09} //kt
      frmNotes.HtmlViewer.PrintFinished := false;               
      UseUI := true;
      frmNotes.HtmlViewer.PrintDocument(UseUI);   //Returns immediately, not after printing done.
      frmTMGPrinting.ShowModal;    // Let user show when print job has been launched.
      PrinterEvents.RestorePrinterTimer.Enabled := true; //launch a restore event in 30 seconds
      //RestoreIEPrinting;  //elh - This was omitted from below. Not sure why.  11/10/09
    finally  
      PrinterEvents.PrintingNow := false;
    end;
  end;

(*
  Safe copy of above.  Delete later...
    
  procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string; 
                            PtName, DOB, Location:string;
                            Application : TApplication);
  //      Web browser printing options:
  //        OLECMDEXECOPT_DODEFAULT       Use the default behavior, whether prompting the user for input or not.
  //        OLECMDEXECOPT_PROMPTUSER      Execute the command after obtaining user input.
  //        OLECMDEXECOPT_DONTPROMPTUSER  Execute the command without prompting the user.

  {Notice:  When IE is asked to print, it immediately returns from the function,
           but the printing has not yet occured.  If UI is requested, then the
          printing will not start until after the user selects a printer and
         presses [OK].  I could not find any reliable way to determine when the
        print job had been created.  I had to know this event because I need to
       restore some IE settings AFTER the printing has finished.  I even tried to
      get the active windows and see if it was a print dialog.  But IE print dlg
     apparently is owned by another thread than CPRS, because GetActiveWindow would
     not bring back a handle to the printer dialog window.  I therefore told IE
     to print WITHOUT asking which printer via UI.  In that case it prints to the
     system wide default printer.  So I have to set the default printer to the 
     user's choice, and then change it back again.  This is bit of a kludge,
     but I couldn't figure out any other way after hours of trial and error.
     NOTE: I tried to query IE to see if it was able to print, thinking that it
     would return NO if in the process of currently printing.  It didn't work, 
     and would return OK immediately.                                               }    
  


  var
    UseUI          : OleVariant;   
    NewPrinterName : string;    
    dlgWinPrinter  : TPrintDialog;
  begin
    if PrinterEvents.RestorePrinterTimer.Enabled = false then begin
      PrinterEvents.SavedDefaultPrinter := GetCurrentPrinterName;
    end;  
    dlgWinPrinter := TPrintDialog.Create(nil);
    frmTMGPrinting.Show;
    //FIX: get printer name for the one used last time somehow...
    if dlgWinPrinter.Execute then begin  //only sets a local printer
      NewPrinterName := GetCurrentPrinterName;  
      SetDefaultPrinter(NewPrinterName); //Set global setting that IE will use.
      PrinterEvents.LastChosenPrinterName := NewPrinterName;
      try
        frmNotes.SetDisplayToHTMLvsText([vmView,vmHTML],Lines);  //ActivateHtmlViewer(Lines);
        if frmNotes.HtmlViewer.WaitForDocComplete = false then begin
          ErrMsg := 'The web browser timed out trying to set up document.';
          exit;
        end;
        SetupHTMLPrinting(PtName,DOB,Location,' ');  {elh 6/19/09} //kt
        frmNotes.HtmlViewer.PrintFinished := false;               
        UseUI := false;  //UseUI := true;
        frmNotes.HtmlViewer.PrintDocument(UseUI);   //Returns immediately, not after printing done.
        PrinterEvents.RestorePrinterTimer.Enabled := true; //launch a restore event in 30 seconds
        Wait(4,Application); 
        //WaitForBrowserOK(10, Application); //wait up to 10 seconds  //Note: this doesn't do what I want.  Status is immediately OK.
        //RestoreIEPrinting;   {elh 6/19/09}  //kt
      finally   //any needed final code goes here.
        //SetDefaultPrinter(DefaultPrinter);
        //beep;
      end;
    end;
    dlgWinPrinter.Free;
    frmTMGPrinting.Hide;        
  end;
*)  
  (*
  function WaitForBrowserOK(MaxSecDelay: integer; Application : TApplication) : boolean;
  //Returns TRUE if can print
  var
    StartTime : TDateTime; 
    Status: OLECMDF;
    MaxDelay,ElapsedTime : Double;
    CanPrint : boolean;
  const
    OneMin = 0.0007;  //note: 0.0007 is about 1 minute
  begin
    StartTime := GetTime; 
    MaxDelay := OneMin * MaxSecDelay;
    repeat
      Status := frmNotes.HtmlViewer.QueryStatusWB(OLECMDID_PRINT);  //"can you print?" -- get print command status
      CanPrint := (Status and OLECMDF_ENABLED) > 0;
      ElapsedTime := GetTime-StartTime;
      Application.ProcessMessages;
    until (ElapsedTime > MaxDelay) or CanPrint or frmNotes.HtmlViewer.PrintFinished;
    Result := CanPrint;
  end;
  *)
  
  Procedure ScanForSubs(Lines : TStrings);
  //Purpose: To scan note for constant $CPRS$ and replace with CPRS's actual directory
  var i : integer;
      CPRSDir : string;
  begin
    for i := 0 to Lines.Count-1 do begin
      if Pos('$CPRSDIR$',Lines.Strings[i])>0 then begin
        CPRSDir := ExcludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));
        Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],'$CPRSDIR$',CPRSDir);
        //Ensure images are downloaded before passing page to web browser        
        frmImages.timLoadImagesTimer(nil);
        //NOTE: This often doesn't get the job completed before passing to browser
        //      ?? check for completion?
      end;
    end;
  end;


  function IsHTML(Line : String): boolean;
  {Purpose: To look at the Text and determine if it is an HTML document.
   Test used: if document contains <!DOCTYPE HTML" or <HTML> or </BODY> or other tags
        This is not a fool-proof test...                                   
   NOTE: **This does NOT call ScanForSubs as the other IsHTML(TStrings) function does.     }

  begin
    Result := false;  //default of false
    Line := UpperCase(Line);
    if (Pos('<!DOCTYPE HTML',Line) > 0) 
      or (Pos('<HTML>',Line) > 0)
      or (Pos('<BR>',Line) > 0)
      or (Pos(HTML_BEGIN_TAG,Line) > 0)
      or (Pos('<P>',Line) > 0)
      or (Pos('&NBSP',Line) > 0)
      or (Pos('</BODY>',Line) > 0)then begin
      Result := true;
    end;
  end;

  
  function IsHTML(Lines : TStrings): boolean;
  //Purpose: To look at the note loaded into Lines and determine if it is
  //          an HTML document.  See other IsHTML(String) function for test used.
  begin
    Result := false;  
    if Lines = nil then exit;
    Result := IsHTML(Lines.Text);
    if Result = true then ScanForSubs(Lines);  
  end;

  
  function HasHTMLTags(Text: string) : boolean;
    function GetTag(p1,p2 : integer; var Text : string) : string;
    var i : integer;
    begin
      Result := MidStr(Text,p1, p2-p1);
      if Result[1] = '/' then Result := MidStr(Result,2,999);
      i := Pos(' ',Result);
      if i >0 then Result := MidStr(Result,1,i-1);
    end;
    
  var p1,p2: integer;
      Tag : string;
  begin
    Result := False; //default to ignore
    Text := UpperCase(Text);
    if (Pos('&NBSP;',Text)>0) then Result := true
    else if (Pos('<P>',Text)>0) then Result := true
    else if (Pos('<BR>',Text)>0) then Result := true
    else if (Pos('<HTML>',Text)>0) then Result := true
    else begin
      p1 := Pos('<',Text); if p1 = 0 then exit;
      p2 := Pos('>',Text); if p2 = 0 then exit;
      Tag := GetTag(p1,p2,Text);
      if Tag='' then exit;
      if Pos('/'+Tag+'>',Text)>0 then result := true;      
    end;
    {
    if (Pos('<BR>',Text)>0) or
       (Pos('</P>',Text)>0) or
       (Pos('<UL>',Text)>0) or
       (Pos('</UL>',Text)>0) or
       (Pos('<LI>',Text)>0) or
       (Pos('</LI>',Text)>0) or
       (Pos('<OL>',Text)>0) or
       (Pos('</OL>',Text)>0) or
       (Pos('&NBSP;',Text)>0) or
       (Pos('<P>',Text)>0) then begin
      Result := true;
    end;            
    }
  end;
    
  
  function LineAfterTag(Lines : TStrings; Tag : string) : integer;
  //returns index of line directly after tag (-1 if not found)
  //Note: only 1st tag is found (stops looking after that)
  var p,i : integer;
      s,s1,s2 : string;
  begin
    result := -1;  
    Tag := UpperCase(Tag);
    for i := 0 to Lines.Count-1 do begin
      s := UpperCase(Lines.Strings[i]);
      p := Pos(Tag,s);
      if p=0 then continue;
      if (p+length(Tag)-1) < length(s) then begin  //extra stuff after tag on line --> split line
        s1 := MidStr(Lines.Strings[i],1,p+length(Tag)-1);
        s2 := MidStr(Lines.Strings[i],p+length(Tag),9999);
        Lines.Strings[i] := s1;
        Lines.Insert(i+1,s2);            
      end;
      //Lines.Insert(i+1,'');    
      result := i+1;
      break;
    end;
  end;

  function LineBeforeTag(Lines : TStrings; Tag : string) : integer;
  //returns index of newly added blank line, directly before tag (-1 if not found)
  //Note: only 1st tag is found (stops looking after that)
  var p,i,idx : integer;
      s,s1,s2 : string;
  begin
    result := -1;  
    idx := -1;
    Tag := UpperCase(Tag);
    for i := 0 to Lines.Count-1 do begin
      s := UpperCase(Lines.Strings[i]);
      p := Pos(Tag,s);
      if p>0 then begin
        idx := i;
        break;
      end;  
    end;  
    if idx <> -1 then begin
      p := Pos(Tag,UpperCase(Lines.Strings[idx]));
      if p>1 then begin  //extra stuff after tag on line --> split line
        s1 := MidStr(Lines.Strings[idx],1,p-1);
        s2 := MidStr(Lines.Strings[idx],p,9999);
        Lines.Strings[idx] := s1;
        Lines.Insert(idx+1,s2);
        inc(idx);
      end;
      //Lines.Insert(idx-1,'');    
      result := idx;
    end;
  end;

  procedure SplitLineAfterTag(Lines : TStrings; Tag : string);
  //Purpose: To ensure that text that occurs after Tag is split and wrapped
  //         to the next line.
  //Note: It is assumed that tag is in form of <TAGName> or <SomeReallyLongText...
  //      if a closing '>' is not provided in the tag name, then the part provided
  //      is used for matching, and then a search for the closing '>' is made, and
  //      the split will occur after that.
  //Note: Only the first instance of Tag will be found, stops searching after that.
  //Note: Tag beginning and ending MUST occur on same line (wrapping of a long tag NOT supported)
  var i,p1,p2 : integer;
      s,s1,s2 : string;
  begin
    Tag := UpperCase(Tag);
    for i := 0 to Lines.Count-1 do begin
      s := UpperCase(Lines.Strings[i]);
      p1 := Pos(Tag,s);    
      if p1=0 then continue;
      p2 := PosEx('>',s,p1);
      if p2=0 then continue;  //this is a problem, no closing '>' found... ignore for now.
      if p2 = length(s) then break;
      s1 := MidStr(Lines.Strings[i],1,p2);
      S2 := MidStr(Lines.Strings[i],p2+1,999);
      Lines.Strings[i] := s1;
      Lines.Insert(i+1,s2);
      break;    
    end;
  end;

  procedure SplitLineBeforeTag(Lines : TStrings; Tag : string);
  //Purpose: To ensure that text that occurs before Tag is split and Tag
  //         is wrapped to the next line.
  //Note: It is assumed that tag is in form of <TAGName> or <SomeReallyLongText...
  //Note: Only the first instance of Tag will be found, stops searching after that.
  var i,p1 : integer;
      s1,s2 : string;
  begin
    Tag := UpperCase(Tag);
    for i := 0 to Lines.Count-1 do begin
      p1 := Pos(Tag,UpperCase(Lines.Strings[i]));    
      if p1=0 then continue;
      s1 := MidStr(Lines.Strings[i],1,p1-1);
      S2 := MidStr(Lines.Strings[i],p1,999);
      Lines.Strings[i] := s1;
      Lines.Insert(i+1,s2);
      break;    
    end;
  end;

  function IndexOfHoldingLine(Lines : TStrings; Tag : string) : integer;
  var i : integer;
      s : string;
  begin
    result := -1;  
    Tag := UpperCase(Tag);
    for i := 0 to Lines.Count-1 do begin
      s := UpperCase(Lines.Strings[i]);
      if Pos (Tag,s)=0 then continue;
      result := i;
      break;
    end;
  end; 

  procedure EnsureTrailingBR(Lines : TStrings);
  var  p,i : integer;
  begin
    for i := 0 to Lines.Count-1 do begin   //Ensure each line ends with <BR>
      p := Pos('<BR>',Lines.Strings[i]);
      if p+3=length(Lines.Strings[i]) then continue;
      Lines.Strings[i] := Lines.Strings[i] + '<BR>';          
    end;
  end;

  procedure MergeLines(Lines,BeforeLines,AfterLines : TStrings);
  var  i : integer;
       Result : TStringList;
  begin
    Result := TStringList.Create;
    SplitLineAfterTag(Lines,'<!DOCTYPE HTML');
    SplitLineBeforeTag(Lines,'</BODY>');
    Result.Add(Lines.Strings[0]);  //Should be line with <!DOCTYPE HTML...
    for i := 0 to BeforeLines.Count-1 do begin  //Add Before-Lines text
      Result.Add(BeforeLines.Strings[i]);
    end;
    for i := 1 to Lines.Count-2 do begin  //Add back regular lines text
      Result.Add(Lines.Strings[i]);
    end;
    for i := 1 to AfterLines.Count-1 do begin //Add After-Lines text
      Result.Add(AfterLines.Strings[i]);
    end;
    Result.Add(Lines.Strings[Lines.count-1]); //Should be '</BODY></HTML>' line

    Lines.Assign(Result);  
  end;

  procedure StripBeforeAfterHTML(Lines,OutBefore,OutAfter : TStrings);
  //Purpose: Strip all text that comes before <!DOCTYPE ... line and store in OutBefore;
  //         Strip all text that comes after </HTML> ... line and store in OutAfter;           
  var i : integer;
      DocTypeLine,EndHTMLLine: integer;
  begin
    OutBefore.Clear;
    OutAfter.Clear;
    DocTypeLine := IndexOfHoldingLine(Lines,'<!DOCTYPE HTML');
    if DocTypeLine>1 then begin
      for i := 0 to DocTypeLine-1 do OutBefore.Add(Lines.Strings[i]);
      for i := 0 to DocTypeLine-1 do Lines.Delete(0);
    end;
    EndHTMLLine := IndexOfHoldingLine(Lines,'</HTML>');
    if (EndHTMLLine>0) and (EndHTMLLine < (Lines.Count-1)) then begin
      for i := EndHTMLLine+1 to Lines.Count-1 do OutAfter.Add(Lines.Strings[i]);
      for i := EndHTMLLine+1 to Lines.Count-1 do Lines.Delete(EndHTMLLine+1);
    end;
  end;

  Function FixHTMLCRLF(Text : String) : string;
  begin
    Result := AnsiReplaceText(Text,'<NO DATA>',#$1E); //protect sequences we want
    Result := AnsiReplaceText(Result,'>'+CRLF,'>'#$1F); //protect sequences we want
    Result := AnsiReplaceText(Result,CRLF,'<BR>'+CRLF); //Add <BR>'s to CrLf's
    Result := AnsiReplaceText(Result,'>'#$1F,'><BR>'+CRLF); //Restore sequences we wanted
    Result := AnsiReplaceText(Result,#$1E,'<NO DATA>'); //Restore sequences we wanted
  end;
  

  procedure FixHTML(Lines : TStrings); //kt 6/20/09
  //Purpose: to put header info that VistA adds to note into proper formatting.  
  var  BeforeLines,AfterLines : TStringList;
  begin
    BeforeLines := TStringList.Create;
    AfterLines := TStringList.Create;
    StripBeforeAfterHTML(Lines,BeforeLines,AfterLines);
    EnsureTrailingBR(BeforeLines);
    if BeforeLines.Count>0 then begin  //Wrap Before-Lines with formatting
      BeforeLines.Insert(0,'<CODE>'); 
      //<---Existing text remains in between --->
      BeforeLines.Add('</CODE>');  
      BeforeLines.Add('<HR><P>');  //horizontal line
    end;
    EnsureTrailingBR(AfterLines);  
    if AfterLines.Count > 0 then begin  //Wrap After-Lines with formatting
      AfterLines.Insert(0,'<P><CODE>'); 
      //<---Existing text remains in between --->
      AfterLines.Add('</CODE>');  
    end;
    MergeLines(Lines,BeforeLines,AfterLines);    
    BeforeLines.Free;
    AfterLines.Free;
  end;
  
  procedure SplitToArray (HTMLText: string; Lines : TStrings);
  var tempS                 : string;
    InEscapeCode, InTagCode : boolean;
    i, LastGoodBreakI       : integer;
    TagStart,TagEnd         : integer;
    TagText                 : string;
    TextLen                 : integer;
    MaxLineLen              : integer;
  begin
    Lines.Clear;
    MaxLineLen := 80;
    Repeat
      InEscapeCode := False;
      InTagCode := False;
      LastGoodBreakI := 0;
      TextLen := length(HTMLText);
      TagText := '';
      TagStart := 0; TagEnd := 0;
      if TextLen > 80 then TextLen := MaxLineLen;
      for i := 1 to TextLen do begin
        if (HTMLText[i] = '<') then begin
          InTagCode := True;
          TagStart := i;
          TagText := '';
          LastGoodBreakI := i-1;
        end;
        if (HTMLText[i] = '&') then begin
          InEscapeCode := True;
          LastGoodBreakI := i-1;
        end;
        if InEscapeCode and (HTMLText[i] = ';') then begin   
          InEscapeCode := False;
          LastGoodBreakI := i;
        end;
        if InTagCode and (HTMLText[i] = '>') then begin   
          InTagCode := False;
          TagEnd := i;
          TagText := UpperCase(MidStr(HTMLText,TagStart+1,(TagEnd-TagStart-1)));
          LastGoodBreakI := i;
        end;
        if (HTMLText[i] = ',') and (MaxLineLen > 80) then begin   
          LastGoodBreakI := i;        
          break;
        end;
        if (TagText='BR') or (TagText='/P') then begin
          LastGoodBreakI := TagEnd;
          break;
        end else TagText := '';;  
        if (not InTagCode) and (not InEscapeCode) 
        and (HTMLText[i] = ' ') then LastGoodBreakI  := i;
      end;    
      if LastGoodBreakI > 0 then begin
        tempS := MidStr(HTMLText,1,LastGoodBreakI);   //get next 80 chars, or less if at the end.
        HTMLText := Rightstr(HTMLText, length(HTMLText)- LastGoodBreakI);    //characters 81 ... the end
        Lines.Add(tempS);      
      end else begin
        if MaxLineLen < 250 then begin
          MaxLineLen := 250; //emergency mode      
        end else begin  //i.e. couldn't find any break within 250 chars. So just chop off.
          tempS := MidStr(HTMLText,1,80);   
          HTMLText := Rightstr(HTMLText, length(HTMLText)- 80);    //characters 81 ... the end
          Lines.Add(tempS);      
        end;  
      end;  
    until length(HTMLText)=0;
   end;      
  

  function WrapHTML(HTMLText : string) : string; //kt 6/3/09
  //Purpose: take HTML formatted text and sure it has proper headers and footers etc.
  //         i.e. 'wrap' partial HTML into formal format.
  begin
    if Pos('<BODY>',HTMLText)=0 then HTMLText := '<BODY>' + HTMLText;    
    if Pos('</BODY>',HTMLText)=0 then HTMLText :=  HTMLText + '</BODY>';      
    if Pos('<HTML>',HTMLText)=0 then HTMLText := '<HTML>' + HTMLText;    
    if Pos('</HTML>',HTMLText)=0 then HTMLText :=  HTMLText + '</HTML>';      
    if Pos('<!DOCTYPE HTML',HTMLText)=0 then begin    
      HTMLText := '<!DOCTYPE HTML PUBLIC "-//WC3//DTD HTML 3.2//EN">'+ #10#13 + HTMLText;
    end;
    result := HTMLText;
  end;

  function UnwrapHTML(HTMLText : string) : string; 
  //Purpose: take HTML formatted text and remove proper headers and footers etc.
  //         i.e. 'unwrap' formal HTML into partial HTML format.
  begin
    HTMLText := piece(HTMLText,'<HTML>',2);
    HTMLText := piece(HTMLText,'</HTML>',1);
    HTMLText := piece(HTMLText,'<BODY>',2);
    HTMLText := piece(HTMLText,'</BODY>',1);
    result := HTMLText;
  end;

  function CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
  {Purpose:  To scan memNote memo for a link to an image.  If found, return link(s)
   input:  none:
   output:  Will return a string list holding 1 or more links
   Notes:  Here will be the <img ..  > format scanned for:

        Here is some opening text...
          <img src="http://www.geocities.com/kdtop3/OpenVistA.jpg" alt="Image Title 1">
        And here is some more text
          <img src="http://www.geocities.com/kdtop3/OpenVistA_small.jpg" alt="Image Title 2">
        And the saga continues...
          <img src="http://www.geocities.com/kdtop3/pics/Image100.gif" alt="Image Title 3">
           As with html, end-of-lines and white space is not preserved or significant
  }

    function GetBetween (var Text : AnsiString; OpenTag,CloseTag : string;
                         KeepTags : Boolean) : string;
    {Purpose: Gets text between Open and Close tags.  Removes any CR's or LF's
     Input: Text - the text to work on.  It IS changed as code is removed
            KeepTags - true if want tag return in result
                       false if tag not in result (still is removed from Text)
     Output: Text is changed.
             Result=the code between the opening and closing tags
     Note: Both OpenTag and CloseTag MUST be present for anything to happen.
    }

      procedure CutInThree(var Text : AnsiString; p1, p2 : Integer; var s1,s2,s3 : AnsiString);
      {Purpose: Cut input string Text into 3 parts, with cut points given by p1 & p2.
                p1 points to first character to be in s2
                p2 points to last character to be in s2        }
      begin
        s1 := ''; s2 := '';  s3 := '';
        if p1 > 1 then s1 := MidStr(Text, 1, p1-1);
        s2 := MidStr(Text, p1, p2-p1+1);
        s3 := MidStr(Text, p2+1, Length(Text)-p2);
      end;

    var
      p1,p2 : integer;
      s1,s2,s3 : AnsiString;

    begin
      Result := ''; //default of no result.

      p1 := Pos(UpperCase(OpenTag), UpperCase(Text));
      if (p1 > 0) then begin
        p2 := Pos(UpperCase(CloseTag),UpperCase(Text)) + Length(CloseTag) -1;
        if ((p2 > 0) and (p2 > p1)) then begin
          CutInThree (Text, p1,p2, s1,Result,s3);
          Text := s1+s3;
          //Now, remove any CR's or LF's
          repeat
            p1 := Pos (Chr(13),Result);
            if p1= 0 then p1 := Pos (Chr(10),Result);
            if (p1 > 0) then begin
              CutInThree (Result, p1,p1, s1,s2,s3);
              Result := s1+s3;
  //            Text := MidStr(Text,1,p1-1) + MidStr(Text,p1+1,Length(Text)-p1);
            end;
          until (p1=0);
          //Now cut off boundry tags if requested.
          if not KeepTags then begin
            p1 := Length(OpenTag) + 1;
            p2 := Length (Result) - Length (CloseTag);
            CutInThree (Result, p1,p2, s1,s2,s3);
            Result := s2;
          end;
        end;
      end;
    end;

  var
    Text : AnsiString;
    LineStr : string;

  begin
    Result := false;  //set default
    if (ImageList = nil) or (Lines = nil) then exit;
    ImageList.Clear;  //set default
    Text := Lines.Text;  //Get entire note into one long string
    repeat
      LineStr := GetBetween (Text, '<img', '>', true);
      if LineStr <> '' then begin
        ImageList.Add(LineStr);
        Result := true;
      end;
    until LineStr = '';
    //Note: The following works, but need to replace removed links
    // with "[Title]"   Work on later...
    //memNote.Lines.Text := Text;
  end;

  function ProtectHTMLSpaces(Text : String) : string;
  begin
    Result := AnsiReplaceStr(Text, #9, '&nbsp;&nbsp;&nbsp;&nbsp; ');
    while Pos('  ',Result)>0 do begin //preserve whitespace
        Result := AnsiReplaceStr(Result, '  ', '&nbsp;&nbsp;');    
    end;
  end;

  function  Text2HTML(Lines : TStrings) : String;
  //Purpose: Take plain text, and prep for viewing in HTML viewer.
  //i.e. convert TABs into &nbsp's and add <br> at end of line etc.  
  var i : integer;
      tempS : string;
  begin
    for i := 0 to Lines.Count-1 do begin
      tempS := TrimRight(Lines.Strings[i]);
      if i = Lines.Count-1 then tempS := tempS + '<P>'
      else tempS := tempS + '<BR>';
      Lines.Strings[i] := tempS;
    end;        
    Result := ProtectHTMLSpaces(Lines.Text)
  end;

  function Text2HTML(text : string) : String;    overload;
  var Lines : TStringList;
  begin
    Lines := TStringList.create;
    Lines.Text := text;
    Result := Text2HTML(Lines);
    Lines.Free;
  end;

  type
    TFontSizeData = record
      case byte of 1: (Data : array[0..3] of byte);
                   2: (Size : byte; Filler : array[1..3] of byte);
    end;    
    
  var
    StoredFontSize : TFontSizeData;
    FontSizeReg:     TRegistry;
  
  procedure SetRegHTMLFontSize(Size: byte);
  //Purpose: To set the internet explorer Font Size value via the registry.
  //Expected input: HTML_SMALLEST, HTML_SMALL, HTML_MEDIUM,HTML_LARGE, HTML_LARGEST
  //         Value should be 0 (smallest) - 4 (largest)
  const  HTML_BLANK : TFontSizeData =(Data: (0,0,0,0));
  var  Value : TFontSizeData;

  begin
    if Size > 4 then Size := 4;
    Value := HTML_BLANK; Value.Size := Size;
    FontSizeReg := TRegistry.Create;  //To be freed in RestoreRegHTMLFontSize
    try
      FontSizeReg.Rootkey := HKEY_CURRENT_USER;
      if FontSizeReg.OpenKey('\Software\Microsoft\Internet Explorer\International\Scripts\3', False) then begin
        FontSizeReg.ReadBinaryData('IEFontSize',StoredFontSize,Sizeof(StoredFontSize));
        FontSizeReg.WriteBinaryData('IEFontSize',Value,SizeOf(Value));
      end;
    finally
    end;
  end;

  procedure RestoreRegHTMLFontSize;
  //Purpose: To restore the Internet Explorer zoom value to a stored value..
  //elh 6/19/09
  begin
    if not assigned(FontSizeReg) then FontSizeReg := TRegistry.Create;
    try
      FontSizeReg.WriteBinaryData('IEFontSize',StoredFontSize,SizeOf(StoredFontSize));
    finally
      FontSizeReg.Free;
    end;
  end;

  var
    StoredIEHeader, StoredIEFooters : string;
    Reg : TRegistry;
   
  procedure SetupHTMLPrinting(Name,DOB,VisitDate,Location,Institution : string);
  //Purpose: To open the IE header and footer registry keys, save the
  //current value and then replace with passed patient data.   elh 6/19/09
  //NOTE: There does not seem to be any other way to do this programatically.
  var NewHeader,NewFooter : string;
  begin
    if DesiredHTMLFontSize > 0 then begin
      SetRegHTMLFontSize(DesiredHTMLFontSize-1);   //Downsize by 1 step
    end;  
    NewHeader := Location + ' &b ' + Institution + ' &b Printed: &d &t';
    NewFooter := Name + ' (' + DOB + ') &b Note: ' + VisitDate + ' &b &p of &P';
    Reg := TRegistry.Create;  //to be freed in RestoreIEPrinting
    try
      Reg.Rootkey := HKEY_CURRENT_USER;
      if Reg.OpenKey('\Software\Microsoft\Internet Explorer\PageSetup', False) then begin
        StoredIEFooters := Reg.ReadString('footer');
        StoredIEHeader := Reg.ReadString('header');
        Reg.WriteString('header',NewHeader);
        Reg.WriteString('footer',NewFooter);
      end;
    finally 
    end;
  end;

  procedure RestoreIEPrinting;
  //Purpose: To restore the IE header and footer registry with the initial value
  //NOTE: The below function was used to restore the previous value to the registry
  //       but got commented above, so the registry retained the patient's data
  //       to resolve this, we are now setting this to a default value.
  //elh 6/19/09
  begin
    if not assigned(Reg) then Reg := TRegistry.Create;
    try
      StoredIEFooters := '&u&b&d';          //Comment this line to restore previous value
      StoredIEHeader := '&d&b&t&bPage &p of &P';  //Comment this line to restore previous value
      Reg.WriteString('footer',StoredIEFooters);
      Reg.WriteString('header',StoredIEHeader);
      RestoreRegHTMLFontSize; 
    finally
      Reg.Free;
    end;
  end;

  function ExtractDateOfNote(Lines : TStringList) : string;
  //Scan note and return date found after 'DATE OF NOTE:', if present.
  var i,p : integer;
      s : string;
  begin
    Result := '';
    if Lines = nil then exit;
    for i := 0 to Lines.Count-1 do begin
      p := Pos('DATE OF NOTE:',Lines.Strings[i]);
      if p<1 then continue;
      s := Piece(Lines.Strings[i],'DATE OF NOTE:',2);
      s := Piece(s,'@',1);
      Result := Trim(s);      
    end;
  end;

  //===============================================================

  Constructor TPrinterEvents.Create;
  begin
    RestorePrinterTimer := TTimer.Create(frmNotes);
    RestorePrinterTimer.Enabled := false;
    RestorePrinterTimer.Interval := 30000; //30 seconds to complete print job.
    RestorePrinterTimer.OnTimer := HandleRestorePrinting;
    PrintingNow := false;
  end;
  
  Destructor TPrinterEvents.Destroy;
  begin
    RestorePrinterTimer.Free;    
    inherited Destroy;
  end;


  procedure TPrinterEvents.HandleRestorePrinting (Sender: TObject);
  begin
    if PrinterEvents.PrintingNow then begin
      RestorePrinterTimer.Enabled := true; // reset timer for later.
      exit;
    end;
    RestorePrinterTimer.Enabled := false;
    RestoreIEPrinting;   {elh 6/19/09}  //kt
    //kt SetDefaultPrinter(SavedDefaultPrinter);   
    //beep;    
  end;  

  //===============================================================
  

initialization
  DesiredHTMLFontSize := 2; //probably overwritten in fNotes initialization
  PrinterEvents := TPrinterEvents.Create;  

finalization
  PrinterEvents.Free;   
end.