Ignore:
Timestamp:
Aug 12, 2009, 7:14:16 PM (15 years ago)
Author:
Kevin Toppenberg
Message:

TMG Ver 1.1 Added HTML Support, better demographics editing

File:
1 edited

Legend:

Unmodified
Added
Removed

  • cprs/branches/tmg-cprs/CPRS-Chart/rHTMLTools.pas

    r453 r541  
    11unit rHTMLTools;
    2 (*
    3   This entire unit was created by K. Toppenberg, starting on 5/27/05
     2(*This entire unit was created by K. Toppenberg, starting on 5/27/05
    43  It will hold additional functions to support HTML display of notes
    5   and printing of HTML notes.
    6 *)
     4  and printing of HTML notes.                                           *)
    75
    86interface
    97
    10 uses Windows, SysUtils, Classes, Printers, ComCtrls,
    11      ShDocVw, {//kt added ShDocVw 5-2-05 for TWebBrowser access}
    12      ORFn;    {//kt for RedrawActivate}
    13 
    14 procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string);  //kt added 5-2-05
    15 function IsHTMLDocument(Lines : TStrings): boolean;  //kt added 5-2-05
    16 procedure WaitForBrowserOK(MaxSecDelay: integer);
    17 procedure ActivateWebBrowser;
    18 procedure ActivateMemo;
    19 function CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
    20 
     8  uses Windows, SysUtils, Classes, Printers, ComCtrls,
     9       ShDocVw, {//kt added ShDocVw 5-2-05 for TWebBrowser access}
     10       Dialogs,
     11       Forms,
     12       Registry, {elh   6/19/09}
     13       ORFn;    {//kt for RedrawActivate}
     14
     15  var
     16    DesiredHTMLFontSize : byte;       
     17     
     18  procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string; PtName:string;
     19                            DOB:string; Location:string; Application : TApplication);  //kt added 5-2-05
     20  function  IsHTML(Lines : TStrings): boolean; overload;
     21  function  IsHTML(Line : String): boolean; overload;
     22  function  HasHTMLTags(Text: string) : boolean;
     23  procedure FixHTML(Lines : TStrings);
     24  function  FixHTMLCRLF(Text : String) : string;
     25  procedure SplitToArray (HTMLText: string; Lines : TStrings);
     26  procedure StripBeforeAfterHTML(Lines,OutBefore,OutAfter : TStrings);
     27  function  UnwrapHTML(HTMLText : string) : string;
     28  function  WrapHTML(HTMLText : string) : string;
     29//  function  WaitForBrowserOK(MaxSecDelay: integer; Application : TApplication) : boolean;
     30  function  CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
     31  function  ProtectHTMLSpaces(Text : String) : string;
     32  function  Text2HTML(Lines : TStrings) : String; overload;
     33  function  Text2HTML(text : string) : String;    overload;
     34  procedure SetRegHTMLFontSize(Size: byte);
     35  procedure RestoreRegHTMLFontSize;
     36  procedure SetupHTMLPrinting(Name,DOB,Location,Institution : string);
     37  procedure RestoreIEPrinting;
     38   
    2139implementation
    2240
    23 uses fNotes,
    24      fImages,
    25      StrUtils; {//kt added 5-2-05 rTIU for frmNotes.WebBrowser access}
    26 
    27 
    28 procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string);
    29 //Note:
    30 //     I use two web browsers because sometimes the display web browser
    31 //     would be changed by other parts of CPRS during the printing
    32 //     process, causing the incorrect page to print out.  By having a
    33 //     browser just for printing, this will hopefully not happen.
    34 //
    35 //      Web browser printing options:
    36 //        OLECMDEXECOPT_DODEFAULT       Use the default behavior, whether prompting the user for input or not.
    37 //        OLECMDEXECOPT_PROMPTUSER      Execute the command after obtaining user input.
    38 //        OLECMDEXECOPT_DONTPROMPTUSER  Execute the command without prompting the user.
    39 
    40 var
    41   Status: OLECMDF;
    42   HTMLfilename : string;
    43   //Pauses : integer;
    44 begin
    45   try
     41  uses fNotes,
     42       fImages,
     43       Messages,
     44       Graphics, //For color constants
     45       fTMGPrintingAnimation,
     46       StrUtils;
     47
     48  const CRLF = #$0D#$0A;
     49
     50 
     51  function GetCurrentPrinterName : string;
     52   //var ResStr: array[0..255] of Char;
     53  begin
     54  //GetProfileString('Windows', 'device', '', ResStr, 255);
     55  //Result := StrPas(ResStr);
     56    if (Printer.PrinterIndex > 0)then begin
     57      Result := Printer.Printers[Printer.PrinterIndex];
     58    end else begin
     59      Result := '';
     60    end;
     61  end;
     62
     63  procedure SetDefaultPrinter(PrinterName: String) ;
     64  var
     65      j                    : Integer;
     66      Device, Driver, Port : PChar;
     67      HdeviceMode          : THandle;
     68      aPrinter             : TPrinter;
     69  begin   
     70     Printer.PrinterIndex := -1;
     71     getmem(Device, 255) ;
     72     getmem(Driver, 255) ;
     73     getmem(Port, 255) ;
     74     aPrinter := TPrinter.create;
     75     j := Printer.Printers.IndexOf(PrinterName);
     76     if j >= 0 then begin
     77       aprinter.printerindex := j;
     78       aPrinter.getprinter(device, driver, port, HdeviceMode) ;
     79       StrCat(Device, ',') ;
     80       StrCat(Device, Driver ) ;
     81       StrCat(Device, Port ) ;
     82       WriteProfileString('windows', 'device', Device) ;
     83       StrCopy( Device, 'windows' ) ;
     84       //SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@Device)) ;
     85     end;
     86     Freemem(Device, 255) ;
     87     Freemem(Driver, 255) ;
     88     Freemem(Port, 255) ;
     89     aPrinter.Free;
     90  end;   
     91
     92
     93  procedure Wait(Sec : byte; Application : TApplication);
     94  var   StartTime : TDateTime;
     95  const OneSec = 0.000012; 
     96  begin
     97    StartTime := GetTime;
     98    repeat
     99      Application.ProcessMessages;
     100    until (GetTime-StartTime) > (OneSec*Sec);
     101  end;
     102 
     103  procedure PrintHTMLReport(Lines: TStringList; var ErrMsg: string;
     104                            PtName, DOB, Location:string;
     105                            Application : TApplication);
     106  //      Web browser printing options:
     107  //        OLECMDEXECOPT_DODEFAULT       Use the default behavior, whether prompting the user for input or not.
     108  //        OLECMDEXECOPT_PROMPTUSER      Execute the command after obtaining user input.
     109  //        OLECMDEXECOPT_DONTPROMPTUSER  Execute the command without prompting the user.
     110
     111  {Notice:  When IE is asked to print, it immediately returns from the function,
     112           but the printing has not yet occured.  If UI is requested, then the
     113          printing will not start until after the user selects a printer and
     114         presses [OK].  I could not find any reliable way to determine when the
     115        print job had been created.  I had to know this event because I need to
     116       restore some IE settings AFTER the printing has finished.  I even tried to
     117      get the active windows and see if it was a print dialog.  But IE print dlg
     118     apparently is owned by another thread than CPRS, because GetActiveWindow would
     119     not bring back a handle to the printer dialog window.  I therefore told IE
     120     to print WITHOUT asking which printer via UI.  In that case it prints to the
     121     system wide default printer.  So I have to set the default printer to the
     122     user's choice, and then change it back again.  This is bit of a kludge,
     123     but I couldn't figure out any other way after hours of trial and error.
     124     NOTE: I tried to query IE to see if it was able to print, thinking that it
     125     would return NO if in the process of currently printing.  It didn't work,
     126     and would return OK immediately.                                               }   
     127 
     128  var
     129    UseUI : OleVariant;   
     130    NewPrinterName,DefaultPrinter: string;   
     131    dlgWinPrinter: TPrintDialog;
     132  begin
     133    DefaultPrinter := GetCurrentPrinterName;
     134    dlgWinPrinter := TPrintDialog.Create(nil);
     135    frmTMGPrinting.Show;
     136    if dlgWinPrinter.Execute then begin  //only sets a local printer
     137      NewPrinterName := GetCurrentPrinterName; 
     138      SetDefaultPrinter(NewPrinterName); //Set global setting that IE will use.
     139      try
     140        //frmNotes.SetHTMLorTextViewer(True,Lines);  //ActivateHtmlViewer(Lines);
     141        frmNotes.SetDisplayToHTMLvsText([vmView,vmHTML],Lines);  //ActivateHtmlViewer(Lines);
     142        if frmNotes.HtmlViewer.WaitForDocComplete = false then begin
     143          ErrMsg := 'The web browser timed out trying to set up document.';
     144          exit;
     145        end;
     146        SetupHTMLPrinting(PtName,DOB,Location,' ');  {elh 6/19/09} //kt
     147        frmNotes.HtmlViewer.PrintFinished := false;               
     148        UseUI := false;  //UseUI := true;
     149        frmNotes.HtmlViewer.PrintDocument(UseUI);   //Returns immediately, not after printing done.
     150        Wait(4,Application); //give IE x sec to complete print document.  Is this always enough?
     151        //WaitForBrowserOK(10, Application); //wait up to 10 seconds  //Note: this doesn't do what I want.  Status is immediately OK.
     152        RestoreIEPrinting;   {elh 6/19/09}  //kt
     153      finally   //any needed final code goes here.
     154        SetDefaultPrinter(DefaultPrinter);
     155        //beep;
     156      end;
     157    end;
     158    dlgWinPrinter.Free;
     159    frmTMGPrinting.Hide;       
     160  end;
     161
     162  (*
     163  function WaitForBrowserOK(MaxSecDelay: integer; Application : TApplication) : boolean;
     164  //Returns TRUE if can print
     165  var
     166    StartTime : TDateTime;
     167    Status: OLECMDF;
     168    MaxDelay,ElapsedTime : Double;
     169    CanPrint : boolean;
     170  const
     171    OneMin = 0.0007;  //note: 0.0007 is about 1 minute
     172  begin
     173    StartTime := GetTime;
     174    MaxDelay := OneMin * MaxSecDelay;
     175    repeat
     176      Status := frmNotes.HtmlViewer.QueryStatusWB(OLECMDID_PRINT);  //"can you print?" -- get print command status
     177      CanPrint := (Status and OLECMDF_ENABLED) > 0;
     178      ElapsedTime := GetTime-StartTime;
     179      Application.ProcessMessages;
     180    until (ElapsedTime > MaxDelay) or CanPrint or frmNotes.HtmlViewer.PrintFinished;
     181    Result := CanPrint;
     182  end;
     183  *)
     184 
     185  Procedure ScanForSubs(Lines : TStrings);
     186  //Purpose: To scan note for constant $CPRS$ and replace with CPRS's actual directory
     187  var i : integer;
     188      CPRSDir : string;
     189  begin
     190    for i := 0 to Lines.Count-1 do begin
     191      if Pos('$CPRSDIR$',Lines.Strings[i])>0 then begin
     192        CPRSDir := ExcludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));
     193        Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],'$CPRSDIR$',CPRSDir);
     194        //Ensure images are downloaded before passing page to web browser       
     195        frmImages.timLoadImagesTimer(nil);
     196      end;
     197    end;
     198  end;
     199
     200
     201  function IsHTML(Line : String): boolean;
     202  {Purpose: To look at the Text and determine if it is an HTML document.
     203   Test used: if document contains <!DOCTYPE HTML" or <HTML> or </BODY>
     204        This is not a fool-proof test...                                   
     205   NOTE: **This does NOT call ScanForSubs as the other IsHTML(TStrings) function does.     }
     206       
     207  begin
     208    Result := false;  //default of false
     209    Line := UpperCase(Line);
     210    if (Pos('<!DOCTYPE HTML',Line) > 0)
     211      or (Pos('<HTML>',Line) > 0)
     212      or (Pos('</BODY>',Line) > 0)then begin
     213      Result := true;
     214    end;
     215  end;
     216
     217 
     218  function IsHTML(Lines : TStrings): boolean;
     219  //Purpose: To look at the note loaded into Lines and determine if it is
     220  //          an HTML document.  See other IsHTML(String) function for test used.
     221  begin
     222    Result := false; 
     223    if Lines = nil then exit;
     224    Result := IsHTML(Lines.Text);
     225    if Result = true then ScanForSubs(Lines); 
     226  end;
     227
     228 
     229  function HasHTMLTags(Text: string) : boolean;
     230    function GetTag(p1,p2 : integer; var Text : string) : string;
     231    var i : integer;
    46232    begin
    47       HTMLfilename := ExtractFilePath(ParamStr(0)) + 'printing_html_note.html';
    48       Lines.SaveToFile(HTMLfilename);  //write the note to a file,
    49       frmNotes.WebBrowser1.Navigate(HTMLfilename);  //now navigate to file.
    50       ActivateWebBrowser;
    51       Status := frmNotes.WebBrowser1.QueryStatusWB(OLECMDID_PRINT);  //"can you print?" -- get print command status
    52       //Note: If I print multiple documents, I think there may be a problem if
    53       //      document #2 asks to print, and it is not yet done with doc #1
    54       //      As it is now, it will simply report an error.  Solutions would
    55       //      be to wait a certain period of time and then ask for status again.
    56       //      OR, I could wait after printing until it is done....
    57       WaitForBrowserOK(10); //wait up to 10 seconds
    58       if (Status and OLECMDF_ENABLED)>0 then begin
    59         frmNotes.WebBrowser1.ExecWB(OLECMDID_PRINT,OLECMDEXECOPT_PROMPTUSER);
    60         //Here I want to wait until it is done printing.
    61         //Note: this doesn't do what I want.  Status is immediately OK.
    62         WaitForBrowserOK(10); //wait up to 10 seconds
     233      Result := MidStr(Text,p1, p2-p1);
     234      if Result[1] = '/' then Result := MidStr(Result,2,999);
     235      i := Pos(' ',Result);
     236      if i >0 then Result := MidStr(Result,1,i-1);
     237    end;
     238   
     239  var p1,p2: integer;
     240      Tag : string;
     241  begin
     242    Result := False; //default to ignore
     243    Text := UpperCase(Text);
     244    if (Pos('&NBSP;',Text)>0) then Result := true
     245    else if (Pos('<P>',Text)>0) then Result := true
     246    else if (Pos('<BR>',Text)>0) then Result := true
     247    else if (Pos('<HTML>',Text)>0) then Result := true
     248    else begin
     249      p1 := Pos('<',Text); if p1 = 0 then exit;
     250      p2 := Pos('>',Text); if p2 = 0 then exit;
     251      Tag := GetTag(p1,p2,Text);
     252      if Tag='' then exit;
     253      if Pos('/'+Tag+'>',Text)>0 then result := true;     
     254    end;
     255    {
     256    if (Pos('<BR>',Text)>0) or
     257       (Pos('</P>',Text)>0) or
     258       (Pos('<UL>',Text)>0) or
     259       (Pos('</UL>',Text)>0) or
     260       (Pos('<LI>',Text)>0) or
     261       (Pos('</LI>',Text)>0) or
     262       (Pos('<OL>',Text)>0) or
     263       (Pos('</OL>',Text)>0) or
     264       (Pos('&NBSP;',Text)>0) or
     265       (Pos('<P>',Text)>0) then begin
     266      Result := true;
     267    end;           
     268    }
     269  end;
     270   
     271 
     272  function LineAfterTag(Lines : TStrings; Tag : string) : integer;
     273  //returns index of line directly after tag (-1 if not found)
     274  //Note: only 1st tag is found (stops looking after that)
     275  var p,i : integer;
     276      s,s1,s2 : string;
     277  begin
     278    result := -1; 
     279    Tag := UpperCase(Tag);
     280    for i := 0 to Lines.Count-1 do begin
     281      s := UpperCase(Lines.Strings[i]);
     282      p := Pos(Tag,s);
     283      if p=0 then continue;
     284      if (p+length(Tag)-1) < length(s) then begin  //extra stuff after tag on line --> split line
     285        s1 := MidStr(Lines.Strings[i],1,p+length(Tag)-1);
     286        s2 := MidStr(Lines.Strings[i],p+length(Tag),9999);
     287        Lines.Strings[i] := s1;
     288        Lines.Insert(i+1,s2);           
     289      end;
     290      //Lines.Insert(i+1,'');   
     291      result := i+1;
     292      break;
     293    end;
     294  end;
     295
     296  function LineBeforeTag(Lines : TStrings; Tag : string) : integer;
     297  //returns index of newly added blank line, directly before tag (-1 if not found)
     298  //Note: only 1st tag is found (stops looking after that)
     299  var p,i,idx : integer;
     300      s,s1,s2 : string;
     301  begin
     302    result := -1; 
     303    idx := -1;
     304    Tag := UpperCase(Tag);
     305    for i := 0 to Lines.Count-1 do begin
     306      s := UpperCase(Lines.Strings[i]);
     307      p := Pos(Tag,s);
     308      if p>0 then begin
     309        idx := i;
     310        break;
     311      end; 
     312    end; 
     313    if idx <> -1 then begin
     314      p := Pos(Tag,UpperCase(Lines.Strings[idx]));
     315      if p>1 then begin  //extra stuff after tag on line --> split line
     316        s1 := MidStr(Lines.Strings[idx],1,p-1);
     317        s2 := MidStr(Lines.Strings[idx],p,9999);
     318        Lines.Strings[idx] := s1;
     319        Lines.Insert(idx+1,s2);
     320        inc(idx);
     321      end;
     322      //Lines.Insert(idx-1,'');   
     323      result := idx;
     324    end;
     325  end;
     326
     327  procedure SplitLineAfterTag(Lines : TStrings; Tag : string);
     328  //Purpose: To ensure that text that occurs after Tag is split and wrapped
     329  //         to the next line.
     330  //Note: It is assumed that tag is in form of <TAGName> or <SomeReallyLongText...
     331  //      if a closing '>' is not provided in the tag name, then the part provided
     332  //      is used for matching, and then a search for the closing '>' is made, and
     333  //      the split will occur after that.
     334  //Note: Only the first instance of Tag will be found, stops searching after that.
     335  //Note: Tag beginning and ending MUST occur on same line (wrapping of a long tag NOT supported)
     336  var i,p1,p2 : integer;
     337      s,s1,s2 : string;
     338  begin
     339    Tag := UpperCase(Tag);
     340    for i := 0 to Lines.Count-1 do begin
     341      s := UpperCase(Lines.Strings[i]);
     342      p1 := Pos(Tag,s);   
     343      if p1=0 then continue;
     344      p2 := PosEx('>',s,p1);
     345      if p2=0 then continue;  //this is a problem, no closing '>' found... ignore for now.
     346      if p2 = length(s) then break;
     347      s1 := MidStr(Lines.Strings[i],1,p2);
     348      S2 := MidStr(Lines.Strings[i],p2+1,999);
     349      Lines.Strings[i] := s1;
     350      Lines.Insert(i+1,s2);
     351      break;   
     352    end;
     353  end;
     354
     355  procedure SplitLineBeforeTag(Lines : TStrings; Tag : string);
     356  //Purpose: To ensure that text that occurs before Tag is split and Tag
     357  //         is wrapped to the next line.
     358  //Note: It is assumed that tag is in form of <TAGName> or <SomeReallyLongText...
     359  //Note: Only the first instance of Tag will be found, stops searching after that.
     360  var i,p1 : integer;
     361      s1,s2 : string;
     362  begin
     363    Tag := UpperCase(Tag);
     364    for i := 0 to Lines.Count-1 do begin
     365      p1 := Pos(Tag,UpperCase(Lines.Strings[i]));   
     366      if p1=0 then continue;
     367      s1 := MidStr(Lines.Strings[i],1,p1-1);
     368      S2 := MidStr(Lines.Strings[i],p1,999);
     369      Lines.Strings[i] := s1;
     370      Lines.Insert(i+1,s2);
     371      break;   
     372    end;
     373  end;
     374
     375  function IndexOfHoldingLine(Lines : TStrings; Tag : string) : integer;
     376  var i : integer;
     377      s : string;
     378  begin
     379    result := -1; 
     380    Tag := UpperCase(Tag);
     381    for i := 0 to Lines.Count-1 do begin
     382      s := UpperCase(Lines.Strings[i]);
     383      if Pos (Tag,s)=0 then continue;
     384      result := i;
     385      break;
     386    end;
     387  end;
     388
     389  procedure EnsureTrailingBR(Lines : TStrings);
     390  var  p,i : integer;
     391  begin
     392    for i := 0 to Lines.Count-1 do begin   //Ensure each line ends with <BR>
     393      p := Pos('<BR>',Lines.Strings[i]);
     394      if p+3=length(Lines.Strings[i]) then continue;
     395      Lines.Strings[i] := Lines.Strings[i] + '<BR>';         
     396    end;
     397  end;
     398
     399  procedure MergeLines(Lines,BeforeLines,AfterLines : TStrings);
     400  var  i : integer;
     401       Result : TStringList;
     402  begin
     403    Result := TStringList.Create;
     404    SplitLineAfterTag(Lines,'<!DOCTYPE HTML');
     405    SplitLineBeforeTag(Lines,'</BODY>');
     406    Result.Add(Lines.Strings[0]);  //Should be line with <!DOCTYPE HTML...
     407    for i := 0 to BeforeLines.Count-1 do begin  //Add Before-Lines text
     408      Result.Add(BeforeLines.Strings[i]);
     409    end;
     410    for i := 1 to Lines.Count-2 do begin  //Add back regular lines text
     411      Result.Add(Lines.Strings[i]);
     412    end;
     413    for i := 1 to AfterLines.Count-1 do begin //Add After-Lines text
     414      Result.Add(AfterLines.Strings[i]);
     415    end;
     416    Result.Add(Lines.Strings[Lines.count-1]); //Should be '</BODY></HTML>' line
     417
     418    Lines.Assign(Result); 
     419  end;
     420
     421  procedure StripBeforeAfterHTML(Lines,OutBefore,OutAfter : TStrings);
     422  //Purpose: Strip all text that comes before <!DOCTYPE ... line and store in OutBefore;
     423  //         Strip all text that comes after </HTML> ... line and store in OutAfter;           
     424  var i : integer;
     425      DocTypeLine,EndHTMLLine: integer;
     426  begin
     427    OutBefore.Clear;
     428    OutAfter.Clear;
     429    DocTypeLine := IndexOfHoldingLine(Lines,'<!DOCTYPE HTML');
     430    if DocTypeLine>1 then begin
     431      for i := 0 to DocTypeLine-1 do OutBefore.Add(Lines.Strings[i]);
     432      for i := 0 to DocTypeLine-1 do Lines.Delete(0);
     433    end;
     434    EndHTMLLine := IndexOfHoldingLine(Lines,'</HTML>');
     435    if (EndHTMLLine>0) and (EndHTMLLine < (Lines.Count-1)) then begin
     436      for i := EndHTMLLine+1 to Lines.Count-1 do OutAfter.Add(Lines.Strings[i]);
     437      for i := EndHTMLLine+1 to Lines.Count-1 do Lines.Delete(EndHTMLLine+1);
     438    end;
     439  end; 
     440
     441  Function FixHTMLCRLF(Text : String) : string;
     442  begin
     443    Result := AnsiReplaceText(Text,'<NO DATA>',#$1E); //protect sequences we want
     444    Result := AnsiReplaceText(Result,'>'+CRLF,'>'#$1F); //protect sequences we want
     445    Result := AnsiReplaceText(Result,CRLF,'<BR>'+CRLF); //Add <BR>'s to CrLf's
     446    Result := AnsiReplaceText(Result,'>'#$1F,'>'+CRLF); //Restore sequences we wanted
     447    Result := AnsiReplaceText(Result,#$1E,'<NO DATA>'); //Restore sequences we wanted
     448  end;
     449 
     450
     451  procedure FixHTML(Lines : TStrings); //kt 6/20/09
     452  //Purpose: to put header info that VistA adds to note into proper formatting. 
     453  var  BeforeLines,AfterLines : TStringList;
     454  begin
     455    BeforeLines := TStringList.Create;
     456    AfterLines := TStringList.Create;
     457    StripBeforeAfterHTML(Lines,BeforeLines,AfterLines);
     458    EnsureTrailingBR(BeforeLines);
     459    if BeforeLines.Count>0 then begin  //Wrap Before-Lines with formatting
     460      BeforeLines.Insert(0,'<CODE>');
     461      //<---Existing text remains in between --->
     462      BeforeLines.Add('</CODE>'); 
     463      BeforeLines.Add('<HR><P>');  //horizontal line
     464    end;
     465    EnsureTrailingBR(AfterLines); 
     466    if AfterLines.Count > 0 then begin  //Wrap After-Lines with formatting
     467      AfterLines.Insert(0,'<P><CODE>');
     468      //<---Existing text remains in between --->
     469      AfterLines.Add('</CODE>'); 
     470    end;
     471    MergeLines(Lines,BeforeLines,AfterLines);   
     472    BeforeLines.Free;
     473    AfterLines.Free;
     474  end;
     475 
     476  procedure SplitToArray (HTMLText: string; Lines : TStrings);
     477  var tempS                 : string;
     478    InEscapeCode, InTagCode : boolean;
     479    i, LastGoodBreakI       : integer;
     480    TagStart,TagEnd         : integer;
     481    TagText                 : string;
     482    TextLen                 : integer;
     483    MaxLineLen              : integer;
     484  begin
     485    Lines.Clear;
     486    MaxLineLen := 80;
     487    Repeat
     488      InEscapeCode := False;
     489      InTagCode := False;
     490      LastGoodBreakI := 0;
     491      TextLen := length(HTMLText);
     492      TagText := '';
     493      TagStart := 0; TagEnd := 0;
     494      if TextLen > 80 then TextLen := MaxLineLen;
     495      for i := 1 to TextLen do begin
     496        if (HTMLText[i] = '<') then begin
     497          InTagCode := True;
     498          TagStart := i;
     499          TagText := '';
     500          LastGoodBreakI := i-1;
     501        end;
     502        if (HTMLText[i] = '&') then begin
     503          InEscapeCode := True;
     504          LastGoodBreakI := i-1;
     505        end;
     506        if InEscapeCode and (HTMLText[i] = ';') then begin   
     507          InEscapeCode := False;
     508          LastGoodBreakI := i;
     509        end;
     510        if InTagCode and (HTMLText[i] = '>') then begin   
     511          InTagCode := False;
     512          TagEnd := i;
     513          TagText := UpperCase(MidStr(HTMLText,TagStart+1,(TagEnd-TagStart-1)));
     514          LastGoodBreakI := i;
     515        end;
     516        if (HTMLText[i] = ',') and (MaxLineLen > 80) then begin   
     517          LastGoodBreakI := i;       
     518          break;
     519        end;
     520        if (TagText='BR') or (TagText='/P') then begin
     521          LastGoodBreakI := TagEnd;
     522          break;
     523        end else TagText := '';; 
     524        if (not InTagCode) and (not InEscapeCode)
     525        and (HTMLText[i] = ' ') then LastGoodBreakI  := i;
     526      end;   
     527      if LastGoodBreakI > 0 then begin
     528        tempS := MidStr(HTMLText,1,LastGoodBreakI);   //get next 80 chars, or less if at the end.
     529        HTMLText := Rightstr(HTMLText, length(HTMLText)- LastGoodBreakI);    //characters 81 ... the end
     530        Lines.Add(tempS);     
    63531      end else begin
    64         ErrMsg := 'The web browser reports being unable to print.  Trying printing this document by itself.';
    65       end;
    66     end;
    67   finally
     532        if MaxLineLen < 250 then begin
     533          MaxLineLen := 250; //emergency mode     
     534        end else begin  //i.e. couldn't find any break within 250 chars. So just chop off.
     535          tempS := MidStr(HTMLText,1,80);   
     536          HTMLText := Rightstr(HTMLText, length(HTMLText)- 80);    //characters 81 ... the end
     537          Lines.Add(tempS);     
     538        end; 
     539      end; 
     540    until length(HTMLText)=0;
     541   end;     
     542 
     543
     544  function WrapHTML(HTMLText : string) : string; //kt 6/3/09
     545  //Purpose: take HTML formatted text and sure it has proper headers and footers etc.
     546  //         i.e. 'wrap' partial HTML into formal format.
     547  begin
     548    if Pos('<BODY>',HTMLText)=0 then HTMLText := '<BODY>' + HTMLText;   
     549    if Pos('</BODY>',HTMLText)=0 then HTMLText :=  HTMLText + '</BODY>';     
     550    if Pos('<HTML>',HTMLText)=0 then HTMLText := '<HTML>' + HTMLText;   
     551    if Pos('</HTML>',HTMLText)=0 then HTMLText :=  HTMLText + '</HTML>';     
     552    if Pos('<!DOCTYPE HTML',HTMLText)=0 then begin   
     553      HTMLText := '<!DOCTYPE HTML PUBLIC "-//WC3//DTD HTML 3.2//EN">'+ #10#13 + HTMLText;
     554    end;
     555    result := HTMLText;
     556  end;
     557
     558  function UnwrapHTML(HTMLText : string) : string;
     559  //Purpose: take HTML formatted text and remove proper headers and footers etc.
     560  //         i.e. 'unwrap' formal HTML into partial HTML format.
     561  begin
     562    HTMLText := piece(HTMLText,'<HTML>',2);
     563    HTMLText := piece(HTMLText,'</HTML>',1);
     564    HTMLText := piece(HTMLText,'<BODY>',2);
     565    HTMLText := piece(HTMLText,'</BODY>',1);
     566    result := HTMLText;
     567  end;
     568
     569  function CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
     570  {Purpose:  To scan memNote memo for a link to an image.  If found, return link(s)
     571   input:  none:
     572   output:  Will return a string list holding 1 or more links
     573   Notes:  Here will be the <img ..  > format scanned for:
     574
     575        Here is some opening text...
     576          <img src="http://www.geocities.com/kdtop3/OpenVistA.jpg" alt="Image Title 1">
     577        And here is some more text
     578          <img src="http://www.geocities.com/kdtop3/OpenVistA_small.jpg" alt="Image Title 2">
     579        And the saga continues...
     580          <img src="http://www.geocities.com/kdtop3/pics/Image100.gif" alt="Image Title 3">
     581           As with html, end-of-lines and white space is not preserved or significant
     582  }
     583
     584    function GetBetween (var Text : AnsiString; OpenTag,CloseTag : string;
     585                         KeepTags : Boolean) : string;
     586    {Purpose: Gets text between Open and Close tags.  Removes any CR's or LF's
     587     Input: Text - the text to work on.  It IS changed as code is removed
     588            KeepTags - true if want tag return in result
     589                       false if tag not in result (still is removed from Text)
     590     Output: Text is changed.
     591             Result=the code between the opening and closing tags
     592     Note: Both OpenTag and CloseTag MUST be present for anything to happen.
     593    }
     594
     595      procedure CutInThree(var Text : AnsiString; p1, p2 : Integer; var s1,s2,s3 : AnsiString);
     596      {Purpose: Cut input string Text into 3 parts, with cut points given by p1 & p2.
     597                p1 points to first character to be in s2
     598                p2 points to last character to be in s2        }
     599      begin
     600        s1 := ''; s2 := '';  s3 := '';
     601        if p1 > 1 then s1 := MidStr(Text, 1, p1-1);
     602        s2 := MidStr(Text, p1, p2-p1+1);
     603        s3 := MidStr(Text, p2+1, Length(Text)-p2);
     604      end;
     605
     606    var
     607      p1,p2 : integer;
     608      s1,s2,s3 : AnsiString;
     609
    68610    begin
    69       //any needed final code goes here.
    70     end;
    71   end;
    72 end;
    73 
    74 
    75 procedure WaitForBrowserOK(MaxSecDelay: integer);
    76 var
    77   CumulativeDelay : integer;
    78   Status: OLECMDF;
    79   MaxMSDelay: integer;
    80 
    81 const
    82   DelayStep = 1000;
    83 begin
    84   MaxMSDelay:=MaxSecDelay*1000;
    85   CumulativeDelay := 0;
    86   while ((Status and OLECMDF_ENABLED)<=0) and (CumulativeDelay < MaxMSDelay) do begin
    87     sleep(DelayStep);
    88     CumulativeDelay := CumulativeDelay + DelayStep;
    89     Status := frmNotes.WebBrowser1.QueryStatusWB(OLECMDID_PRINT);  //"can you print?" -- get print command status
    90     //Beep;
    91   end;
    92 end;
    93 
    94 
    95 Procedure ScanForSubs(Lines : TStrings);
    96 //Purpose: To scan note for constant $CPRS$ and replace with CPRS's actual directory
    97 var i : integer;
    98     CPRSDir : string;
    99 begin
    100   for i := 0 to Lines.Count-1 do begin
    101     if Pos('$CPRSDIR$',Lines.Strings[i])>0 then begin
    102       CPRSDir := ExcludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));
    103       Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],'$CPRSDIR$',CPRSDir);
    104       //Ensure images are downloaded before passing page to web browser       
    105       frmImages.timLoadImagesTimer(nil);  //only downloads 1 image each call
    106     end;
    107   end;
    108 end;
    109 
    110 
    111 //kt added following 5-2-05
    112 function IsHTMLDocument(Lines : TStrings): boolean;
    113 {purpose: To look at the note loaded into Lines and determine if it is
    114           an HTML document.
    115  Test used: if document contains <!DOCTYPE HTML" or <HTML>
    116       This is not a fool-proof test...                                   }
    117 var
    118   i:integer;  s : string;
    119 begin
    120   i := 0;
    121   Result := false;  //default of false
    122   while (i <= Lines.Count-1) do begin
    123     s := UpperCase(Lines.Strings[i]);
    124     if (Pos('<!DOCTYPE HTML',s) > 0) or (Pos('<HTML>',s) > 0) then begin
    125       Result := true;
    126       break;
    127     end;
    128     Inc(i);
    129   end;
    130   if Result = true then ScanForSubs(Lines); 
    131 end;
    132 //kt end of addition from 5-2-05
    133 
    134 
    135 procedure ActivateWebBrowser;
    136 begin
    137   with frmNotes do begin
    138     MemNote.Lines.SaveToFile(HTMLfilename);  //write the note to a file,
    139     //kt I later delete the file on destruction of this form (on CPRS exiting)
    140     WebBrowser1.Visible := true;
    141     WebBrowser1.TabStop := true;
    142     WebBrowser1.Navigate(HTMLfilename);  //now navigate to file.
    143     WebBrowser1.BringToFront;
    144     memNote.Visible := false;
    145     memNote.TabStop := false;
    146   end;
    147 end;
    148 
    149 procedure ActivateMemo;
    150 begin
    151   with frmNotes do begin
    152     WebBrowser1.Visible := false;
    153     //WebBrowser1.Navigate('about:blank');  //if I leave this here, "Print Selected" doesn't work properly
    154     //DeleteFile(HTMLfilename);  //no error if file doesn't exist.
    155     WebBrowser1.TabStop := false;
    156     memNote.Visible := true;
    157     memNote.TabStop := true;
    158     memNote.BringToFront;
    159     RedrawActivate(frmNotes.memNote.Handle);
    160   end;
    161 end;
    162 
    163 
    164 
    165 //kt added the following  1/1/05
    166 function CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
    167 {Purpose:  To scan memNote memo for a link to an image.  If found, return link(s)
    168  input:  none:
    169  output:  Will return a string list holding 1 or more links
    170  Notes:  Here will be the <img ..  > format scanned for:
    171 
    172       Here is some opening text...
    173         <img src="http://www.geocities.com/kdtop3/OpenVistA.jpg" alt="Image Title 1">
    174       And here is some more text
    175         <img src="http://www.geocities.com/kdtop3/OpenVistA_small.jpg" alt="Image Title 2">
    176       And the saga continues...
    177         <img src="http://www.geocities.com/kdtop3/pics/Image100.gif" alt="Image Title 3">
    178          As with html, end-of-lines and white space is not preserved or significant
    179 }
    180 
    181   function GetBetween (var Text : AnsiString; OpenTag,CloseTag : string;
    182                        KeepTags : Boolean) : string;
    183   {Purpose: Gets text between Open and Close tags.  Removes any CR's or LF's
    184    Input: Text - the text to work on.  It IS changed as code is removed
    185           KeepTags - true if want tag return in result
    186                      false if tag not in result (still is removed from Text)
    187    Output: Text is changed.
    188            Result=the code between the opening and closing tags
    189    Note: Both OpenTag and CloseTag MUST be present for anything to happen.
    190   }
    191 
    192     procedure CutInThree(var Text : AnsiString; p1, p2 : Integer; var s1,s2,s3 : AnsiString);
    193     {Purpose: Cut input string Text into 3 parts, with cut points given by p1 & p2.
    194               p1 points to first character to be in s2
    195               p2 points to last character to be in s2        }
    196     begin
    197       s1 := ''; s2 := '';  s3 := '';
    198       if p1 > 1 then s1 := MidStr(Text, 1, p1-1);
    199       s2 := MidStr(Text, p1, p2-p1+1);
    200       s3 := MidStr(Text, p2+1, Length(Text)-p2);
     611      Result := ''; //default of no result.
     612
     613      p1 := Pos(UpperCase(OpenTag), UpperCase(Text));
     614      if (p1 > 0) then begin
     615        p2 := Pos(UpperCase(CloseTag),UpperCase(Text)) + Length(CloseTag) -1;
     616        if ((p2 > 0) and (p2 > p1)) then begin
     617          CutInThree (Text, p1,p2, s1,Result,s3);
     618          Text := s1+s3;
     619          //Now, remove any CR's or LF's
     620          repeat
     621            p1 := Pos (Chr(13),Result);
     622            if p1= 0 then p1 := Pos (Chr(10),Result);
     623            if (p1 > 0) then begin
     624              CutInThree (Result, p1,p1, s1,s2,s3);
     625              Result := s1+s3;
     626  //            Text := MidStr(Text,1,p1-1) + MidStr(Text,p1+1,Length(Text)-p1);
     627            end;
     628          until (p1=0);
     629          //Now cut off boundry tags if requested.
     630          if not KeepTags then begin
     631            p1 := Length(OpenTag) + 1;
     632            p2 := Length (Result) - Length (CloseTag);
     633            CutInThree (Result, p1,p2, s1,s2,s3);
     634            Result := s2;
     635          end;
     636        end;
     637      end;
    201638    end;
    202639
    203640  var
    204     p1,p2 : integer;
    205     s1,s2,s3 : AnsiString;
    206 
    207   begin
    208     Result := ''; //default of no result.
    209 
    210     p1 := Pos(UpperCase(OpenTag), UpperCase(Text));
    211     if (p1 > 0) then begin
    212       p2 := Pos(UpperCase(CloseTag),UpperCase(Text)) + Length(CloseTag) -1;
    213       if ((p2 > 0) and (p2 > p1)) then begin
    214         CutInThree (Text, p1,p2, s1,Result,s3);
    215         Text := s1+s3;
    216         //Now, remove any CR's or LF's
    217         repeat
    218           p1 := Pos (Chr(13),Result);
    219           if p1= 0 then p1 := Pos (Chr(10),Result);
    220           if (p1 > 0) then begin
    221             CutInThree (Result, p1,p1, s1,s2,s3);
    222             Result := s1+s3;
    223 //            Text := MidStr(Text,1,p1-1) + MidStr(Text,p1+1,Length(Text)-p1);
    224           end;
    225         until (p1=0);
    226         //Now cut off boundry tags if requested.
    227         if not KeepTags then begin
    228           p1 := Length(OpenTag) + 1;
    229           p2 := Length (Result) - Length (CloseTag);
    230           CutInThree (Result, p1,p2, s1,s2,s3);
    231           Result := s2;
    232         end;
    233       end;
    234     end;
    235   end;
    236 
    237 var
    238   Text : AnsiString;
    239   Line : string;
    240 
    241 begin
    242   Result := false;  //set default
    243   if (ImageList <> nil) then begin
     641    Text : AnsiString;
     642    LineStr : string;
     643
     644  begin
     645    Result := false;  //set default
     646    if (ImageList = nil) or (Lines = nil) then exit;
    244647    ImageList.Clear;  //set default
    245648    Text := Lines.Text;  //Get entire note into one long string
    246649    repeat
    247       Line := GetBetween (Text, '<img', '>', true);
    248       if Line <> '' then begin
    249         ImageList.Add(Line);
     650      LineStr := GetBetween (Text, '<img', '>', true);
     651      if LineStr <> '' then begin
     652        ImageList.Add(LineStr);
    250653        Result := true;
    251654      end;
    252     until Line = '';
     655    until LineStr = '';
    253656    //Note: The following works, but need to replace removed links
    254657    // with "[Title]"   Work on later...
    255658    //memNote.Lines.Text := Text;
    256659  end;
    257 end;
    258 
    259 
    260 
     660
     661  function ProtectHTMLSpaces(Text : String) : string;
     662  begin
     663    Result := AnsiReplaceStr(Text, #9, '&nbsp;&nbsp;&nbsp;&nbsp; ');
     664    while Pos('  ',Result)>0 do begin //preserve whitespace
     665        Result := AnsiReplaceStr(Result, '  ', '&nbsp;&nbsp;');   
     666    end;
     667  end;
     668
     669  function  Text2HTML(Lines : TStrings) : String;
     670  //Purpose: Take plain text, and prep for viewing in HTML viewer.
     671  //i.e. convert TABs into &nbsp's and add <br> at end of line etc. 
     672  var i : integer;
     673      tempS : string;
     674  begin
     675    for i := 0 to Lines.Count-1 do begin
     676      tempS := TrimRight(Lines.Strings[i]);
     677      if i = Lines.Count-1 then tempS := tempS + '<P>'
     678      else tempS := tempS + '<BR>';
     679      Lines.Strings[i] := tempS;
     680    end;       
     681    Result := ProtectHTMLSpaces(Lines.Text)
     682  end;
     683
     684  function Text2HTML(text : string) : String;    overload;
     685  var Lines : TStringList;
     686  begin
     687    Lines := TStringList.create;
     688    Lines.Text := text;
     689    Result := Text2HTML(Lines);
     690    Lines.Free;
     691  end;
     692
     693  type
     694    TFontSizeData = record
     695      case byte of 1: (Data : array[0..3] of byte);
     696                   2: (Size : byte; Filler : array[1..3] of byte);
     697    end;   
     698   
     699  var
     700    StoredFontSize : TFontSizeData;
     701    FontSizeReg:     TRegistry;
     702 
     703  procedure SetRegHTMLFontSize(Size: byte);
     704  //Purpose: To set the internet explorer Font Size value via the registry.
     705  //Expected input: HTML_SMALLEST, HTML_SMALL, HTML_MEDIUM,HTML_LARGE, HTML_LARGEST
     706  //         Value should be 0 (smallest) - 4 (largest)
     707  const  HTML_BLANK : TFontSizeData =(Data: (0,0,0,0));
     708  var  Value : TFontSizeData;
     709
     710  begin
     711    if Size > 4 then Size := 4;
     712    Value := HTML_BLANK; Value.Size := Size;
     713    FontSizeReg := TRegistry.Create;  //To be freed in RestoreRegHTMLFontSize
     714    try
     715      FontSizeReg.Rootkey := HKEY_CURRENT_USER;
     716      if FontSizeReg.OpenKey('\Software\Microsoft\Internet Explorer\International\Scripts\3', False) then begin
     717        FontSizeReg.ReadBinaryData('IEFontSize',StoredFontSize,Sizeof(StoredFontSize));
     718        FontSizeReg.WriteBinaryData('IEFontSize',Value,SizeOf(Value));
     719      end;
     720    finally
     721    end;
     722  end;
     723
     724  procedure RestoreRegHTMLFontSize;
     725  //Purpose: To restore the Internet Explorer zoom value to a stored value..
     726  //elh 6/19/09
     727  begin
     728    if not assigned(FontSizeReg) then FontSizeReg := TRegistry.Create;
     729    try
     730      FontSizeReg.WriteBinaryData('IEFontSize',StoredFontSize,SizeOf(StoredFontSize));
     731    finally
     732      FontSizeReg.Free;
     733    end;
     734  end;
     735
     736  var
     737    StoredIEHeader, StoredIEFooters : string;
     738    Reg : TRegistry;
     739   
     740  procedure SetupHTMLPrinting(Name,DOB,Location,Institution : string);
     741  //Purpose: To open the IE header and footer registry keys, save the
     742  //current value and then replace with passed patient data.   elh 6/19/09
     743  //NOTE: There does not seem to be any other way to do this programatically.
     744  var NewHeader,NewFooter : string;
     745  begin
     746    if DesiredHTMLFontSize > 0 then begin
     747      SetRegHTMLFontSize(DesiredHTMLFontSize-1);   //Downsize by 1 step
     748    end; 
     749    NewHeader := Location + ' &b ' + Institution + ' &b Printed: &d &t';
     750    NewFooter := Name + ' &b DOB: ' + DOB + ' &b &p of &P';
     751    Reg := TRegistry.Create;  //to be freed in RestoreIEPrinting
     752    try
     753      Reg.Rootkey := HKEY_CURRENT_USER;
     754      if Reg.OpenKey('\Software\Microsoft\Internet Explorer\PageSetup', False) then begin
     755        StoredIEFooters := Reg.ReadString('footer');
     756        StoredIEHeader := Reg.ReadString('header');
     757        Reg.WriteString('header',NewHeader);
     758        Reg.WriteString('footer',NewFooter);
     759      end;
     760    finally
     761    end;
     762  end;
     763
     764  procedure RestoreIEPrinting;
     765  //Purpose: To restore the IE header and footer registry with the initial value
     766  //elh 6/19/09
     767  begin
     768    if not assigned(Reg) then Reg := TRegistry.Create;
     769    try
     770      Reg.WriteString('footer',StoredIEFooters);
     771      Reg.WriteString('header',StoredIEHeader);
     772      RestoreRegHTMLFontSize;
     773    finally
     774      Reg.Free;
     775    end;
     776  end;
     777
     778begin
     779  DesiredHTMLFontSize := 2; //probably overwritten in fNotes initialization
    261780end.
Note: See TracChangeset for help on using the changeset viewer.