Unit1.pas
上传用户:daoqigc
上传日期:2021-04-20
资源大小:2795k
文件大小:10k
源码类别:

RichEdit

开发平台:

Delphi

  1. {==============================================================================}
  2. { This demo shows how to work with tables, mouse events, GetItemAt method      }
  3. {==============================================================================}
  4. unit Unit1;
  5. interface
  6. uses
  7.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  8.   Dialogs, RVTable, RVScroll, RichView, RVStyle, CRVFData, StdCtrls, MMSystem;
  9. type
  10.   TForm1 = class(TForm)
  11.     RVStyle1: TRVStyle;
  12.     RichView1: TRichView;
  13.     procedure FormCreate(Sender: TObject);
  14.     procedure RichView1MouseMove(Sender: TObject; Shift: TShiftState; X,
  15.       Y: Integer);
  16.     procedure RichView1RVMouseUp(Sender: TCustomRichView;
  17.       Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
  18.     procedure RichView1Jump(Sender: TObject; id: Integer);
  19.   private
  20.     { Private declarations }
  21.     HighlightedRVData: TCustomRVFormattedData; // highlighted cell
  22.     AnsweredCount: Integer; // number of answered count
  23.     Ready: Boolean; // "ready!" is clicked
  24.     procedure AddTable(const Question: String; Answers: TStringList; CorrectAnswer: Integer);
  25.     procedure HighlightCell(RVData: TCustomRVFormattedData);
  26.     procedure SelectCell(RVData: TCustomRVFormattedData);
  27.     procedure FillQuestion(sl: TStringList; const arr: array of String; var CorrectAnswer: Integer);
  28.     procedure BuildQuiz;
  29.   public
  30.     { Public declarations }
  31.   end;
  32. var
  33.   Form1: TForm1;
  34. implementation
  35. {$R *.dfm}
  36. // Sorted array of answers.
  37. const Answers : array [0..3, 0..8] of String =
  38.  (
  39.   ('Mercury', 'Venus', 'Earth', 'Mars', 'Jupiter', 'Saturn', 'Uranus', 'Neptune', 'Pluto'),
  40.   ('Pluto', 'Neptune', 'Uranus', 'Saturn', 'Jupiter', 'Mars', 'Earth', 'Venus', 'Mercury'),
  41.   ('Pluto', 'Mercury', 'Mars', 'Venus', 'Earth', 'Neptune', 'Uranus', 'Saturn', 'Jupiter'),
  42.   ('Jupiter', 'Saturn', 'Uranus', 'Neptune', 'Earth', 'Venus', 'Mars', 'Mercury', 'Pluto')
  43.  );
  44. // Array of questions
  45. const Questions: array [0..3] of String =
  46.   ( 'Which of these planets is closest to the Sun?',
  47.     'Which of these planets is the most distant from the Sun?',
  48.     'Which of these planets is the smallest?',
  49.     'Which of these planets is the largest?'
  50.    );
  51. { TForm1 }
  52. const
  53.   TABLECOLOR = $CCFFFF;
  54.   HEADCOLOR  = $990033;//$CCFF33;
  55.   HLTCOLOR   = $66CCFF;
  56.   SELCOLOR   = $3399CC;
  57.   PASSCOLOR  = $00FF33;
  58.   FAILCOLOR  = $0033FF;
  59. procedure TForm1.FormCreate(Sender: TObject);
  60. begin
  61.   Randomize;
  62.   BuildQuiz;
  63. end;
  64. {------------------------------------------------------------------------------}
  65. // Filling RichView. Preparing the quiz
  66. procedure TForm1.BuildQuiz;
  67. var sl: TStringList;
  68.     i, CorrectAnswer: Integer;
  69. begin
  70.   RichView1.Clear;
  71.   AnsweredCount := 0;
  72.   sl := TStringList.Create;
  73.   for i := 0 to High(Questions) do begin
  74.     // adding questions. one question is one table
  75.     FillQuestion(sl, Answers[i], CorrectAnswer);
  76.     AddTable(Questions[i], sl, CorrectAnswer);
  77.     RichView1.AddNL('',0,0);
  78.   end;
  79.   sl.Free;
  80.   // adding hypertext "button"
  81.   RichView1.AddNL('Ready!', 2, 1);
  82.   RichView1.Format;
  83.   Ready := False;
  84.   RVStyle1.TextStyles[2].HoverBackColor := FAILCOLOR;
  85. end;
  86. {------------------------------------------------------------------------------}
  87. // This function chooses 3 answers from ARR and add them in SL.
  88. // Index of the correct answer is returned in CORRECTANSWER
  89. procedure TForm1.FillQuestion(sl: TStringList; const arr: array of String;
  90.   var CorrectAnswer: Integer);
  91. var i,j,v: Integer;
  92. var Options: array [0..2] of Integer;
  93. begin
  94.   sl.Clear;
  95.   // Choosing 3 different random answers
  96.   for i := 0 to High(Options) do
  97.     repeat
  98.       v := Random(High(arr)+1);
  99.       for j := 0 to i-1 do
  100.         if Options[j]=v then begin
  101.           v := -1;
  102.           break;
  103.         end;
  104.       if v>=0 then begin
  105.         Options[i] := v;
  106.         sl.Add(arr[v]);
  107.       end;
  108.     until v>=0;
  109.   // Finding the correct answer. arr is sorted so that the correct answer
  110.   // is an answer with smaller index
  111.   CorrectAnswer := -1;
  112.   j := High(arr)+1;
  113.   for i := 0 to High(Options) do begin
  114.     if Options[i]<j then begin
  115.       j := Options[i];
  116.       CorrectAnswer := i;
  117.     end;
  118.   end;
  119. end;
  120. {------------------------------------------------------------------------------}
  121. // Adding one question
  122. // The 0-th table row will contain the question. Other rows - answers.
  123. // Index of the correct answer is stored in invisible table caption
  124. procedure TForm1.AddTable(const Question: String; Answers: TStringList;
  125.   CorrectAnswer: Integer);
  126. var table: TRVTableItemInfo;
  127.     i: Integer;
  128. begin
  129.   table := TRVTableItemInfo.CreateEx(Answers.Count+1, 1, RichView1.RVData);
  130.   table.BestWidth := -80;
  131.   table.ParaNo := 1;
  132.   table.Color := TABLECOLOR;
  133.   table.Cells[0,0].Clear;
  134.   table.Cells[0,0].AddNL(Question,1,0);
  135.   table.Cells[0,0].Color := HEADCOLOR;
  136.   for i := 0 to Answers.Count-1 do begin
  137.     table.Cells[i+1,0].Clear;
  138.     table.Cells[i+1,0].AddNL(Answers[i],0,0);
  139.   end;
  140.   table.BorderVSpacing := 5;
  141.   table.BorderHSpacing := 10;
  142.   table.CellPadding := 4;
  143.   table.BorderWidth := 2;
  144.   table.CellBorderWidth := 0;
  145.   table.BorderStyle := rvtbColor;
  146.   table.CellBorderStyle := rvtbColor;
  147.   RichView1.AddItem(IntToStr(CorrectAnswer), table);
  148. end;
  149. {------------------------------------------------------------------------------}
  150. // If RVData is a table cell, this function highlights this cell.
  151. // Removes highlighting from the previously highlighted cell (stored in HighlightedRVData)
  152. // Updates HighlightedRVData
  153. // Highlighted cell has color = HLTCOLOR, others - clNone.
  154. procedure TForm1.HighlightCell(RVData: TCustomRVFormattedData);
  155. var r,c: Integer;
  156. begin
  157.   if HighlightedRVData=RVData then
  158.     exit;
  159.   if HighlightedRVData<>nil then begin
  160.     TRVTableCellData(HighlightedRVData).Color := clNone;
  161.     HighlightedRVData.Invalidate;
  162.     HighlightedRVData := nil;
  163.   end;
  164.   if not (RVData is TRVTableCellData) or (TRVTableCellData(RVData).Color=SELCOLOR) then
  165.     exit;
  166.   TRVTableCellData(RVData).GetTable.GetCellPosition(TRVTableCellData(RVData),r,c);
  167.   if r=0 then
  168.     exit;
  169.   TRVTableCellData(RVData).Color := HLTCOLOR;
  170.   RVData.Invalidate;
  171.   HighlightedRVData := RVData;
  172. end;
  173. {------------------------------------------------------------------------------}
  174. // If RVData is a table cell, this function selects this cell.
  175. // Selected cell has color = SELCOLOR.
  176. // Updates number of answered questions (AnsweredCount).
  177. // If all questions are answered, changes highlight of hypertext jump from
  178. // red to green.
  179. procedure TForm1.SelectCell(RVData: TCustomRVFormattedData);
  180. var r,c: Integer;
  181.     table: TRVTableItemInfo;
  182. begin
  183.   if not (RVData is TRVTableCellData) then
  184.     exit;
  185.   table := TRVTableCellData(RVData).GetTable;
  186.   table.GetCellPosition(TRVTableCellData(RVData),r,c);
  187.   if r=0 then
  188.     exit;
  189.   for r := 1 to table.Rows.Count-1 do begin
  190.     if table.Cells[r,0].Color=SELCOLOR then
  191.       dec(AnsweredCount);
  192.     table.Cells[r,0].Color := clNone;
  193.   end;
  194.   TRVTableCellData(RVData).Color := SELCOLOR;
  195.   inc(AnsweredCount);
  196.   TRVTableCellData(RVData).Invalidate;
  197.   if HighlightedRVData=RVData then
  198.     HighlightedRVData := nil;
  199.   if AnsweredCount=High(Questions)+1 then
  200.     RVStyle1.TextStyles[2].HoverBackColor := PASSCOLOR;
  201. end;
  202. {------------------------------------------------------------------------------}
  203. // OnMouseMove event - highlighting cell
  204. procedure TForm1.RichView1MouseMove(Sender: TObject; Shift: TShiftState; X,
  205.   Y: Integer);
  206. var RVData: TCustomRVFormattedData;
  207.     a,b: Integer;
  208. begin
  209.   if Ready then
  210.     exit;
  211.   inc(X, RichView1.HScrollPos);
  212.   inc(Y, RichView1.VScrollPos*RichView1.VSmallStep);
  213.   RichView1.GetItemAt(X, Y, RVData, a, b, False);
  214.   HighlightCell(RVData);
  215. end;
  216. {------------------------------------------------------------------------------}
  217. // OnRVMouseUP event - selecting cell
  218. procedure TForm1.RichView1RVMouseUp(Sender: TCustomRichView;
  219.   Button: TMouseButton; Shift: TShiftState; ItemNo, X, Y: Integer);
  220. var RVData: TCustomRVFormattedData;
  221.     a,b: Integer;
  222. begin
  223.   if Ready then
  224.     exit;
  225.   inc(X, RichView1.HScrollPos);
  226.   inc(Y, RichView1.VScrollPos*RichView1.VSmallStep);
  227.   RichView1.GetItemAt(X, Y, RVData, a, b, False);
  228.   SelectCell(RVData);
  229. end;
  230. {------------------------------------------------------------------------------}
  231. // On hyperlink click.
  232. procedure TForm1.RichView1Jump(Sender: TObject; id: Integer);
  233. var i,r: Integer;
  234.     table: TRVTableItemInfo;
  235.     Score: Integer;
  236. begin
  237.   if not Ready then begin // clicking on "Ready!"
  238.     if AnsweredCount<High(Questions)+1 then begin
  239.       Beep;
  240.       exit;
  241.     end;
  242.     Ready := True;
  243.     HighlightCell(RichView1.RVData);
  244.     Score := 0;
  245.     for i := 0 to RichView1.ItemCount-1 do
  246.       if RichView1.GetItemStyle(i)=rvsTable then begin
  247.         table := RichView1.GetItem(i) as TRVTableItemInfo;
  248.          for r := 1 to table.Rows.Count-1 do
  249.            if table.Cells[r,0].Color=SELCOLOR then begin
  250.              if IntToStr(r-1)=RichView1.GetItemTextA(i) then begin
  251.                table.Cells[0,0].AddNL(' (passed)', 1,-1);
  252.                table.Cells[r,0].Color := PASSCOLOR;
  253.                inc(Score);
  254.                end
  255.              else begin
  256.                table.Cells[0,0].AddNL(' (failed)', 1,-1);
  257.                table.Cells[r,0].Color := FAILCOLOR;
  258.              end;
  259.            break;
  260.          end;
  261.       end;
  262.     RichView1.SetItemTextA(RichView1.ItemCount-1, 'Try again');
  263.     Caption := Format('PlanetQuiz : %d of %d', [Score, High(Questions)+1]);
  264.     RichView1.Format;
  265.     RichView1.Update;
  266.     if Score<>High(Questions)+1 then
  267.       SndPlaySound('CHORD.WAV', SND_SYNC or SND_NODEFAULT)
  268.     else
  269.       SndPlaySound('TADA.WAV', SND_SYNC or SND_NODEFAULT);
  270.     end
  271.   else begin // clicking on "Try Again"
  272.     BuildQuiz;
  273.     RichView1.ScrollTo(0);
  274.     Caption := 'PlanetQuiz';
  275.   end;
  276. end;
  277. end.