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

Last change on this file since 710 was 686, checked in by Kevin Toppenberg, 15 years ago

Fixed HTML Linked Template-Note Issue

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