1 unit uform;
2 
3 {$mode objfpc}{$H+}
4 
5 interface
6 
7 uses
8   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, Types;
9 
10 type
11 
12   { TFormMain }
13 
14   TFormMain = class(TForm)
15     Label1: TLabel;
16     Label2: TLabel;
17     Label3: TLabel;
18     Label4: TLabel;
19     Label5: TLabel;
20     Label6: TLabel;
21     Label7: TLabel;
22     Label8: TLabel;
23     Label9: TLabel;
24     ShapeButtonExtra2: TShape;
25     ShapeButtonLeft: TShape;
26     ShapeButtonExtra1: TShape;
27     ShapeButtonRight: TShape;
28     ShapeWheel: TShape;
29     ShapeWheelUp: TShape;
30     ShapeWheelDown: TShape;
31     ShapeWheelRight: TShape;
32     ShapeWheelLeft: TShape;
33     procedure FormCreate(Sender: TObject);
34     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
35       Shift: TShiftState; X, Y: Integer);
36     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
37       Shift: TShiftState; X, Y: Integer);
38     procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
39       MousePos: TPoint; var Handled: Boolean);
40     procedure FormMouseWheelLeft(Sender: TObject; Shift: TShiftState;
41       MousePos: TPoint; var Handled: Boolean);
42     procedure FormMouseWheelRight(Sender: TObject; Shift: TShiftState;
43       MousePos: TPoint; var Handled: Boolean);
44     procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
45       MousePos: TPoint; var Handled: Boolean);
46   private
47 
48   public
49 
50   end;
51 
52 var
53   FormMain: TFormMain;
54 
55 implementation
56 
57 {$R *.lfm}
58 
59 const
60   color_On = clGreen;
61   color_Off = clWhite;
62   cDelay = 100;
63 
64 procedure DoBlink(C: TShape);
65 begin
66   C.Brush.Color:= color_On;
67   Application.ProcessMessages;
68   Sleep(cDelay);
69   C.Brush.Color:= color_Off;
70 end;
71 
72 { TFormMain }
73 
74 procedure TFormMain.FormCreate(Sender: TObject);
75 var
76   i: integer;
77 begin
78   for i:= 0 to ControlCount-1 do
79     if Controls[i] is TShape then
80     begin
81       (Controls[i] as TShape).OnMouseDown:= Self.OnMouseDown;
82       (Controls[i] as TShape).OnMouseUp:= Self.OnMouseUp;
83       (Controls[i] as TShape).OnMouseWheelUp:= Self.OnMouseWheelUp;
84       (Controls[i] as TShape).OnMouseWheelDown:= Self.OnMouseWheelDown;
85       (Controls[i] as TShape).OnMouseWheelLeft:= Self.OnMouseWheelLeft;
86       (Controls[i] as TShape).OnMouseWheelRight:= Self.OnMouseWheelRight;
87     end;
88 end;
89 
90 procedure TFormMain.FormMouseDown(Sender: TObject; Button: TMouseButton;
91   Shift: TShiftState; X, Y: Integer);
92 begin
93   case Button of
94     mbLeft:
95       ShapeButtonLeft.Brush.Color:= color_On;
96     mbRight:
97       ShapeButtonRight.Brush.Color:= color_On;
98     mbMiddle:
99       ShapeWheel.Brush.Color:= color_On;
100     mbExtra1:
101       ShapeButtonExtra1.Brush.Color:= color_On;
102     mbExtra2:
103       ShapeButtonExtra2.Brush.Color:= color_On;
104   end;
105 end;
106 
107 procedure TFormMain.FormMouseUp(Sender: TObject; Button: TMouseButton;
108   Shift: TShiftState; X, Y: Integer);
109 begin
110   case Button of
111     mbLeft:
112       ShapeButtonLeft.Brush.Color:= color_Off;
113     mbRight:
114       ShapeButtonRight.Brush.Color:= color_Off;
115     mbMiddle:
116       ShapeWheel.Brush.Color:= color_Off;
117     mbExtra1:
118       ShapeButtonExtra1.Brush.Color:= color_Off;
119     mbExtra2:
120       ShapeButtonExtra2.Brush.Color:= color_Off;
121   end;
122 end;
123 
124 procedure TFormMain.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
125   MousePos: TPoint; var Handled: Boolean);
126 begin
127   DoBlink(ShapeWheelDown);
128 end;
129 
130 procedure TFormMain.FormMouseWheelLeft(Sender: TObject; Shift: TShiftState;
131   MousePos: TPoint; var Handled: Boolean);
132 begin
133   DoBlink(ShapeWheelLeft);
134 end;
135 
136 procedure TFormMain.FormMouseWheelRight(Sender: TObject; Shift: TShiftState;
137   MousePos: TPoint; var Handled: Boolean);
138 begin
139   DoBlink(ShapeWheelRight);
140 end;
141 
142 procedure TFormMain.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
143   MousePos: TPoint; var Handled: Boolean);
144 begin
145   DoBlink(ShapeWheelUp);
146 end;
147 
148 end.
149 
150