home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RXDICE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  9.0 KB  |  359 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. unit RXDice;
  13.  
  14. interface
  15.  
  16. {$I RX.INC}
  17.  
  18. uses SysUtils, {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  19.   Classes, Graphics, Messages, Controls, Forms, StdCtrls, ExtCtrls, Menus,
  20.   RxTimer, VCLUtils;
  21.  
  22. type
  23.   TRxDiceValue = 1..6;
  24.  
  25. { TRxDice }
  26.  
  27.   TRxDice = class(TCustomControl)
  28.   private
  29.     { Private declarations }
  30.     FActive: Boolean;
  31.     FAutoSize: Boolean;
  32.     FBitmap: TBitmap;
  33.     FInterval: Cardinal;
  34.     FAutoStopInterval: Cardinal;
  35.     FOnChange: TNotifyEvent;
  36.     FRotate: Boolean;
  37.     FShowFocus: Boolean;
  38.     FTimer: TRxTimer;
  39.     FTickCount: Longint;
  40.     FValue: TRxDiceValue;
  41.     FOnStart: TNotifyEvent;
  42.     FOnStop: TNotifyEvent;
  43.     procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
  44.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  45.     procedure CreateBitmap;
  46.     procedure SetInterval(Value: Cardinal);
  47.     procedure SetRotate(Value: Boolean);
  48.     procedure SetShowFocus(Value: Boolean);
  49.     procedure SetValue(Value: TRxDiceValue);
  50.     procedure TimerExpired(Sender: TObject);
  51.   protected
  52.     { Protected declarations }
  53.     procedure SetAutoSize(Value: Boolean); override;
  54.     function GetPalette: HPALETTE; override;
  55.     procedure AdjustSize; {$IFDEF RX_D4} override; {$ENDIF}
  56.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  57.       X, Y: Integer); override;
  58.     procedure Paint; override;
  59.     procedure Change; dynamic;
  60.     procedure DoStart; dynamic;
  61.     procedure DoStop; dynamic;
  62.   public
  63.     { Public declarations }
  64.     constructor Create(AOwner: TComponent); override;
  65.     destructor Destroy; override;
  66.     procedure RandomValue;
  67.   published
  68.     { Published declarations }
  69.     property Align;
  70.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  71.     property AutoStopInterval: Cardinal read FAutoStopInterval write FAutoStopInterval default 0;
  72.     property Color;
  73.     property Cursor;
  74.     property DragMode;
  75.     property DragCursor;
  76.     property Enabled;
  77.     property Interval: Cardinal read FInterval write SetInterval default 60;
  78.     property ParentColor;
  79.     property ParentShowHint;
  80.     property PopupMenu;
  81.     property Rotate: Boolean read FRotate write SetRotate;
  82.     property ShowFocus: Boolean read FShowFocus write SetShowFocus;
  83.     property ShowHint;
  84. {$IFDEF RX_D4}
  85.     property Anchors;
  86.     property Constraints;
  87.     property DragKind;
  88. {$ENDIF}
  89.     property TabOrder;
  90.     property TabStop;
  91.     property Value: TRxDiceValue read FValue write SetValue default 1;
  92.     property Visible;
  93.     property OnClick;
  94.     property OnDblClick;
  95.     property OnEnter;
  96.     property OnExit;
  97.     property OnMouseMove;
  98.     property OnMouseDown;
  99.     property OnMouseUp;
  100.     property OnKeyDown;
  101.     property OnKeyUp;
  102.     property OnKeyPress;
  103.     property OnDragOver;
  104.     property OnDragDrop;
  105.     property OnEndDrag;
  106. {$IFDEF WIN32}
  107.     property OnStartDrag;
  108. {$ENDIF}
  109. {$IFDEF RX_D5}
  110.     property OnContextPopup;
  111. {$ENDIF}
  112.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  113.     property OnStart: TNotifyEvent read FOnStart write FOnStart;
  114.     property OnStop: TNotifyEvent read FOnStop write FOnStop;
  115. {$IFDEF RX_D4}
  116.     property OnEndDock;
  117.     property OnStartDock;
  118. {$ENDIF}
  119.   end;
  120.  
  121. implementation
  122.  
  123. {$IFDEF WIN32}
  124.  {$R *.R32}
  125. {$ELSE}
  126.  {$R *.R16}
  127. {$ENDIF}
  128.  
  129. const
  130.   ResName: array [TRxDiceValue] of PChar =
  131.    ('DICE1', 'DICE2', 'DICE3', 'DICE4', 'DICE5', 'DICE6');
  132.  
  133. { TRxDice }
  134.  
  135. constructor TRxDice.Create(AOwner: TComponent);
  136. begin
  137.   inherited Create(AOwner);
  138.   Randomize;
  139.   ControlStyle := [csClickEvents, csSetCaption, csCaptureMouse,
  140.     csOpaque, csDoubleClicks];
  141.   FValue := 1;
  142.   FInterval := 60;
  143.   CreateBitmap;
  144.   FAutoSize := True;
  145.   Width := FBitmap.Width + 2;
  146.   Height := FBitmap.Height + 2;
  147. end;
  148.  
  149. destructor TRxDice.Destroy;
  150. begin
  151.   FOnChange := nil;
  152.   if FBitmap <> nil then FBitmap.Free;
  153.   inherited Destroy;
  154. end;
  155.  
  156. function TRxDice.GetPalette: HPALETTE;
  157. begin
  158.   if FBitmap <> nil then Result := FBitmap.Palette
  159.   else Result := 0;
  160. end;
  161.  
  162. procedure TRxDice.RandomValue;
  163. var
  164.   Val: Byte;
  165. begin
  166.   Val := Random(6) + 1;
  167.   if Val = Byte(FValue) then begin
  168.     if Val = 1 then Inc(Val)
  169.     else Dec(Val);
  170.   end;
  171.   SetValue(TRxDiceValue(Val));
  172. end;
  173.  
  174. procedure TRxDice.DoStart;
  175. begin
  176.   if Assigned(FOnStart) then FOnStart(Self);
  177. end;
  178.  
  179. procedure TRxDice.DoStop;
  180. begin
  181.   if Assigned(FOnStop) then FOnStop(Self);
  182. end;
  183.  
  184. procedure TRxDice.CMFocusChanged(var Message: TCMFocusChanged);
  185. var
  186.   Active: Boolean;
  187. begin
  188.   with Message do Active := (Sender = Self);
  189.   if Active <> FActive then begin
  190.     FActive := Active;
  191.     if FShowFocus then Invalidate;
  192.   end;
  193.   inherited;
  194. end;
  195.  
  196. procedure TRxDice.WMSize(var Message: TWMSize);
  197. begin
  198.   inherited;
  199. {$IFNDEF RX_D4}
  200.   AdjustSize;
  201. {$ENDIF}
  202. end;
  203.  
  204. procedure TRxDice.CreateBitmap;
  205. begin
  206.   if FBitmap = nil then FBitmap := TBitmap.Create;
  207.   FBitmap.Handle := LoadBitmap(HInstance, ResName[FValue]);
  208. end;
  209.  
  210. procedure TRxDice.AdjustSize;
  211. var
  212.   MinSide: Integer;
  213. begin
  214.   if not (csReading in ComponentState) then begin
  215.     if AutoSize and Assigned(FBitmap) and (FBitmap.Width > 0) and
  216.       (FBitmap.Height > 0) then
  217.         SetBounds(Left, Top, FBitmap.Width + 2, FBitmap.Height + 2)
  218.     else begin
  219.       { Adjust aspect ratio if control size changed }
  220.       MinSide := Width;
  221.       if Height < Width then MinSide := Height;
  222.       SetBounds(Left, Top, MinSide, MinSide);
  223.     end;
  224.   end;
  225. end;
  226.  
  227. procedure TRxDice.MouseDown(Button: TMouseButton;
  228.   Shift: TShiftState; X, Y: Integer);
  229. begin
  230.   if (Button = mbLeft) and TabStop and CanFocus then SetFocus;
  231.   inherited MouseDown(Button, Shift, X, Y);
  232. end;
  233.  
  234. procedure TRxDice.Paint;
  235. var
  236.   ARect: TRect;
  237.  
  238.   procedure DrawBitmap;
  239.   var
  240.     TmpImage: TBitmap;
  241.     IWidth, IHeight: Integer;
  242.     IRect: TRect;
  243.   begin
  244.     IWidth := FBitmap.Width;
  245.     IHeight := FBitmap.Height;
  246.     IRect := Rect(0, 0, IWidth, IHeight);
  247.     TmpImage := TBitmap.Create;
  248.     try
  249.       TmpImage.Width := IWidth;
  250.       TmpImage.Height := IHeight;
  251.       TmpImage.Canvas.Brush.Color := Self.Brush.Color;
  252.       TmpImage.Canvas.BrushCopy(IRect, FBitmap, IRect, FBitmap.TransparentColor);
  253.       InflateRect(ARect, -1, -1);
  254.       Canvas.StretchDraw(ARect, TmpImage);
  255.     finally
  256.       TmpImage.Free;
  257.     end;
  258.   end;
  259.  
  260. begin
  261.   ARect := ClientRect;
  262.   if FBitmap <> nil then DrawBitmap;
  263.   if Focused and FShowFocus and TabStop and not (csDesigning in ComponentState) then
  264.   begin
  265.     Canvas.DrawFocusRect(ARect);
  266.   end;
  267. end;
  268.  
  269. procedure TRxDice.TimerExpired(Sender: TObject);
  270. var
  271.   ParentForm: TCustomForm;
  272.   Now: Longint;
  273. begin
  274.   RandomValue;
  275.   if not FRotate then begin
  276.     FTimer.Free;
  277.     FTimer := nil;
  278.     if (csDesigning in ComponentState) then begin
  279.       ParentForm := GetParentForm(Self);
  280.       if ParentForm <> nil then ParentForm.Designer.Modified;
  281.     end;
  282.     DoStop;
  283.   end
  284.   else if AutoStopInterval > 0 then begin
  285.     Now := GetTickCount;
  286. {$IFDEF RX_D4}
  287.     if (Now - FTickCount >= Integer(AutoStopInterval))
  288. {$ELSE}
  289.     if (Now - FTickCount >= AutoStopInterval)
  290. {$ENDIF}
  291.       or (Now < FTickCount) then Rotate := False;
  292.   end;
  293. end;
  294.  
  295. procedure TRxDice.Change;
  296. begin
  297.   if Assigned(FOnChange) then FOnChange(Self);
  298. end;
  299.  
  300. procedure TRxDice.SetValue(Value: TRxDiceValue);
  301. begin
  302.   if FValue <> Value then begin
  303.     FValue := Value;
  304.     CreateBitmap;
  305.     Invalidate;
  306.     Change;
  307.   end;
  308. end;
  309.  
  310. procedure TRxDice.SetAutoSize(Value: Boolean);
  311. begin
  312.   inherited SetAutoSize(Value);
  313.   FAutoSize := Value;
  314.   AdjustSize;
  315.   Invalidate;
  316. end;
  317.  
  318. procedure TRxDice.SetInterval(Value: Cardinal);
  319. begin
  320.   if FInterval <> Value then begin
  321.     FInterval := Value;
  322.     if FTimer <> nil then FTimer.Interval := FInterval;
  323.   end;
  324. end;
  325.  
  326. procedure TRxDice.SetRotate(Value: Boolean);
  327. begin
  328.   if FRotate <> Value then begin
  329.     if Value then begin
  330.       if FTimer = nil then FTimer := TRxTimer.Create(Self);
  331.       try
  332.         with FTimer do begin
  333.           OnTimer := TimerExpired;
  334.           Interval := FInterval;
  335.           Enabled := True;
  336.         end;
  337.         FRotate := Value;
  338.         FTickCount := GetTickCount;
  339.         DoStart;
  340.       except
  341.         FTimer.Free;
  342.         FTimer := nil;
  343.         raise;
  344.       end;
  345.     end
  346.     else FRotate := Value;
  347.   end;
  348. end;
  349.  
  350. procedure TRxDice.SetShowFocus(Value: Boolean);
  351. begin
  352.   if FShowFocus <> Value then begin
  353.     FShowFocus := Value;
  354.     if not (csDesigning in ComponentState) then Invalidate;
  355.   end;
  356. end;
  357.  
  358. end.
  359.