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

Last change on this file since 795 was 793, checked in by Kevin Toppenberg, 14 years ago

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