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