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

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

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