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