Unit1.pas
上传用户:daoqigc
上传日期:2021-04-20
资源大小:2795k
文件大小:10k
- {==============================================================================}
- { This demo shows how to work with tables, mouse events, GetItemAt method }
- {==============================================================================}
- unit Unit1;
- interface
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
- Dialogs, RVTable, RVScroll, RichView, RVStyle, CRVFData, StdCtrls, MMSystem;
- type
- TForm1 = class(TForm)
- RVStyle1: TRVStyle;
- RichView1: TRichView;
- procedure FormCreate(Sender: TObject);
- procedure RichView1MouseMove(Sender: TObject; Shift: TShiftState; X,
- Y: Integer);
- procedure RichView1RVMouseUp(Sender: TCustomRichView;
- Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
- procedure RichView1Jump(Sender: TObject; id: Integer);
- private
- { Private declarations }
- HighlightedRVData: TCustomRVFormattedData; // highlighted cell
- AnsweredCount: Integer; // number of answered count
- Ready: Boolean; // "ready!" is clicked
- procedure AddTable(const Question: String; Answers: TStringList; CorrectAnswer: Integer);
- procedure HighlightCell(RVData: TCustomRVFormattedData);
- procedure SelectCell(RVData: TCustomRVFormattedData);
- procedure FillQuestion(sl: TStringList; const arr: array of String; var CorrectAnswer: Integer);
- procedure BuildQuiz;
- public
- { Public declarations }
- end;
- var
- Form1: TForm1;
- implementation
- {$R *.dfm}
- // Sorted array of answers.
- const Answers : array [0..3, 0..8] of String =
- (
- ('Mercury', 'Venus', 'Earth', 'Mars', 'Jupiter', 'Saturn', 'Uranus', 'Neptune', 'Pluto'),
- ('Pluto', 'Neptune', 'Uranus', 'Saturn', 'Jupiter', 'Mars', 'Earth', 'Venus', 'Mercury'),
- ('Pluto', 'Mercury', 'Mars', 'Venus', 'Earth', 'Neptune', 'Uranus', 'Saturn', 'Jupiter'),
- ('Jupiter', 'Saturn', 'Uranus', 'Neptune', 'Earth', 'Venus', 'Mars', 'Mercury', 'Pluto')
- );
- // Array of questions
- const Questions: array [0..3] of String =
- ( 'Which of these planets is closest to the Sun?',
- 'Which of these planets is the most distant from the Sun?',
- 'Which of these planets is the smallest?',
- 'Which of these planets is the largest?'
- );
- { TForm1 }
- const
- TABLECOLOR = $CCFFFF;
- HEADCOLOR = $990033;//$CCFF33;
- HLTCOLOR = $66CCFF;
- SELCOLOR = $3399CC;
- PASSCOLOR = $00FF33;
- FAILCOLOR = $0033FF;
- procedure TForm1.FormCreate(Sender: TObject);
- begin
- Randomize;
- BuildQuiz;
- end;
- {------------------------------------------------------------------------------}
- // Filling RichView. Preparing the quiz
- procedure TForm1.BuildQuiz;
- var sl: TStringList;
- i, CorrectAnswer: Integer;
- begin
- RichView1.Clear;
- AnsweredCount := 0;
- sl := TStringList.Create;
- for i := 0 to High(Questions) do begin
- // adding questions. one question is one table
- FillQuestion(sl, Answers[i], CorrectAnswer);
- AddTable(Questions[i], sl, CorrectAnswer);
- RichView1.AddNL('',0,0);
- end;
- sl.Free;
- // adding hypertext "button"
- RichView1.AddNL('Ready!', 2, 1);
- RichView1.Format;
- Ready := False;
- RVStyle1.TextStyles[2].HoverBackColor := FAILCOLOR;
- end;
- {------------------------------------------------------------------------------}
- // This function chooses 3 answers from ARR and add them in SL.
- // Index of the correct answer is returned in CORRECTANSWER
- procedure TForm1.FillQuestion(sl: TStringList; const arr: array of String;
- var CorrectAnswer: Integer);
- var i,j,v: Integer;
- var Options: array [0..2] of Integer;
- begin
- sl.Clear;
- // Choosing 3 different random answers
- for i := 0 to High(Options) do
- repeat
- v := Random(High(arr)+1);
- for j := 0 to i-1 do
- if Options[j]=v then begin
- v := -1;
- break;
- end;
- if v>=0 then begin
- Options[i] := v;
- sl.Add(arr[v]);
- end;
- until v>=0;
- // Finding the correct answer. arr is sorted so that the correct answer
- // is an answer with smaller index
- CorrectAnswer := -1;
- j := High(arr)+1;
- for i := 0 to High(Options) do begin
- if Options[i]<j then begin
- j := Options[i];
- CorrectAnswer := i;
- end;
- end;
- end;
- {------------------------------------------------------------------------------}
- // Adding one question
- // The 0-th table row will contain the question. Other rows - answers.
- // Index of the correct answer is stored in invisible table caption
- procedure TForm1.AddTable(const Question: String; Answers: TStringList;
- CorrectAnswer: Integer);
- var table: TRVTableItemInfo;
- i: Integer;
- begin
- table := TRVTableItemInfo.CreateEx(Answers.Count+1, 1, RichView1.RVData);
- table.BestWidth := -80;
- table.ParaNo := 1;
- table.Color := TABLECOLOR;
- table.Cells[0,0].Clear;
- table.Cells[0,0].AddNL(Question,1,0);
- table.Cells[0,0].Color := HEADCOLOR;
- for i := 0 to Answers.Count-1 do begin
- table.Cells[i+1,0].Clear;
- table.Cells[i+1,0].AddNL(Answers[i],0,0);
- end;
- table.BorderVSpacing := 5;
- table.BorderHSpacing := 10;
- table.CellPadding := 4;
- table.BorderWidth := 2;
- table.CellBorderWidth := 0;
- table.BorderStyle := rvtbColor;
- table.CellBorderStyle := rvtbColor;
- RichView1.AddItem(IntToStr(CorrectAnswer), table);
- end;
- {------------------------------------------------------------------------------}
- // If RVData is a table cell, this function highlights this cell.
- // Removes highlighting from the previously highlighted cell (stored in HighlightedRVData)
- // Updates HighlightedRVData
- // Highlighted cell has color = HLTCOLOR, others - clNone.
- procedure TForm1.HighlightCell(RVData: TCustomRVFormattedData);
- var r,c: Integer;
- begin
- if HighlightedRVData=RVData then
- exit;
- if HighlightedRVData<>nil then begin
- TRVTableCellData(HighlightedRVData).Color := clNone;
- HighlightedRVData.Invalidate;
- HighlightedRVData := nil;
- end;
- if not (RVData is TRVTableCellData) or (TRVTableCellData(RVData).Color=SELCOLOR) then
- exit;
- TRVTableCellData(RVData).GetTable.GetCellPosition(TRVTableCellData(RVData),r,c);
- if r=0 then
- exit;
- TRVTableCellData(RVData).Color := HLTCOLOR;
- RVData.Invalidate;
- HighlightedRVData := RVData;
- end;
- {------------------------------------------------------------------------------}
- // If RVData is a table cell, this function selects this cell.
- // Selected cell has color = SELCOLOR.
- // Updates number of answered questions (AnsweredCount).
- // If all questions are answered, changes highlight of hypertext jump from
- // red to green.
- procedure TForm1.SelectCell(RVData: TCustomRVFormattedData);
- var r,c: Integer;
- table: TRVTableItemInfo;
- begin
- if not (RVData is TRVTableCellData) then
- exit;
- table := TRVTableCellData(RVData).GetTable;
- table.GetCellPosition(TRVTableCellData(RVData),r,c);
- if r=0 then
- exit;
- for r := 1 to table.Rows.Count-1 do begin
- if table.Cells[r,0].Color=SELCOLOR then
- dec(AnsweredCount);
- table.Cells[r,0].Color := clNone;
- end;
- TRVTableCellData(RVData).Color := SELCOLOR;
- inc(AnsweredCount);
- TRVTableCellData(RVData).Invalidate;
- if HighlightedRVData=RVData then
- HighlightedRVData := nil;
- if AnsweredCount=High(Questions)+1 then
- RVStyle1.TextStyles[2].HoverBackColor := PASSCOLOR;
- end;
- {------------------------------------------------------------------------------}
- // OnMouseMove event - highlighting cell
- procedure TForm1.RichView1MouseMove(Sender: TObject; Shift: TShiftState; X,
- Y: Integer);
- var RVData: TCustomRVFormattedData;
- a,b: Integer;
- begin
- if Ready then
- exit;
- inc(X, RichView1.HScrollPos);
- inc(Y, RichView1.VScrollPos*RichView1.VSmallStep);
- RichView1.GetItemAt(X, Y, RVData, a, b, False);
- HighlightCell(RVData);
- end;
- {------------------------------------------------------------------------------}
- // OnRVMouseUP event - selecting cell
- procedure TForm1.RichView1RVMouseUp(Sender: TCustomRichView;
- Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
- var RVData: TCustomRVFormattedData;
- a,b: Integer;
- begin
- if Ready then
- exit;
- inc(X, RichView1.HScrollPos);
- inc(Y, RichView1.VScrollPos*RichView1.VSmallStep);
- RichView1.GetItemAt(X, Y, RVData, a, b, False);
- SelectCell(RVData);
- end;
- {------------------------------------------------------------------------------}
- // On hyperlink click.
- procedure TForm1.RichView1Jump(Sender: TObject; id: Integer);
- var i,r: Integer;
- table: TRVTableItemInfo;
- Score: Integer;
- begin
- if not Ready then begin // clicking on "Ready!"
- if AnsweredCount<High(Questions)+1 then begin
- Beep;
- exit;
- end;
- Ready := True;
- HighlightCell(RichView1.RVData);
- Score := 0;
- for i := 0 to RichView1.ItemCount-1 do
- if RichView1.GetItemStyle(i)=rvsTable then begin
- table := RichView1.GetItem(i) as TRVTableItemInfo;
- for r := 1 to table.Rows.Count-1 do
- if table.Cells[r,0].Color=SELCOLOR then begin
- if IntToStr(r-1)=RichView1.GetItemTextA(i) then begin
- table.Cells[0,0].AddNL(' (passed)', 1,-1);
- table.Cells[r,0].Color := PASSCOLOR;
- inc(Score);
- end
- else begin
- table.Cells[0,0].AddNL(' (failed)', 1,-1);
- table.Cells[r,0].Color := FAILCOLOR;
- end;
- break;
- end;
- end;
- RichView1.SetItemTextA(RichView1.ItemCount-1, 'Try again');
- Caption := Format('PlanetQuiz : %d of %d', [Score, High(Questions)+1]);
- RichView1.Format;
- RichView1.Update;
- if Score<>High(Questions)+1 then
- SndPlaySound('CHORD.WAV', SND_SYNC or SND_NODEFAULT)
- else
- SndPlaySound('TADA.WAV', SND_SYNC or SND_NODEFAULT);
- end
- else begin // clicking on "Try Again"
- BuildQuiz;
- RichView1.ScrollTo(0);
- Caption := 'PlanetQuiz';
- end;
- end;
- end.