Context Navigation

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

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

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

Download in other formats: