Context Navigation

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

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

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

Download in other formats: