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; CPRSDir : string; URL_CPRSDir : string; //This is CPRSDir, but all '\'s are converted to '/'s CONST ALT_IMG_TAG_CONVERT = 'alt="convert to $CPRSDIR$"'; 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); Procedure InsertSubs(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; SubsFoundList : TStringList; 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; (* 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,p,p2 : integer; tempS : String; begin SubsFoundList.Clear; for i := 0 to Lines.Count-1 do begin p := Pos('$CPRSDIR$',Lines.Strings[i]); if p>0 then begin p := p + Length('$CPRSDIR$\Cache\'); p2 := PosEx('"',Lines.Strings[i],p); tempS := MidStr(Lines.Strings[i],p,(p2-p)); SubsFoundList.Add(tempS); if Pos('file:///',Lines.Strings[i]) > 0 then begin Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],'$CPRSDIR$',URL_CPRSDir); end else begin Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],'$CPRSDIR$',CPRSDir); end; //Ensure images are downloaded before passing page to web browser end; end; frmImages.EnsureImagesDownloaded(SubsFoundList); end; Procedure InsertSubs(Lines : TStrings); //Purpose: To scan a edited note images, and replace references to CPRS's // actual local directory with $CPRS$ var i,p : integer; TempS: string; begin for i := 0 to Lines.Count-1 do begin Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],URL_CPRSDir,'$CPRSDIR$'); Lines.Strings[i] := AnsiReplaceStr(Lines.Strings[i],ALT_IMG_TAG_CONVERT,'IMAGE'); //Remove signal p := pos(ALT_IMG_TAG_CONVERT,Lines.Strings[i]); if p > 0 then begin TempS := MidStr(Lines.Strings[i],1,p-1); TempS := TempS + MidStr(Lines.Strings[i],p+length(ALT_IMG_TAG_CONVERT),length(Lines.Strings[i])+1); Lines.Strings[i] := TempS; 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 or 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(' 0) or (Pos('',Line) > 0) or (Pos('
',Line) > 0) or (Pos(HTML_BEGIN_TAG,Line) > 0) or (Pos('

',Line) > 0) or (Pos('&NBSP',Line) > 0) or (Pos('',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(' ',Text)>0) then Result := true else if (Pos('

',Text)>0) then Result := true else if (Pos('
',Text)>0) then Result := true else if (Pos('',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('
',Text)>0) or (Pos('

',Text)>0) or (Pos('',Text)>0) or (Pos('
  • ',Text)>0) or (Pos('
  • ',Text)>0) or (Pos('
      ',Text)>0) or (Pos('
    ',Text)>0) or (Pos('&NBSP;',Text)>0) or (Pos('

    ',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 or ' 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 or p := Pos('
    ',Lines.Strings[i]); if p+3=length(Lines.Strings[i]) then continue; Lines.Strings[i] := Lines.Strings[i] + '
    '; end; end; procedure MergeLines(Lines,BeforeLines,AfterLines : TStrings); var i : integer; Result : TStringList; begin Result := TStringList.Create; SplitLineAfterTag(Lines,''); Result.Add(Lines.Strings[0]); //Should be line with ' line Lines.Assign(Result); end; procedure StripBeforeAfterHTML(Lines,OutBefore,OutAfter : TStrings); //Purpose: Strip all text that comes before ... line and store in OutAfter; var i : integer; DocTypeLine,EndHTMLLine: integer; begin OutBefore.Clear; OutAfter.Clear; DocTypeLine := IndexOfHoldingLine(Lines,'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,''); 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,'',#$1E); //protect sequences we want Result := AnsiReplaceText(Result,'>'+CRLF,'>'#$1F); //protect sequences we want Result := AnsiReplaceText(Result,CRLF,'
    '+CRLF); //Add
    's to CrLf's Result := AnsiReplaceText(Result,'>'#$1F,'>'+CRLF); //Restore sequences we wanted Result := AnsiReplaceText(Result,#$1E,''); //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,''); //<---Existing text remains in between ---> BeforeLines.Add(''); BeforeLines.Add('


    '); //horizontal line end; EnsureTrailingBR(AfterLines); if AfterLines.Count > 0 then begin //Wrap After-Lines with formatting AfterLines.Insert(0,'

    '); //<---Existing text remains in between ---> AfterLines.Add(''); 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('',HTMLText)=0 then HTMLText := '' + HTMLText; if Pos('',HTMLText)=0 then HTMLText := HTMLText + ''; if Pos('',HTMLText)=0 then HTMLText := '' + HTMLText; if Pos('',HTMLText)=0 then HTMLText := HTMLText + ''; if Pos(''+ #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,'',2); HTMLText := piece(HTMLText,'',1); HTMLText := piece(HTMLText,'',2); HTMLText := piece(HTMLText,'',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 format scanned for: Here is some opening text... Image Title 1 And here is some more text Image Title 2 And the saga continues... 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, '', 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, '     '); while Pos(' ',Result)>0 do begin //preserve whitespace Result := AnsiReplaceStr(Result, ' ', '  '); end; end; function Text2HTML(Lines : TStrings) : String; //Purpose: Take plain text, and prep for viewing in HTML viewer. //i.e. convert TABs into  's and add
    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 + '

    ' else tempS := tempS + '
    '; 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; CPRSDir := ExcludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))); URL_CPRSDir := AnsiReplaceStr(CPRSDir,'\','/'); SubsFoundList := TStringList.Create; finalization PrinterEvents.Free; SubsFoundList.Free; end.