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

Last change on this file since 657 was 541, checked in by Kevin Toppenberg, 16 years ago

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