Context Navigation

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

Last change on this file since 809 was 809, checked in by Kevin Toppenberg, 14 years ago
Corrected HTML line feed
File size: 34.9 KB

Line
1	unit 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
6	interface
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
50	implementation
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,'>'+CRLF,'>'#$1F); //protect sequences we want
512	Result := AnsiReplaceText(Result,CRLF,'<BR>'+CRLF); //Add <BR>'s to CrLf's
513	Result := AnsiReplaceText(Result,'>'#$1F,'><BR>'+CRLF); //Restore sequences we wanted
514	Result := AnsiReplaceText(Result,#$1E,'<NO DATA>'); //Restore sequences we wanted
515	end;
516
517
518	procedure FixHTML(Lines : TStrings); //kt 6/20/09
519	//Purpose: to put header info that VistA adds to note into proper formatting.
520	var BeforeLines,AfterLines : TStringList;
521	begin
522	BeforeLines := TStringList.Create;
523	AfterLines := TStringList.Create;
524	StripBeforeAfterHTML(Lines,BeforeLines,AfterLines);
525	EnsureTrailingBR(BeforeLines);
526	if BeforeLines.Count>0 then begin //Wrap Before-Lines with formatting
527	BeforeLines.Insert(0,'<CODE>');
528	//<---Existing text remains in between --->
529	BeforeLines.Add('</CODE>');
530	BeforeLines.Add('<HR><P>'); //horizontal line
531	end;
532	EnsureTrailingBR(AfterLines);
533	if AfterLines.Count > 0 then begin //Wrap After-Lines with formatting
534	AfterLines.Insert(0,'<P><CODE>');
535	//<---Existing text remains in between --->
536	AfterLines.Add('</CODE>');
537	end;
538	MergeLines(Lines,BeforeLines,AfterLines);
539	BeforeLines.Free;
540	AfterLines.Free;
541	end;
542
543	procedure SplitToArray (HTMLText: string; Lines : TStrings);
544	var tempS : string;
545	InEscapeCode, InTagCode : boolean;
546	i, LastGoodBreakI : integer;
547	TagStart,TagEnd : integer;
548	TagText : string;
549	TextLen : integer;
550	MaxLineLen : integer;
551	begin
552	Lines.Clear;
553	MaxLineLen := 80;
554	Repeat
555	InEscapeCode := False;
556	InTagCode := False;
557	LastGoodBreakI := 0;
558	TextLen := length(HTMLText);
559	TagText := '';
560	TagStart := 0; TagEnd := 0;
561	if TextLen > 80 then TextLen := MaxLineLen;
562	for i := 1 to TextLen do begin
563	if (HTMLText[i] = '<') then begin
564	InTagCode := True;
565	TagStart := i;
566	TagText := '';
567	LastGoodBreakI := i-1;
568	end;
569	if (HTMLText[i] = '&') then begin
570	InEscapeCode := True;
571	LastGoodBreakI := i-1;
572	end;
573	if InEscapeCode and (HTMLText[i] = ';') then begin
574	InEscapeCode := False;
575	LastGoodBreakI := i;
576	end;
577	if InTagCode and (HTMLText[i] = '>') then begin
578	InTagCode := False;
579	TagEnd := i;
580	TagText := UpperCase(MidStr(HTMLText,TagStart+1,(TagEnd-TagStart-1)));
581	LastGoodBreakI := i;
582	end;
583	if (HTMLText[i] = ',') and (MaxLineLen > 80) then begin
584	LastGoodBreakI := i;
585	break;
586	end;
587	if (TagText='BR') or (TagText='/P') then begin
588	LastGoodBreakI := TagEnd;
589	break;
590	end else TagText := '';;
591	if (not InTagCode) and (not InEscapeCode)
592	and (HTMLText[i] = ' ') then LastGoodBreakI := i;
593	end;
594	if LastGoodBreakI > 0 then begin
595	tempS := MidStr(HTMLText,1,LastGoodBreakI); //get next 80 chars, or less if at the end.
596	HTMLText := Rightstr(HTMLText, length(HTMLText)- LastGoodBreakI); //characters 81 ... the end
597	Lines.Add(tempS);
598	end else begin
599	if MaxLineLen < 250 then begin
600	MaxLineLen := 250; //emergency mode
601	end else begin //i.e. couldn't find any break within 250 chars. So just chop off.
602	tempS := MidStr(HTMLText,1,80);
603	HTMLText := Rightstr(HTMLText, length(HTMLText)- 80); //characters 81 ... the end
604	Lines.Add(tempS);
605	end;
606	end;
607	until length(HTMLText)=0;
608	end;
609
610
611	function WrapHTML(HTMLText : string) : string; //kt 6/3/09
612	//Purpose: take HTML formatted text and sure it has proper headers and footers etc.
613	// i.e. 'wrap' partial HTML into formal format.
614	begin
615	if Pos('<BODY>',HTMLText)=0 then HTMLText := '<BODY>' + HTMLText;
616	if Pos('</BODY>',HTMLText)=0 then HTMLText := HTMLText + '</BODY>';
617	if Pos('<HTML>',HTMLText)=0 then HTMLText := '<HTML>' + HTMLText;
618	if Pos('</HTML>',HTMLText)=0 then HTMLText := HTMLText + '</HTML>';
619	if Pos('<!DOCTYPE HTML',HTMLText)=0 then begin
620	HTMLText := '<!DOCTYPE HTML PUBLIC "-//WC3//DTD HTML 3.2//EN">'+ #10#13 + HTMLText;
621	end;
622	result := HTMLText;
623	end;
624
625	function UnwrapHTML(HTMLText : string) : string;
626	//Purpose: take HTML formatted text and remove proper headers and footers etc.
627	// i.e. 'unwrap' formal HTML into partial HTML format.
628	begin
629	HTMLText := piece(HTMLText,'<HTML>',2);
630	HTMLText := piece(HTMLText,'</HTML>',1);
631	HTMLText := piece(HTMLText,'<BODY>',2);
632	HTMLText := piece(HTMLText,'</BODY>',1);
633	result := HTMLText;
634	end;
635
636	function CheckForImageLink(Lines: TStrings; ImageList : TStringList) : boolean;
637	{Purpose: To scan memNote memo for a link to an image. If found, return link(s)
638	input: none:
639	output: Will return a string list holding 1 or more links
640	Notes: Here will be the <img .. > format scanned for:
641
642	Here is some opening text...
643	<img src="http://www.geocities.com/kdtop3/OpenVistA.jpg" alt="Image Title 1">
644	And here is some more text
645	<img src="http://www.geocities.com/kdtop3/OpenVistA_small.jpg" alt="Image Title 2">
646	And the saga continues...
647	<img src="http://www.geocities.com/kdtop3/pics/Image100.gif" alt="Image Title 3">
648	As with html, end-of-lines and white space is not preserved or significant
649	}
650
651	function GetBetween (var Text : AnsiString; OpenTag,CloseTag : string;
652	KeepTags : Boolean) : string;
653	{Purpose: Gets text between Open and Close tags. Removes any CR's or LF's
654	Input: Text - the text to work on. It IS changed as code is removed
655	KeepTags - true if want tag return in result
656	false if tag not in result (still is removed from Text)
657	Output: Text is changed.
658	Result=the code between the opening and closing tags
659	Note: Both OpenTag and CloseTag MUST be present for anything to happen.
660	}
661
662	procedure CutInThree(var Text : AnsiString; p1, p2 : Integer; var s1,s2,s3 : AnsiString);
663	{Purpose: Cut input string Text into 3 parts, with cut points given by p1 & p2.
664	p1 points to first character to be in s2
665	p2 points to last character to be in s2 }
666	begin
667	s1 := ''; s2 := ''; s3 := '';
668	if p1 > 1 then s1 := MidStr(Text, 1, p1-1);
669	s2 := MidStr(Text, p1, p2-p1+1);
670	s3 := MidStr(Text, p2+1, Length(Text)-p2);
671	end;
672
673	var
674	p1,p2 : integer;
675	s1,s2,s3 : AnsiString;
676
677	begin
678	Result := ''; //default of no result.
679
680	p1 := Pos(UpperCase(OpenTag), UpperCase(Text));
681	if (p1 > 0) then begin
682	p2 := Pos(UpperCase(CloseTag),UpperCase(Text)) + Length(CloseTag) -1;
683	if ((p2 > 0) and (p2 > p1)) then begin
684	CutInThree (Text, p1,p2, s1,Result,s3);
685	Text := s1+s3;
686	//Now, remove any CR's or LF's
687	repeat
688	p1 := Pos (Chr(13),Result);
689	if p1= 0 then p1 := Pos (Chr(10),Result);
690	if (p1 > 0) then begin
691	CutInThree (Result, p1,p1, s1,s2,s3);
692	Result := s1+s3;
693	// Text := MidStr(Text,1,p1-1) + MidStr(Text,p1+1,Length(Text)-p1);
694	end;
695	until (p1=0);
696	//Now cut off boundry tags if requested.
697	if not KeepTags then begin
698	p1 := Length(OpenTag) + 1;
699	p2 := Length (Result) - Length (CloseTag);
700	CutInThree (Result, p1,p2, s1,s2,s3);
701	Result := s2;
702	end;
703	end;
704	end;
705	end;
706
707	var
708	Text : AnsiString;
709	LineStr : string;
710
711	begin
712	Result := false; //set default
713	if (ImageList = nil) or (Lines = nil) then exit;
714	ImageList.Clear; //set default
715	Text := Lines.Text; //Get entire note into one long string
716	repeat
717	LineStr := GetBetween (Text, '<img', '>', true);
718	if LineStr <> '' then begin
719	ImageList.Add(LineStr);
720	Result := true;
721	end;
722	until LineStr = '';
723	//Note: The following works, but need to replace removed links
724	// with "[Title]" Work on later...
725	//memNote.Lines.Text := Text;
726	end;
727
728	function ProtectHTMLSpaces(Text : String) : string;
729	begin
730	Result := AnsiReplaceStr(Text, #9, '     ');
731	while Pos(' ',Result)>0 do begin //preserve whitespace
732	Result := AnsiReplaceStr(Result, ' ', '  ');
733	end;
734	end;
735
736	function Text2HTML(Lines : TStrings) : String;
737	//Purpose: Take plain text, and prep for viewing in HTML viewer.
738	//i.e. convert TABs into &nbsp's and add <br> at end of line etc.
739	var i : integer;
740	tempS : string;
741	begin
742	for i := 0 to Lines.Count-1 do begin
743	tempS := TrimRight(Lines.Strings[i]);
744	if i = Lines.Count-1 then tempS := tempS + '<P>'
745	else tempS := tempS + '<BR>';
746	Lines.Strings[i] := tempS;
747	end;
748	Result := ProtectHTMLSpaces(Lines.Text)
749	end;
750
751	function Text2HTML(text : string) : String; overload;
752	var Lines : TStringList;
753	begin
754	Lines := TStringList.create;
755	Lines.Text := text;
756	Result := Text2HTML(Lines);
757	Lines.Free;
758	end;
759
760	type
761	TFontSizeData = record
762	case byte of 1: (Data : array[0..3] of byte);
763	2: (Size : byte; Filler : array[1..3] of byte);
764	end;
765
766	var
767	StoredFontSize : TFontSizeData;
768	FontSizeReg: TRegistry;
769
770	procedure SetRegHTMLFontSize(Size: byte);
771	//Purpose: To set the internet explorer Font Size value via the registry.
772	//Expected input: HTML_SMALLEST, HTML_SMALL, HTML_MEDIUM,HTML_LARGE, HTML_LARGEST
773	// Value should be 0 (smallest) - 4 (largest)
774	const HTML_BLANK : TFontSizeData =(Data: (0,0,0,0));
775	var Value : TFontSizeData;
776
777	begin
778	if Size > 4 then Size := 4;
779	Value := HTML_BLANK; Value.Size := Size;
780	FontSizeReg := TRegistry.Create; //To be freed in RestoreRegHTMLFontSize
781	try
782	FontSizeReg.Rootkey := HKEY_CURRENT_USER;
783	if FontSizeReg.OpenKey('\Software\Microsoft\Internet Explorer\International\Scripts\3', False) then begin
784	FontSizeReg.ReadBinaryData('IEFontSize',StoredFontSize,Sizeof(StoredFontSize));
785	FontSizeReg.WriteBinaryData('IEFontSize',Value,SizeOf(Value));
786	end;
787	finally
788	end;
789	end;
790
791	procedure RestoreRegHTMLFontSize;
792	//Purpose: To restore the Internet Explorer zoom value to a stored value..
793	//elh 6/19/09
794	begin
795	if not assigned(FontSizeReg) then FontSizeReg := TRegistry.Create;
796	try
797	FontSizeReg.WriteBinaryData('IEFontSize',StoredFontSize,SizeOf(StoredFontSize));
798	finally
799	FontSizeReg.Free;
800	end;
801	end;
802
803	var
804	StoredIEHeader, StoredIEFooters : string;
805	Reg : TRegistry;
806
807	procedure SetupHTMLPrinting(Name,DOB,VisitDate,Location,Institution : string);
808	//Purpose: To open the IE header and footer registry keys, save the
809	//current value and then replace with passed patient data. elh 6/19/09
810	//NOTE: There does not seem to be any other way to do this programatically.
811	var NewHeader,NewFooter : string;
812	begin
813	if DesiredHTMLFontSize > 0 then begin
814	SetRegHTMLFontSize(DesiredHTMLFontSize-1); //Downsize by 1 step
815	end;
816	NewHeader := Location + ' &b ' + Institution + ' &b Printed: &d &t';
817	NewFooter := Name + ' (' + DOB + ') &b Note: ' + VisitDate + ' &b &p of &P';
818	Reg := TRegistry.Create; //to be freed in RestoreIEPrinting
819	try
820	Reg.Rootkey := HKEY_CURRENT_USER;
821	if Reg.OpenKey('\Software\Microsoft\Internet Explorer\PageSetup', False) then begin
822	StoredIEFooters := Reg.ReadString('footer');
823	StoredIEHeader := Reg.ReadString('header');
824	Reg.WriteString('header',NewHeader);
825	Reg.WriteString('footer',NewFooter);
826	end;
827	finally
828	end;
829	end;
830
831	procedure RestoreIEPrinting;
832	//Purpose: To restore the IE header and footer registry with the initial value
833	//NOTE: The below function was used to restore the previous value to the registry
834	// but got commented above, so the registry retained the patient's data
835	// to resolve this, we are now setting this to a default value.
836	//elh 6/19/09
837	begin
838	if not assigned(Reg) then begin
839	Reg := TRegistry.Create;
840	Reg.Rootkey := HKEY_CURRENT_USER;
841	Reg.OpenKey('\Software\Microsoft\Internet Explorer\PageSetup', False)
842	end;
843	try
844	StoredIEFooters := '&u&b&d'; //Comment this line to restore previous value
845	StoredIEHeader := '&d&b&t&bPage &p of &P'; //Comment this line to restore previous value
846	Reg.WriteString('footer',StoredIEFooters);
847	Reg.WriteString('header',StoredIEHeader);
848	RestoreRegHTMLFontSize;
849	finally
850	Reg.Free;
851	end;
852	end;
853
854	function ExtractDateOfNote(Lines : TStringList) : string;
855	//Scan note and return date found after 'DATE OF NOTE:', if present.
856	var i,p : integer;
857	s : string;
858	begin
859	Result := '';
860	if Lines = nil then exit;
861	for i := 0 to Lines.Count-1 do begin
862	p := Pos('DATE OF NOTE:',Lines.Strings[i]);
863	if p<1 then continue;
864	s := Piece(Lines.Strings[i],'DATE OF NOTE:',2);
865	s := Piece(s,'@',1);
866	Result := Trim(s);
867	end;
868	end;
869
870	function HTTPEncode(const AStr: string): string;
871	//NOTE: routine from here:
872	// http://www.delphitricks.com/source-code/internet/encode_a_http_url.html
873	//NOTE: I modified this to my purposes. I removed conversion of '/',':'
874	const
875	//kt original --> NoConversion = ['A'..'Z', 'a'..'z', '*', '@', '.', '_', '-'];
876	NoConversion = ['A'..'Z', 'a'..'z', '*', '@', '.', '_', '-', '/', ':']; //kt
877	var
878	Sp, Rp: PChar;
879	begin
880	SetLength(Result, Length(AStr) * 3);
881	Sp := PChar(AStr);
882	Rp := PChar(Result);
883	while Sp^ <> #0 do begin
884	if Sp^ in NoConversion then
885	Rp^ := Sp^
886	//kt else if Sp^ = ' ' then
887	//kt Rp^ := '+'
888	else begin
889	FormatBuf(Rp^, 3, '%%%.2x', 6, [Ord(Sp^)]);
890	Inc(Rp, 2);
891	end;
892	Inc(Rp);
893	Inc(Sp);
894	end;
895	SetLength(Result, Rp - PChar(Result));
896	end;
897
898
899	//===============================================================
900
901	Constructor TPrinterEvents.Create;
902	begin
903	RestorePrinterTimer := TTimer.Create(frmNotes);
904	RestorePrinterTimer.Enabled := false;
905	RestorePrinterTimer.Interval := 30000; //30 seconds to complete print job.
906	RestorePrinterTimer.OnTimer := HandleRestorePrinting;
907	PrintingNow := false;
908	end;
909
910	Destructor TPrinterEvents.Destroy;
911	begin
912	RestorePrinterTimer.Free;
913	inherited Destroy;
914	end;
915
916
917	procedure TPrinterEvents.HandleRestorePrinting (Sender: TObject);
918	begin
919	if PrinterEvents.PrintingNow then begin
920	RestorePrinterTimer.Enabled := true; // reset timer for later.
921	exit;
922	end;
923	RestorePrinterTimer.Enabled := false;
924	RestoreIEPrinting; {elh 6/19/09} //kt
925	//kt SetDefaultPrinter(SavedDefaultPrinter);
926	//beep;
927	end;
928
929	//===============================================================
930
931	function EncodePath(var Path : string) : string;
932	begin
933	Result := AnsiReplaceStr(Path,'\','/');
934	Result := HTTPEncode(Result);
935	end;
936
937	initialization
938	DesiredHTMLFontSize := 2; //probably overwritten in fNotes initialization
939	PrinterEvents := TPrinterEvents.Create;
940	CPRSDir := ExcludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));
941	URL_CPRSDir := EncodePath(CPRSDir);
942	SubsFoundList := TStringList.Create;
943
944	finalization
945	//kt causing crash --> Reg.WriteString('footer',StoredIEFooters);
946	//RestoreIEPrinting;
947	PrinterEvents.Free;
948	SubsFoundList.Free;
949
950	end.

Note: See TracBrowser for help on using the repository browser.

Download in other formats: