source: cprs/branches/foia-cprs/CPRS-Chart/fMHTest.pas@ 459

Last change on this file since 459 was 459, checked in by Kevin Toppenberg, 16 years ago

Adding foia-cprs branch
File size: 19.7 KB
Line 
1unit fMHTest;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ORCtrls, ORFn, uConst;
8
9type
10 TfrmMHTest = class(TForm)
11 sbMain: TScrollBox;
12 pnlBottom: TPanel;
13 btnCancel: TButton;
14 btnOK: TButton;
15 btnClear: TButton;
16 procedure FormDestroy(Sender: TObject);
17 procedure FormCreate(Sender: TObject);
18 procedure FormShow(Sender: TObject);
19 procedure sbMainResize(Sender: TObject);
20 procedure btnOKClick(Sender: TObject);
21 procedure FormKeyDown(Sender: TObject; var Key: Word;
22 Shift: TShiftState);
23 procedure btnClearClick(Sender: TObject);
24 private
25 FIDCount: integer;
26 FAnswers: TStringList;
27 FObjs: TList;
28 FInfoText: string;
29 FInfoLabel: TMemo;
30 FBuilt: boolean;
31 FMaxLines: integer;
32 FBuildingControls: boolean;
33 procedure BuildControls;
34 function Answers: string;
35 procedure GetQText(QText: TStringList);
36 function LoadTest(InitialAnswers, TestName: string): boolean;
37 function CurrentQ: integer;
38 procedure GotoQ(x: integer);
39 public
40 end;
41
42function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList): string;
43
44implementation
45
46uses rReminders;
47
48{$R *.DFM}
49
50const
51 MaxQ = 100; // Max # of allowed answers for one question
52 LineNumberTag = 1;
53 ComboBoxTag = 2;
54 BevelTag = 3;
55 QuestionLabelTag = 4;
56 CheckBoxTag = 10;
57
58 NumberThreshhold = 5; // min # of questions on test before each has a line number
59 Skipped = 'X';
60 QGap = 4;
61 Gap = 2;
62
63var
64 frmMHTest: TfrmMHTest;
65 FFirstCtrl: TList;
66 FYPos: TList;
67
68type
69 TMHQuestion = class(TObject)
70 private
71 FSeeAnswers: boolean;
72 FAnswerText: string;
73 FText: string;
74 FAllowedAnswers: string;
75 FAnswerIndex: integer;
76 FAnswerCount: integer;
77 FID: integer;
78 FAnswer: string;
79 FObjects: TList;
80 FLine: integer;
81 protected
82 procedure OnChange(Sender: TObject);
83 public
84 constructor Create;
85 destructor Destroy; override;
86 function Question: string;
87 procedure BuildControls(var Y: integer; Wide: integer);
88 property AllowedAnswers: string read FAllowedAnswers;
89 property Answer: string read FAnswer;
90 property AnswerCount: integer read FAnswerCount;
91 property AnswerIndex: integer read FAnswerIndex;
92 property AnswerText: string read FAnswerText;
93 property SeeAnswers: boolean read FSeeAnswers;
94 property ID: integer read FID;
95 property Text: string read FText;
96 end;
97
98procedure ProcessMsg;
99var
100 SaveCursor: TCursor;
101
102begin
103 if(Screen.Cursor = crHourGlass) then
104 begin
105 SaveCursor := Screen.Cursor;
106 Screen.Cursor := crDefault;
107 try
108 Application.ProcessMessages;
109 finally
110 Screen.Cursor := SaveCursor;
111 end;
112 end
113 else
114 Application.ProcessMessages;
115end;
116
117function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList): string;
118begin
119 Result := InitialAnswers;
120 frmMHTest := TfrmMHTest.Create(Application);
121 try
122 frmMHTest.Caption := TestName;
123 if(frmMHTest.LoadTest(InitialAnswers, TestName)) then
124 begin
125 if(frmMHTest.ShowModal = mrOK) then
126 begin
127 Result := frmMHTest.Answers;
128 if(assigned(QText)) then
129 begin
130 QText.Clear;
131 if(Result <> '') then
132 frmMHTest.GetQText(QText);
133 end;
134 end;
135 end;
136 finally
137 frmMHTest.Free;
138 end;
139end;
140
141{ TfrmMHTest }
142
143function TfrmMHTest.Answers: string;
144var
145 i, XCnt: integer;
146 ans: string;
147
148begin
149 Result := '';
150 XCnt := 0;
151 for i := 0 to FObjs.Count-1 do
152 begin
153 ans := TMHQuestion(FObjs[i]).FAnswer;
154 if(ans = Skipped) then
155 inc(XCnt);
156 Result := Result + ans;
157 end;
158 if(XCnt = FObjs.Count) then
159 Result := '';
160end;
161
162function TfrmMHTest.LoadTest(InitialAnswers, TestName: string): boolean;
163var
164 TstData: TStringList;
165 lNum, i, idx: integer;
166 Line, LastLine, Inp, Code: string;
167 Txt, Spec, p, Spidx, tmp: string;
168 RSpec, First, TCodes: boolean;
169 QObj: TMHQuestion;
170
171 procedure ParseText;
172 var
173 i, tlen: integer;
174
175 begin
176 Code := '';
177 i := 1;
178 tlen := length(Txt);
179 while(i <= tlen) do
180 begin
181 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
182 if(i > tlen) then
183 begin
184 Txt := '';
185 exit;
186 end;
187 if(i > 1) then
188 begin
189 delete(Txt,1,i-1);
190 i := 1;
191 end;
192 if(Spec = 'I') then exit;
193 tlen := length(Txt);
194 if(tlen < 3) then exit;
195 Code := copy(Txt,i,1);
196 if(pos(Code, (UpperCaseLetters + LowerCaseLetters + Digits)) = 0) then
197 begin
198 Code := '';
199 exit;
200 end;
201 inc(i);
202 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
203 if(Txt[i] in ['.','=']) then
204 begin
205 if(pos(Code, QObj.FAllowedAnswers) > 0) then
206 begin
207 inc(i);
208 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
209 if(i <= tlen) then
210 delete(Txt,1,i-1)
211 else
212 Code := '';
213 exit;
214 end
215 else
216 begin
217 Code := '';
218 exit;
219 end;
220 end
221 else
222 begin
223 Code := '';
224 exit;
225 end;
226 end;
227 end;
228
229 procedure AddTxt2Str(var X: string);
230 begin
231 if(Txt <> '') then
232 begin
233 if(X <> '') then
234 begin
235 X := X + ' ';
236 if(copy(Txt, length(Txt), 1) = '.') then
237 X := X + ' ';
238 end;
239 X := X + Txt;
240 end;
241 end;
242
243begin
244 Result := TRUE;
245 TstData := TStringList.Create;
246 try
247 TstData.Assign(LoadMentalHealthTest(TestName));
248 Screen.Cursor := crHourGlass;
249 try
250 TstData.Add('99999;X;0');
251 idx := 0;
252 FMaxLines := 0;
253 FInfoText := '';
254 LastLine := U;
255 First := TRUE;
256 RSpec := FALSE;
257 TCodes := FALSE;
258 QObj := nil;
259 while (idx < TstData.Count) do
260 begin
261 Inp := TstData[idx];
262 if(pos('[ERROR]', Inp) > 0) then
263 begin
264 Result := FALSE;
265 break;
266 end;
267 p := Piece(Inp, U, 1);
268 Line := Piece(p, ';', 1);
269 Spec := Piece(p, ';', 2);
270 SpIdx := Piece(p, ';', 3);
271 if(LastLine <> Line) then
272 begin
273 LastLine := Line;
274 if(First) then
275 First := FALSE
276 else
277 begin
278 if(not RSpec) then
279 begin
280 Result := FALSE;
281 break;
282 end;
283 end;
284 if(Spec = 'X') then break;
285 lNum := StrToIntDef(Line, 0);
286 if(lNum <= 0) then
287 begin
288 Result := FALSE;
289 break;
290 end;
291 RSpec := FALSE;
292 TCodes := FALSE;
293 QObj := TMHQuestion(FObjs[FObjs.Add(TMHQuestion.Create)]);
294 QObj.FLine := lNum;
295 if(FMaxLines < lNum) then
296 FMaxLines := lNum;
297 end;
298 Txt := Piece(Inp, U, 2);
299 ParseText;
300 if(Txt <> '') then
301 begin
302 if(Spec = 'I') then
303 begin
304 AddTxt2Str(FInfoText);
305 end
306 else
307 if(Spec = 'R') then
308 begin
309 RSpec := TRUE;
310 if(spIdx = '0') then
311 QObj.FAllowedAnswers := Txt
312 else
313 if(Code = '') then
314 QObj.FAnswerText := Txt
315 else
316 begin
317 QObj.FSeeAnswers := FALSE;
318 FAnswers.Add(Code + U + Txt);
319 inc(QObj.FAnswerCount);
320 end;
321 end
322 else
323 if(Spec = 'T') then
324 begin
325 if(Code = '') then
326 begin
327 if(TCodes) then
328 begin
329 tmp := FAnswers[FAnswers.Count-1];
330 AddTxt2Str(tmp);
331 FAnswers[FAnswers.Count-1] := tmp;
332 end
333 else
334 AddTxt2Str(QObj.FText);
335 end
336 else
337 begin
338 TCodes := TRUE;
339 FAnswers.Add(Code + U + Txt);
340 inc(QObj.FAnswerCount);
341 end;
342 end;
343 end;
344 inc(idx);
345 end;
346 finally
347 Screen.Cursor := crDefault;
348 end;
349 finally
350 TstData.Free;
351 end;
352 if(not Result) then
353 ShowMessage('Error encountered loading ' + TestName)
354 else
355 begin
356 for i := 0 to FObjs.Count-1 do
357 begin
358 with TMHQuestion(FObjs[i]) do
359 begin
360 tmp := copy(InitialAnswers,i+1,1);
361 if(tmp <> '') then
362 FAnswer := tmp;
363 end;
364 end;
365 end;
366end;
367
368procedure TfrmMHTest.FormCreate(Sender: TObject);
369begin
370 ResizeAnchoredFormToFont(self);
371 FAnswers := TStringList.Create;
372 FObjs := TList.Create;
373 FFirstCtrl := TList.Create;
374 FYPos := TList.Create;
375end;
376
377procedure TfrmMHTest.FormDestroy(Sender: TObject);
378begin
379 KillObj(@FFirstCtrl);
380 KillObj(@FYPos);
381 KillObj(@FObjs, TRUE);
382 KillObj(@FAnswers);
383end;
384
385procedure TfrmMHTest.BuildControls;
386var
387 i, Wide, Y: integer;
388 BoundsRect: TRect;
389begin
390 if(not FBuildingControls) then
391 begin
392 FBuildingControls := TRUE;
393 try
394 if(not assigned(FInfoLabel)) then
395 begin
396 FInfoLabel := TMemo.Create(Self);
397 FInfoLabel.Color := clBtnFace;
398 FInfoLabel.BorderStyle := bsNone;
399 FInfoLabel.ReadOnly := TRUE;
400 FInfoLabel.TabStop := FALSE;
401 FInfoLabel.Parent := sbMain;
402 FInfoLabel.WordWrap := TRUE;
403 FInfoLabel.Text := FInfoText;
404 FInfoLabel.Left := Gap;
405 end;
406 BoundsRect := FInfoLabel.BoundsRect;
407 Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4;
408 Y := Gap - sbMain.VertScrollBar.Position;
409 BoundsRect.Top := Y;
410 BoundsRect.Right := BoundsRect.Left + Wide;
411 WrappedTextHeightByFont(Canvas, FInfoLabel.Font, FInfoLabel.Text, BoundsRect);
412 BoundsRect.Right := BoundsRect.Left + Wide;
413 FInfoLabel.BoundsRect := BoundsRect;
414 ProcessMsg;
415 inc(Y, FInfoLabel.Height + QGap);
416 for i := 0 to FObjs.Count-1 do
417 TMHQuestion(FObjs[i]).BuildControls(Y, Wide);
418 finally
419 FBuildingControls := FALSE;
420 end;
421 end;
422end;
423
424procedure TfrmMHTest.GetQText(QText: TStringList);
425var
426 i, lx: integer;
427
428begin
429 if(FObjs.Count > 99) then
430 lx := 5
431 else
432 if(FObjs.Count > 9) then
433 lx := 4
434 else
435 lx := 3;
436 for i := 0 to FObjs.Count-1 do
437 QText.Add(copy(IntToStr(i+1) + '. ', 1, lx) + TMHQuestion(FObjs[i]).Question);
438end;
439
440function TfrmMHTest.CurrentQ: integer;
441var
442 i, j: integer;
443 ctrl: TWinControl;
444 MHQ: TMHQuestion;
445
446begin
447 Result := 0;
448 ctrl := ActiveControl;
449 if(not assigned(Ctrl)) then
450 exit;
451 for i := 0 to FObjs.Count-1 do
452 begin
453 MHQ := TMHQuestion(FObjs[i]);
454 for j := 0 to MHQ.FObjects.Count-1 do
455 begin
456 if(Ctrl = MHQ.FObjects[j]) then
457 begin
458 Result := i;
459 exit;
460 end;
461 end;
462 end;
463end;
464
465procedure TfrmMHTest.GotoQ(x: integer);
466begin
467 if(ModalResult <> mrNone) then exit;
468 if(x < 0) then x := 0;
469 if(x >= FYPos.Count) then
470 begin
471 btnOK.Default := TRUE;
472 btnOK.SetFocus;
473 end
474 else
475 begin
476 btnOK.Default := FALSE;
477 sbMain.VertScrollBar.Position := Integer(FYPos[x]) - 2;
478 TWinControl(FFirstCtrl[x]).SetFocus;
479 end;
480end;
481
482procedure TfrmMHTest.FormKeyDown(Sender: TObject; var Key: Word;
483 Shift: TShiftState);
484begin
485 if Key = VK_PRIOR then
486 begin
487 GotoQ(CurrentQ - 1);
488 Key := 0;
489 end
490 else
491 if (Key = VK_NEXT) or (Key = VK_RETURN) then
492 begin
493 GotoQ(CurrentQ + 1);
494 Key := 0;
495 end;
496end;
497
498{ TMHQuestion }
499
500procedure TMHQuestion.BuildControls(var Y: integer; Wide: integer);
501var
502 RCombo: TComboBox;
503 LNLbl, RLbl: TMemo;
504 Bvl: TBevel;
505 cb: TORCheckBox;
506 ans, idx, DX, MaxDX, MaxDY: integer;
507 Offset: integer;
508 txt: string;
509 QNum: integer;
510
511 function GetCtrl(SubTag: integer): TControl;
512 var
513 i: integer;
514
515 begin
516 Result := nil;
517 for i := 0 to FObjects.Count-1 do
518 begin
519 if(TControl(FObjects[i]).Tag = (FID + SubTag)) then
520 begin
521 Result := TControl(FObjects[i]);
522 break;
523 end;
524 end;
525 end;
526
527 procedure AdjDY(Ht: integer);
528 begin
529 if(MaxDY < Ht) then
530 MaxDY := Ht;
531 end;
532
533 procedure GetRLbl;
534 var
535 BoundsRect: TRect;
536 begin
537 if(FText <> '') then
538 begin
539 RLbl := TMemo(GetCtrl(QuestionLabelTag));
540 if(not assigned(RLbl)) then
541 begin
542 RLbl := TMemo.Create(frmMHTest);
543 RLbl.Color := clBtnFace;
544 RLbl.BorderStyle := bsNone;
545 RLbl.ReadOnly := TRUE;
546 RLbl.TabStop := FALSE;
547 RLbl.Parent := frmMHTest.sbMain;
548 RLbl.Tag := FID + QuestionLabelTag;
549 RLbl.WordWrap := TRUE;
550 RLbl.Text := FText;
551 FObjects.Add(RLbl);
552 end;
553 BoundsRect.Top := Y;
554 BoundsRect.Left := Offset;
555 BoundsRect.Right := Wide;
556 WrappedTextHeightByFont(frmMHTest.Canvas, RLbl.Font, RLbl.Text, BoundsRect);
557 BoundsRect.Right := Wide;
558 RLbl.BoundsRect := BoundsRect;
559 ProcessMsg;
560 end
561 else
562 RLbl := nil;
563 end;
564
565begin
566 QNum := (FID div MaxQ)-1;
567 while(FFirstCtrl.Count <= QNum) do
568 FFirstCtrl.Add(nil);
569 while(FYPos.Count <= QNum) do
570 FYPos.Add(nil);
571 FYPos[QNum] := Pointer(Y);
572 ans := pos(FAnswer, FAllowedAnswers) - 1;
573 Offset := Gap;
574 if(not assigned(FObjects)) then
575 FObjects := TList.Create;
576 MaxDY := 0;
577 if(frmMHTest.FObjs.Count >= NumberThreshhold) then
578 begin
579 LNLbl := TMemo(GetCtrl(LineNumberTag));
580 if(not assigned(LNLbl)) then
581 begin
582 LNLbl := TMemo.Create(frmMHTest);
583 LNLbl.Color := clBtnFace;
584 LNLbl.BorderStyle := bsNone;
585 LNLbl.ReadOnly := TRUE;
586 LNLbl.TabStop := FALSE;
587 LNLbl.Parent := frmMHTest.sbMain;
588 LNLbl.Tag := FID + LineNumberTag;
589 LNLbl.Text := IntToStr(QNum+1) + '.';
590 LNLbl.Width := TextWidthByFont(LNLbl.Font.Handle, LNLbl.Text);
591 LNLbl.Height := TextHeightByFont(LNLbl.Font.Handle, LNLbl.Text);
592 FObjects.Add(LNLbl);
593 end;
594 LNLbl.Top := Y;
595 LNLbl.Left := Offset;
596 inc(Offset, MainFontSize * 4);
597 AdjDY(LNLbl.Height);
598 end;
599
600 Bvl := TBevel(GetCtrl(BevelTag));
601 if(not assigned(Bvl)) then
602 begin
603 Bvl := TBevel.Create(frmMHTest);
604 Bvl.Parent := frmMHTest.sbMain;
605 Bvl.Tag := FID + BevelTag;
606 Bvl.Shape := bsFrame;
607 FObjects.Add(Bvl);
608 end;
609 Bvl.Top := Y;
610 Bvl.Left := Offset;
611 Bvl.Width := Wide - Offset;
612 inc(Offset, Gap * 2);
613 inc(Y, Gap * 2);
614 dec(Wide, Offset + (Gap * 2));
615
616 GetRLbl;
617 if(assigned(RLbl)) then
618 begin
619 MaxDY := RLbl.Height;
620 inc(Y, MaxDY + Gap * 2);
621 end;
622
623 if(FSeeAnswers) then
624 begin
625 for idx := 0 to FAnswerCount-1 do
626 begin
627 cb := TORCheckBox(GetCtrl(CheckBoxTag + idx));
628 if(not assigned(cb)) then
629 begin
630 cb := TORCheckBox.Create(frmMHTest);
631 if(idx = 0) then
632 FFirstCtrl[QNum] := cb;
633 cb.Parent := frmMHTest.sbMain;
634 cb.Tag := FID + CheckBoxTag + idx;
635 cb.GroupIndex := FID;
636 cb.WordWrap := TRUE;
637 cb.AutoSize := TRUE;
638 if(idx = ans) then
639 cb.Checked := TRUE;
640 cb.OnClick := OnChange;
641 cb.Caption := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2);
642 FObjects.Add(cb);
643 end;
644 cb.Top := Y;
645 cb.Left := Offset;
646 cb.WordWrap := TRUE;
647 cb.Width := Wide;
648 cb.AutoAdjustSize;
649 cb.WordWrap := (not cb.SingleLine);
650 inc(Y, cb.Height + Gap);
651 end;
652 end
653 else
654 begin
655 RCombo := TComboBox(GetCtrl(ComboBoxTag));
656 if(not assigned(RCombo)) then
657 begin
658 RCombo := TComboBox.Create(frmMHTest);
659 FFirstCtrl[QNum] := RCombo;
660 RCombo.Parent := frmMHTest.sbMain;
661 RCombo.Tag := FID + ComboBoxTag;
662 FObjects.Add(RCombo);
663 MaxDX := 0;
664 for idx := 0 to FAnswerCount-1 do
665 begin
666 txt := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2);
667 RCombo.Items.Add(txt);
668 DX := TextWidthByFont(frmMHTest.sbMain.Font.Handle, txt);
669 if(MaxDX < DX) then
670 MaxDX := DX;
671 end;
672 RCombo.ItemIndex := ans;
673 RCombo.Width := MaxDX + 24;
674 RCombo.OnChange := OnChange;
675 end;
676 RCombo.Top := Y;
677 RCombo.Left := Offset;
678 inc(Y, RCombo.Height + (Gap * 2));
679 end;
680 Bvl.Height := Y - Bvl.Top;
681 inc(Y, QGap);
682end;
683
684constructor TMHQuestion.Create;
685begin
686 inherited;
687 FSeeAnswers := TRUE;
688 FAnswerText := '';
689 FText := '';
690 FAllowedAnswers := '';
691 FAnswerIndex := frmMHTest.FAnswers.Count;
692 FAnswerCount := 0;
693 inc(frmMHTest.FIDCount, MaxQ);
694 FID := frmMHTest.FIDCount;
695 FAnswer := Skipped;
696end;
697
698destructor TMHQuestion.Destroy;
699begin
700 KillObj(@FObjects, TRUE);
701 inherited;
702end;
703
704procedure TMHQuestion.OnChange(Sender: TObject);
705var
706 idx: integer;
707 cb: TCheckBox;
708 cbo: TComboBox;
709
710begin
711 if(Sender is TCheckBox) then
712 begin
713 cb := TCheckBox(Sender);
714 if(cb.Checked) then
715 begin
716 idx := cb.Tag - CheckBoxTag + 1;
717 idx := idx mod MaxQ;
718 FAnswer := copy(FAllowedAnswers, idx, 1);
719 end
720 else
721 FAnswer := Skipped;
722 end
723 else
724 if(Sender is TComboBox) then
725 begin
726 cbo := TComboBox(Sender);
727 idx := cbo.ItemIndex + 1;
728 if(idx = 0) or (cbo.Text = '') then
729 FAnswer := Skipped
730 else
731 FAnswer := copy(FAllowedAnswers, idx, 1);
732 end;
733end;
734
735procedure TfrmMHTest.FormShow(Sender: TObject);
736begin
737 if(not FBuilt) then
738 begin
739 Screen.Cursor := crHourGlass;
740 try
741 BuildControls;
742 FBuilt := TRUE;
743 finally
744 Screen.Cursor := crDefault;
745 end;
746 end;
747end;
748
749procedure TfrmMHTest.sbMainResize(Sender: TObject);
750begin
751 if(FBuilt) then
752 BuildControls;
753end;
754
755function TMHQuestion.Question: string;
756var
757 idx: integer;
758 echar: string;
759
760begin
761 Result := trim(FText);
762 echar := copy(Result, length(Result), 1);
763 if(echar <> ':') and (echar <> '?') then
764 begin
765 if(echar = '.') then
766 delete(Result, length(result), 1);
767 Result := Result + ':';
768 end;
769 if(FAnswer = Skipped) then
770 Result := Result + ' Not rated'
771 else
772 begin
773 idx := pos(FAnswer, FAllowedAnswers) + FAnswerIndex - 1;
774 if(idx >= 0) and (idx < frmMHTest.FAnswers.Count) then
775 Result := Result + ' ' + Piece(frmMHTest.FAnswers[idx],U,2);
776 end;
777end;
778
779procedure TfrmMHTest.btnOKClick(Sender: TObject);
780var
781 i, XCnt, First: integer;
782 msg: string;
783
784begin
785 msg := '';
786 XCnt := 0;
787 First := -1;
788 for i := 0 to FObjs.Count-1 do
789 begin
790 if(TMHQuestion(FObjs[i]).FAnswer = Skipped) then
791 begin
792 if(First < 0) then First := i;
793 inc(XCnt);
794 if(msg <> '') then
795 msg := msg + ', ';
796 msg := msg + IntToStr(i+1);
797 end;
798 end;
799 if(XCnt = 0) then
800 ModalResult := mrOK
801 else
802 begin
803 if(XCnt = FObjs.Count) then
804 ModalResult := mrOK
805 else
806 begin
807 msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg;
808 if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions',
809 MB_YESNO or MB_ICONQUESTION) = IDYES) then
810 GotoQ(First)
811 else
812 ModalResult := mrOK;
813 end;
814 end;
815end;
816
817procedure TfrmMHTest.btnClearClick(Sender: TObject);
818var
819 i: integer;
820
821begin
822 for i := 0 to sbMain.ControlCount-1 do
823 begin
824 if(sbMain.Controls[i] is TCheckBox) then
825 TCheckBox(sbMain.Controls[i]).Checked := FALSE
826 else
827 if(sbMain.Controls[i] is TComboBox) then
828 begin
829 with TComboBox(sbMain.Controls[i]) do
830 begin
831 ItemIndex := -1;
832 OnChange(sbMain.Controls[i]);
833 end;
834 end;
835 end;
836end;
837
838end.
Note: See TracBrowser for help on using the repository browser.