close Warning: Can't use blame annotator:
svn blame failed on cprs/trunk/CPRS-Chart/Orders/fOCSession.pas: 'GenericSWIGWrapper' object has no attribute '_wrap'

source: cprs/trunk/CPRS-Chart/Orders/fOCSession.pas@ 908

Last change on this file since 908 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

File size: 10.7 KB
RevLine 
1unit fOCSession;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 fAutoSz, StdCtrls, ORFn, uConst, ORCtrls, ExtCtrls, VA508AccessibilityManager;
8
9type
10 TfrmOCSession = class(TfrmAutoSz)
11 lstChecks: TCaptionListBox;
12 pnlBottom: TPanel;
13 lblJustify: TLabel;
14 txtJustify: TCaptionEdit;
15 cmdCancelOrder: TButton;
16 cmdContinue: TButton;
17 btnReturn: TButton;
18 memNote: TMemo;
19 procedure cmdCancelOrderClick(Sender: TObject);
20 procedure cmdContinueClick(Sender: TObject);
21 procedure lstChecksMeasureItem(Control: TWinControl; Index: Integer;
22 var Height: Integer);
23 procedure lstChecksDrawItem(Control: TWinControl; Index: Integer;
24 Rect: TRect; State: TOwnerDrawState);
25 procedure FormClose(Sender: TObject; var Action: TCloseAction);
26 procedure FormShow(Sender: TObject);
27 procedure FormResize(Sender: TObject);
28 procedure txtJustifyKeyDown(Sender: TObject; var Key: Word;
29 Shift: TShiftState);
30 procedure btnReturnClick(Sender: TObject);
31 procedure memNoteEnter(Sender: TObject);
32 private
33 FCritical: Boolean;
34 FCancelSignProcess : Boolean;
35 FCheckList: TStringList;
36 FOrderList: TStringList;
37 procedure SetReqJustify;
38 procedure SetReturn(const Value: Boolean);
39 public
40 { Public declarations }
41 property CancelSignProcess : Boolean read FCancelSignProcess write SetReturn default false;
42 end;
43
44procedure ExecuteReleaseOrderChecks(SelectList: TList);
45function ExecuteSessionOrderChecks(OrderList: TStringList) : Boolean;
46
47implementation
48
49{$R *.DFM}
50
51uses rOrders, uCore, rMisc, fFrame;
52
53type
54 TOCRec = class
55 OrderID: string;
56 OrderText: string;
57 Checks: TStringList;
58 constructor Create(const AnID: string);
59 destructor Destroy; override;
60 end;
61
62var
63 uCheckedOrders: TList;
64 FOldHintHidePause: integer;
65
66constructor TOCRec.Create(const AnID: string);
67begin
68 OrderID := AnID;
69 Checks := TStringList.Create;
70 FOldHintHidePause := Application.HintHidePause;
71end;
72
73destructor TOCRec.Destroy;
74begin
75 Application.HintHidePause := FOldHintHidePause;
76 Checks.Free;
77 inherited Destroy;
78end;
79
80procedure ExecuteReleaseOrderChecks(SelectList: TList);
81var
82 i: Integer;
83 AnOrder: TOrder;
84 OrderIDList: TStringList;
85begin
86 OrderIDList := TStringList.Create;
87 try
88 for i := 0 to SelectList.Count - 1 do
89 begin
90 AnOrder := TOrder(SelectList.Items[i]);
91 OrderIDList.Add(AnOrder.ID + '^^1'); // 3rd pce = 1 means releasing order
92 end;
93 if ExecuteSessionOrderChecks(OrderIDList) then
94 for i := SelectList.Count - 1 downto 0 do
95 begin
96 AnOrder := TOrder(SelectList.Items[i]);
97 if OrderIDList.IndexOf(AnOrder.ID + '^^1') < 0 then
98 begin
99 Changes.Remove(CH_ORD, AnOrder.ID);
100 SelectList.Delete(i);
101 end;
102 end
103 else
104 SelectList.Clear;
105 finally
106 OrderIDList.Free;
107 end;
108end;
109
110{Returns True if the Signature process should proceed.
111 Clears OrderList If False. }
112function ExecuteSessionOrderChecks(OrderList: TStringList) : Boolean;
113var
114 i, j: Integer;
115 LastID, NewID: string;
116 CheckList: TStringList;
117 OCRec: TOCRec;
118 //AChangeItem: TChangeItem;
119 frmOCSession: TfrmOCSession;
120 x: string;
121begin
122 Result := True;
123 CheckList := TStringList.Create;
124 try
125 StatusText('Order Checking...');
126 OrderChecksForSession(CheckList, OrderList);
127 StatusText('');
128 if CheckList.Count > 0 then
129 begin
130 frmOCSession := TfrmOCSession.Create(Application);
131 try
132 ResizeFormToFont(TForm(frmOCSession));
133 uCheckedOrders := TList.Create;
134 LastID := '';
135 for i := 0 to CheckList.Count - 1 do
136 begin
137 NewID := Piece(CheckList[i], U, 1);
138 if NewID <> LastID then
139 begin
140 OCRec := TOCRec.Create(NewID);
141 uCheckedOrders.Add(OCRec);
142 LastID := NewID;
143 end; {if NewID}
144 end; {for i}
145 with uCheckedOrders do for i := 0 to Count - 1 do
146 begin
147 OCRec := TOCRec(Items[i]);
148 x := TextForOrder(OCRec.OrderID);
149 OCRec.OrderText := x;
150 for j := 0 to CheckList.Count - 1 do
151 if Piece(CheckList[j], U, 1) = OCRec.OrderID then
152 begin
153 OCRec.Checks.Add(Pieces(CheckList[j], U, 2, 4));
154 x := x + CRLF + Piece(CheckList[j], U, 4);
155 end;
156 //AChangeItem := Changes.Locate(CH_ORD, OCRec.OrderID);
157 //if AChangeItem <> nil then OCRec.OrderText := AChangeItem.Text;
158 frmOCSession.lstChecks.Items.Add(x);
159 end; {with...for i}
160 frmOCSession.FOrderList := OrderList;
161 frmOCSession.FCheckList := CheckList;
162 frmOCSession.SetReqJustify;
163 MessageBeep(MB_ICONASTERISK);
164 if frmOCSession.Visible then frmOCSession.SetFocus;
165 frmOCSession.ShowModal;
166 Result := not frmOCSession.CancelSignProcess;
167 if frmOCSession.CancelSignProcess then begin
168 OrderList.Clear;
169 if Assigned(frmFrame) then
170 frmFrame.SetActiveTab(CT_ORDERS);
171 end;
172 finally
173 with uCheckedOrders do for i := 0 to Count - 1 do TOCRec(Items[i]).Free;
174 frmOCSession.Free;
175 end; {try}
176 end; {if CheckList}
177 finally
178 CheckList.Free;
179 end;
180end;
181
182procedure TfrmOCSession.SetReqJustify;
183var
184 i, j: Integer;
185 OCRec: TOCRec;
186begin
187 FCritical := False;
188 with uCheckedOrders do for i := 0 to Count - 1 do
189 begin
190 OCRec := TOCRec(Items[i]);
191 for j := 0 to OCRec.Checks.Count - 1 do
192 if Piece(OCRec.Checks[j], U, 2) = '1' then FCritical := True;
193 end;
194 lblJustify.Visible := FCritical;
195 txtJustify.Visible := FCritical;
196 memNote.Visible := FCritical;
197
198end;
199
200procedure TfrmOCSession.lstChecksMeasureItem(Control: TWinControl; Index: Integer; var Height: Integer);
201var
202 i, AHt, TotalHt: Integer;
203 x: string;
204 ARect: TRect;
205 OCRec: TOCRec;
206begin
207 inherited;
208
209 with lstChecks do
210 begin
211 if Index >= uCheckedOrders.Count then Exit;
212 OCRec := TOCRec(uCheckedOrders.Items[Index]);
213 ARect := ItemRect(Index);
214 ARect.Left := ARect.Left + 2;
215 AHt := DrawText(Canvas.Handle, PChar(OCRec.OrderText), Length(OCRec.OrderText), ARect, DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DT_EXTERNALLEADING) + 2; //CQ7178: added DT_EXTERNALLEADING
216 TotalHt := AHt;
217
218 for i := 0 to OCRec.Checks.Count - 1 do
219 begin
220 ARect := ItemRect(Index);
221 ARect.Left := ARect.Left + 10;
222 x := Piece(OCRec.Checks[i], U, 3);
223 AHt := DrawText(Canvas.Handle, PChar(x), Length(x), ARect, DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DT_EXTERNALLEADING); //CQ7178: added DT_EXTERNALLEADING
224 TotalHt := TotalHt + AHt;
225 end;
226 end;
227 Height := TotalHt + 2; // add 2 for focus rectangle
228 if Height > 255 then Height := 255; //CQ7178
229end;
230
231procedure TfrmOCSession.lstChecksDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
232var
233 i, AHt: Integer;
234 x: string;
235 ARect: TRect;
236 OCRec: TOCRec;
237begin
238 inherited;
239
240 with lstChecks do
241 begin
242 if Index >= uCheckedOrders.Count then Exit;
243 OCRec := TOCRec(uCheckedOrders.Items[Index]);
244 ARect := ItemRect(Index);
245 AHt := DrawText(Canvas.Handle, PChar(OCRec.OrderText), Length(OCRec.OrderText), ARect, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DT_EXTERNALLEADING) + 2; //CQ7178: added DT_EXTERNALLEADING
246 ARect.Left := ARect.Left + 10;
247 ARect.Top := ARect.Top + AHt;
248 for i := 0 to OCRec.Checks.Count - 1 do
249 begin
250 x := Piece(OCRec.Checks[i], U, 3);
251 if not (odSelected in State) then
252 begin
253 if (Piece(OCRec.Checks[i], U, 2) = '1') then
254 begin
255 Canvas.Font.Color := Get508CompliantColor(clBlue);
256 Canvas.Font.Style := [fsUnderline];
257 end
258 else Canvas.Font.Color := clWindowText;
259 end;
260 AHt := DrawText(Canvas.Handle, PChar(x), Length(x), ARect, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK or DT_EXTERNALLEADING); //CQ7178: added DT_EXTERNALLEADING
261 ARect.Top := ARect.Top + AHt;
262 end;
263 end;
264
265end;
266
267procedure TfrmOCSession.cmdCancelOrderClick(Sender: TObject);
268var
269 i, j: Integer;
270 AnOrderID: string;
271 OCRec: TOCRec;
272begin
273 inherited;
274 for i := lstChecks.Items.Count - 1 downto 0 do if lstChecks.Selected[i] then
275 begin
276 OCRec := TOCRec(uCheckedOrders.Items[i]);
277 AnOrderID := OCRec.OrderID;
278 if DeleteCheckedOrder(AnOrderID) then
279 begin
280 for j := FCheckList.Count - 1 downto 0 do
281 if Piece(FCheckList[j], U, 1) = AnOrderID then FCheckList.Delete(j);
282 for j := FOrderList.Count - 1 downto 0 do
283 if Piece(FOrderList[j], U, 1) = AnOrderID then FOrderList.Delete(j);
284 OCRec.Free;
285 uCheckedOrders.Delete(i);
286 lstChecks.Items.Delete(i);
287 end;
288 end;
289 if uCheckedOrders.Count = 0 then Close;
290end;
291
292procedure TfrmOCSession.cmdContinueClick(Sender: TObject);
293begin
294 inherited;
295 if FCritical and ((Length(txtJustify.Text) < 2) or not ContainsVisibleChar(txtJustify.Text)) then
296 begin
297 InfoBox('A justification for overriding critical order checks is required.',
298 'Justification Required', MB_OK);
299 Exit;
300 end;
301 StatusText('Saving Order Checks...');
302 SaveOrderChecksForSession(txtJustify.Text, FCheckList);
303 StatusText('');
304 Close;
305end;
306
307procedure TfrmOCSession.FormClose(Sender: TObject;
308 var Action: TCloseAction);
309begin
310 inherited;
311 SaveUserBounds(Self); //Save Position & Size of Form
312end;
313
314procedure TfrmOCSession.FormShow(Sender: TObject);
315begin
316 inherited;
317 SetFormPosition(Self); //Get Saved Position & Size of Form
318 FCancelSignProcess := False;
319end;
320
321
322procedure TfrmOCSession.FormResize(Sender: TObject);
323begin
324 //TfrmAutoSz has defect must call inherited Resize for the resize to function.
325 inherited;
326end;
327
328procedure TfrmOCSession.txtJustifyKeyDown(Sender: TObject; var Key: Word;
329 Shift: TShiftState);
330begin
331 inherited;
332 //GE CQ9540 activate Return key, behave as "Continue" buttom clicked.
333 if Key = VK_RETURN then cmdContinueClick(self);
334end;
335
336procedure TfrmOCSession.btnReturnClick(Sender: TObject);
337begin
338 inherited;
339 FCancelSignProcess := True;
340 Close;
341end;
342
343procedure TfrmOCSession.SetReturn(const Value: Boolean);
344begin
345 FCancelSignProcess := Value;
346end;
347
348procedure TfrmOCSession.memNoteEnter(Sender: TObject);
349begin
350 inherited;
351 memNote.SelStart := 0;
352end;
353
354end.
Note: See TracBrowser for help on using the repository browser.