1 | //kt -- Modified with SourceScanner on 8/20/2007
|
---|
2 | unit fRptBox;
|
---|
3 |
|
---|
4 | interface
|
---|
5 |
|
---|
6 | uses
|
---|
7 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
---|
8 | StdCtrls, ORFn, ComCtrls, ExtCtrls, fFrame, DKLang;
|
---|
9 |
|
---|
10 | type
|
---|
11 | TfrmReportBox = class(TForm)
|
---|
12 | lblFontTest: TLabel;
|
---|
13 | memReport: TRichEdit;
|
---|
14 | pnlButton: TPanel;
|
---|
15 | cmdPrint: TButton;
|
---|
16 | dlgPrintReport: TPrintDialog;
|
---|
17 | cmdClose: TButton;
|
---|
18 | DKLanguageController1: TDKLanguageController;
|
---|
19 | procedure memReportClick(Sender: TObject);
|
---|
20 | procedure cmdPrintClick(Sender: TObject);
|
---|
21 | procedure cmdCloseClick(Sender: TObject);
|
---|
22 | procedure FormClose(Sender: TObject; var Action: TCloseAction);
|
---|
23 | procedure FormCreate(Sender: TObject);
|
---|
24 | end;
|
---|
25 |
|
---|
26 | procedure ReportBox(ReportText: TStrings; ReportTitle: string; AllowPrint: boolean);
|
---|
27 | function ModelessReportBox(ReportText: TStrings; ReportTitle: string; AllowPrint: boolean): TfrmReportBox;
|
---|
28 | procedure PrintStrings(Form: TForm; StringText: TStrings; const Title, Trailer: string);
|
---|
29 |
|
---|
30 | implementation
|
---|
31 |
|
---|
32 | uses
|
---|
33 | uCore, rCore, rReports, Printers, rMisc;
|
---|
34 |
|
---|
35 | {$R *.DFM}
|
---|
36 |
|
---|
37 | function CreateReportBox(ReportText: TStrings; ReportTitle: string; AllowPrint: boolean): TfrmReportBox;
|
---|
38 | var
|
---|
39 | i, AWidth, MaxWidth, AHeight: Integer;
|
---|
40 | Rect: TRect;
|
---|
41 | // %$@# buttons!
|
---|
42 | BtnArray: array of TButton;
|
---|
43 | BtnRight: array of integer;
|
---|
44 | BtnLeft: array of integer;
|
---|
45 | //cmdCloseRightMargin: integer;
|
---|
46 | //cmdPrintRightMargin: integer;
|
---|
47 | j, k: integer;
|
---|
48 | begin
|
---|
49 | Result := TfrmReportBox.Create(Application);
|
---|
50 | try
|
---|
51 | with Result do
|
---|
52 | begin
|
---|
53 | k := 0;
|
---|
54 | with pnlButton do for j := 0 to ControlCount - 1 do
|
---|
55 | if Controls[j] is TButton then
|
---|
56 | begin
|
---|
57 | SetLength(BtnArray, k+1);
|
---|
58 | SetLength(BtnRight, k+1);
|
---|
59 | BtnArray[j] := TButton(Controls[j]);
|
---|
60 | BtnRight[j] := ResizeWidth(Font, MainFont, BtnArray[j].Width - BtnArray[j].Width - BtnArray[j].Left);
|
---|
61 | k := k + 1;
|
---|
62 | end;
|
---|
63 | //cmdCloseRightMargin := ResizeWidth(Font, MainFont, pnlButton.Width - cmdClose.Width - cmdClose.Left);
|
---|
64 | //cmdPrintRightMargin := ResizeWidth(Font, MainFont, pnlButton.Width - cmdPrint.Width - cmdPrint.Left);
|
---|
65 | MaxWidth := 350;
|
---|
66 | for i := 0 to ReportText.Count - 1 do
|
---|
67 | begin
|
---|
68 | AWidth := lblFontTest.Canvas.TextWidth(ReportText[i]);
|
---|
69 | if AWidth > MaxWidth then MaxWidth := AWidth;
|
---|
70 | end;
|
---|
71 | cmdPrint.Visible := AllowPrint;
|
---|
72 | MaxWidth := MaxWidth + GetSystemMetrics(SM_CXVSCROLL);
|
---|
73 | AHeight := (ReportText.Count * (lblFontTest.Height + 2)) + pnlbutton.Height;
|
---|
74 | AHeight := HigherOf(AHeight, 250);
|
---|
75 | if AHeight > (Screen.Height - 80) then AHeight := Screen.Height - 80;
|
---|
76 | if MaxWidth > Screen.Width then MaxWidth := Screen.Width;
|
---|
77 | ClientWidth := MaxWidth;
|
---|
78 | ClientHeight := AHeight;
|
---|
79 | Rect := BoundsRect;
|
---|
80 | ForceInsideWorkArea(Rect);
|
---|
81 | BoundsRect := Rect;
|
---|
82 | ResizeAnchoredFormToFont(Result);
|
---|
83 |
|
---|
84 | memReport.Align := alClient; //CQ6661
|
---|
85 |
|
---|
86 | //CQ6889 - force Print & Close buttons to bottom right of form regardless of selected font size
|
---|
87 | cmdClose.Left := (pnlButton.Left+pnlButton.Width)-cmdClose.Width;
|
---|
88 | cmdPrint.Left := (cmdClose.Left-cmdPrint.Width)-1;
|
---|
89 | //end CQ6889
|
---|
90 |
|
---|
91 | SetLength(BtnLeft, k);
|
---|
92 | for j := 0 to k - 1 do
|
---|
93 | begin
|
---|
94 | BtnLeft[j] := pnlButton.Width - BtnArray[j].Width - BtnRight[j];
|
---|
95 | end;
|
---|
96 | //cmdClose.Left := pnlButton.Width - cmdClose.Width - cmdCloseRightMargin;
|
---|
97 | //cmdPrint.Left := pnlButton.Width - cmdPrint.Width - cmdPrintRightMargin;
|
---|
98 | memReport.Lines.Assign(ReportText);
|
---|
99 | for i := 1 to Length(ReportTitle) do if ReportTitle[i] = #9 then ReportTitle[i] := ' ';
|
---|
100 | Caption := ReportTitle;
|
---|
101 | memReport.SelStart := 0;
|
---|
102 | end;
|
---|
103 | except
|
---|
104 | KillObj(@Result);
|
---|
105 | raise;
|
---|
106 | end;
|
---|
107 | end;
|
---|
108 |
|
---|
109 | procedure ReportBox(ReportText: TStrings; ReportTitle: string; AllowPrint: boolean);
|
---|
110 | var
|
---|
111 | frmReportBox: TfrmReportBox;
|
---|
112 |
|
---|
113 | begin
|
---|
114 | frmReportBox := CreateReportBox(ReportText, ReportTitle, AllowPrint);
|
---|
115 | try
|
---|
116 | frmReportBox.ShowModal;
|
---|
117 | finally
|
---|
118 | frmReportBox.Release;
|
---|
119 | end;
|
---|
120 | end;
|
---|
121 |
|
---|
122 | function ModelessReportBox(ReportText: TStrings; ReportTitle: string; AllowPrint: boolean): TfrmReportBox;
|
---|
123 | begin
|
---|
124 | Result := CreateReportBox(ReportText, ReportTitle, AllowPrint);
|
---|
125 | Result.FormStyle := fsStayOnTop;
|
---|
126 | Result.Show;
|
---|
127 | end;
|
---|
128 |
|
---|
129 | procedure PrintStrings(Form: TForm; StringText: TStrings; const Title, Trailer: string);
|
---|
130 | var
|
---|
131 | AHeader: TStringList;
|
---|
132 | memPrintReport: TRichEdit;
|
---|
133 | MaxLines, LastLine, ThisPage, i: integer;
|
---|
134 | ErrMsg: string;
|
---|
135 | // RemoteSiteID: string; //for Remote site printing
|
---|
136 | // RemoteQuery: string; //for Remote site printing
|
---|
137 | dlgPrintReport: TPrintDialog;
|
---|
138 |
|
---|
139 | const
|
---|
140 | PAGE_BREAK = '**PAGE BREAK**';
|
---|
141 |
|
---|
142 | begin
|
---|
143 | // RemoteSiteID := '';
|
---|
144 | // RemoteQuery := '';
|
---|
145 | dlgPrintReport := TPrintDialog.Create(Form);
|
---|
146 | try
|
---|
147 | frmFrame.CCOWBusy := True;
|
---|
148 | if dlgPrintReport.Execute then
|
---|
149 | begin
|
---|
150 | AHeader := TStringList.Create;
|
---|
151 | CreatePatientHeader(AHeader, Title);
|
---|
152 | memPrintReport := TRichEdit.Create(Form);
|
---|
153 | try
|
---|
154 | MaxLines := 60 - AHeader.Count;
|
---|
155 | LastLine := 0;
|
---|
156 | ThisPage := 0;
|
---|
157 | with memPrintReport do
|
---|
158 | begin
|
---|
159 | Visible := False;
|
---|
160 | Parent := Form;
|
---|
161 | Font.Name := 'Courier New';
|
---|
162 | Font.Size := MainFontSize;
|
---|
163 | Width := Printer.Canvas.TextWidth(StringOfChar('-', 74));
|
---|
164 | //Width := 600;
|
---|
165 | repeat
|
---|
166 | with Lines do
|
---|
167 | begin
|
---|
168 | AddStrings(AHeader);
|
---|
169 | for i := 0 to MaxLines do
|
---|
170 | if i < StringText.Count then
|
---|
171 | Add(StringText[LastLine + i])
|
---|
172 | else
|
---|
173 | Break;
|
---|
174 | LastLine := LastLine + i;
|
---|
175 | Add(' ');
|
---|
176 | Add(' ');
|
---|
177 | Add(StringOfChar('-', 74));
|
---|
178 | if LastLine >= StringText.Count - 1 then
|
---|
179 | Add(Trailer)
|
---|
180 | else
|
---|
181 | begin
|
---|
182 | ThisPage := ThisPage + 1;
|
---|
183 | // Add('Page ' + IntToStr(ThisPage)); <-- original line. //kt 8/20/2007
|
---|
184 | Add(DKLangConstW('fRptBox_Page') + IntToStr(ThisPage)); //kt 8/20/2007
|
---|
185 | Add(PAGE_BREAK);
|
---|
186 | end;
|
---|
187 | end;
|
---|
188 | until LastLine >= StringText.Count - 1;
|
---|
189 | PrintWindowsReport(memPrintReport, PAGE_BREAK, Title, ErrMsg, Application); //kt 8/09, Added ',Application'
|
---|
190 | end;
|
---|
191 | finally
|
---|
192 | memPrintReport.Free;
|
---|
193 | AHeader.Free;
|
---|
194 | end;
|
---|
195 | end;
|
---|
196 | finally
|
---|
197 | frmFrame.CCOWBusy := False;
|
---|
198 | dlgPrintReport.Free;
|
---|
199 | end;
|
---|
200 | end;
|
---|
201 |
|
---|
202 |
|
---|
203 |
|
---|
204 | procedure TfrmReportBox.memReportClick(Sender: TObject);
|
---|
205 | begin
|
---|
206 | //Close;
|
---|
207 | end;
|
---|
208 |
|
---|
209 | procedure TfrmReportBox.cmdPrintClick(Sender: TObject);
|
---|
210 | begin
|
---|
211 | //PrintStrings(Self, memReport.Lines, Self.Caption, 'End of report'); <-- original line. //kt 8/20/2007
|
---|
212 | PrintStrings(Self, memReport.Lines, Self.Caption, DKLangConstW('fRptBox_End_of_report')); //kt added 8/20/2007
|
---|
213 | memReport.Invalidate;
|
---|
214 | end;
|
---|
215 |
|
---|
216 | procedure TfrmReportBox.cmdCloseClick(Sender: TObject);
|
---|
217 | begin
|
---|
218 | Close;
|
---|
219 | end;
|
---|
220 |
|
---|
221 | procedure TfrmReportBox.FormClose(Sender: TObject; var Action: TCloseAction);
|
---|
222 | begin
|
---|
223 | if(not (fsModal in FormState)) then
|
---|
224 | Action := caFree;
|
---|
225 | end;
|
---|
226 |
|
---|
227 | procedure TfrmReportBox.FormCreate(Sender: TObject);
|
---|
228 | begin
|
---|
229 | memReport.Color := ReadOnlyColor;
|
---|
230 | end;
|
---|
231 |
|
---|
232 | end.
|
---|