开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
VrDesign.pas
资源名称：varian_led_studio_3.34.rar　[点击查看]
上传用户：hbszzs
上传日期：2008-08-20
资源大小：628k
文件大小：48k
源码类别：

Delphi控件源码

开发平台：

Delphi

VrDesign.pas：源码内容
  1. {*****************************************************}
  2. {                                                     }
  3. {     Varian Component Workshop                       }
  4. {                                                     }
  5. {     Varian Software NL (c) 1996-2000                }
  6. {     All Rights Reserved                             }
  7. {                                                     }
  8. {*****************************************************}
  10. unit VrDesign;
  12. {$I VRLIB.INC}
  14. interface
  16. uses
  17.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  18.   VrTypes, VrClasses, VrControls, VrSystem, VrSysUtils;
  21. type
  22.   TVrBitmapButton = class(TVrGraphicImageControl)
  23.   private
  24.     FAutoSize: Boolean;
  25.     FGlyph: TBitmap;
  26.     FMask: TBitmap;
  27.     FNumGlyphs: TVrNumGlyphs;
  28.     FImageWidth: Integer;
  29.     FImageHeight: Integer;
  30.     FVIndent: Integer;
  31.     FHIndent: Integer;
  32.     FHasMouse: Boolean;
  33.     FTransparentMode: TVrTransparentMode;
  34.     Down: Boolean;
  35.     Pressed: Boolean;
  36.     function InControl(X, Y: Integer): Boolean;
  37.     procedure SetGlyph(Value: TBitmap);
  38.     procedure SetNumGlyphs(Value: TVrNumGlyphs);
  39.     procedure SetVIndent(Value: Integer);
  40.     procedure SetHIndent(Value: Integer);
  41.     procedure SetAutoSize(Value: Boolean);
  42.     procedure SetTransparentMode(Value: TVrTransparentMode);
  43.     procedure GlyphChanged(Sender: TObject);
  44.     procedure DoMouseDown(XPos, YPos: Integer);
  45.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LButtonDown;
  46.     procedure WMMouseMove(var Message: TWMMouseMove); message WM_MouseMove;
  47.     procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LButtonUp;
  48.     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  49.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  50.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  51.   protected
  52.     function GetPalette: HPalette; override;
  53.     procedure Loaded; override;
  54.     procedure Paint; override;
  55.     procedure AdjustBounds;
  56.     procedure AdjustImageSize;
  57.     function DestRect: TRect;
  58.     function GetImageRect(Index: Integer): TRect;
  59.     function GetTransparentColor: TColor;
  60.   public
  61.     constructor Create(AOwner: TComponent); override;
  62.     destructor Destroy; override;
  63.   published
  64.     property Glyph: TBitmap read FGlyph write SetGlyph;
  65.     property NumGlyphs: TVrNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
  66.     property VIndent: Integer read FVIndent write SetVIndent default 2;
  67.     property HIndent: Integer read FHIndent write SetHIndent default 2;
  68.     property AutoSize: Boolean read FAutoSize write SetAutoSize default false;
  69.     property TransparentMode: TVrTransparentMode read FTransparentMode write SetTransparentMode default tmColor;
  70.     property Transparent default false;
  71.     property Align;
  72. {$IFDEF VER110}
  73.     property Anchors;
  74.     property Constraints;
  75. {$ENDIF}
  76.     property Color default clBtnFace;
  77.     property DragCursor;
  78. {$IFDEF VER110}
  79.     property DragKind;
  80. {$ENDIF}
  81.     property DragMode;
  82.     property Enabled;
  83.     property Hint;
  84.     property ParentColor default false;
  85.     property ParentShowHint;
  86.     property PopupMenu;
  87.     property ShowHint;
  88.     property Visible;
  89.     property OnClick;
  90. {$IFDEF VER130}
  91.     property OnContextPopup;
  92. {$ENDIF}
  93.     property OnDragDrop;
  94.     property OnDragOver;
  95. {$IFDEF VER110}
  96.     property OnEndDock;
  97. {$ENDIF}
  98.     property OnEndDrag;
  99.     property OnMouseDown;
  100.     property OnMouseMove;
  101.     property OnMouseUp;
  102. {$IFDEF VER110}
  103.     property OnStartDock;
  104. {$ENDIF}
  105.     property OnStartDrag;
  106.   end;
  108.   TVrBitmapImage = class(TVrGraphicImageControl)
  109.   private
  110.     FAutoSize: Boolean;
  111.     FCenter: Boolean;
  112.     FStretch: Boolean;
  113.     FBitmapIndex: Integer;
  114.     FBitmap: TBitmap;
  115.     FBitmapList: TVrBitmapList;
  116.     FBitmapListLink: TVrChangeLink;
  117.     function GetBitmap: TBitmap;
  118.     procedure SetAutoSize(Value: Boolean);
  119.     procedure SetCenter(Value: Boolean);
  120.     procedure SetStretch(Value: Boolean);
  121.     procedure SetBitmapIndex(Value: Integer);
  122.     procedure SetBitmapList(Value: TVrBitmapList);
  123.     procedure BitmapListChanged(Sender: TObject);
  124.   protected
  125.     function GetPalette: HPALETTE; override;
  126.     function DestRect: TRect;
  127.     procedure AdjustBounds;
  128.     procedure Paint; override;
  129.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  130.   public
  131.     constructor Create(AOwner: TComponent); override;
  132.     destructor Destroy; override;
  133.   published
  134.     property AutoSize: Boolean read FAutoSize write SetAutoSize default false;
  135.     property Center: Boolean read FCenter write SetCenter default True;
  136.     property Stretch: Boolean read FStretch write SetStretch default false;
  137.     property BitmapIndex: Integer read FBitmapIndex write SetBitmapIndex default -1;
  138.     property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
  139.     property Transparent default false;
  140.     property Align;
  141. {$IFDEF VER110}
  142.     property Anchors;
  143.     property Constraints;
  144. {$ENDIF}
  145.     property Color default clBlack;
  146.     property DragCursor;
  147. {$IFDEF VER110}
  148.     property DragKind;
  149. {$ENDIF}
  150.     property DragMode;
  151.     property Hint;
  152.     property ParentColor default false;
  153.     property ParentShowHint;
  154.     property PopupMenu;
  155.     property ShowHint;
  156.     property Visible;
  157.     property OnClick;
  158. {$IFDEF VER130}
  159.     property OnContextPopup;
  160. {$ENDIF}    
  161.     property OnDblClick;    
  162.     property OnDragDrop;
  163.     property OnDragOver;
  164. {$IFDEF VER110}
  165.     property OnEndDock;
  166. {$ENDIF}
  167.     property OnEndDrag;
  168.     property OnMouseDown;
  169.     property OnMouseMove;
  170.     property OnMouseUp;
  171. {$IFDEF VER110}
  172.     property OnStartDock;
  173. {$ENDIF}
  174.     property OnStartDrag;
  175.   end;
  177.   TVrCounterDigits = 1..10;
  178.   TVrCounterValue = 0..MaxInt;
  179.   TVrCounter = class(TVrGraphicImageControl)
  180.   private
  181.     FValue: TVrCounterValue;
  182.     FDigits: TVrCounterDigits;
  183.     FAutoSize: Boolean;
  184.     FBitmap: TBitmap;
  185.     FSpacing: Integer;
  186.     FDigitSize: TPoint;
  187.     FStretch: Boolean;
  188.     FOnChange: TNotifyEvent;
  189.     FImage: TBitmap;
  190.     procedure SetValue(Value: TVrCounterValue);
  191.     procedure SetDigits(Value: TVrCounterDigits);
  192.     procedure SetAutoSize(Value: Boolean);
  193.     procedure SetBitmap(Value: TBitmap);
  194.     procedure SetSpacing(Value: Integer);
  195.     procedure SetStretch(Value: Boolean);
  196.     procedure BitmapChanged(Sender: TObject);
  197.   protected
  198.     function GetPalette: HPalette; override;
  199.     procedure CalcPaintParams;
  200.     procedure Paint; override;
  201.     procedure Changed; virtual;
  202.   public
  203.     constructor Create(AOwner: TComponent); override;
  204.     destructor Destroy; override;
  205.   published
  206.     property Value: TVrCounterValue read FValue write SetValue default 0;
  207.     property Digits: TVrCounterDigits read FDigits write SetDigits default 8;
  208.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  209.     property Bitmap: TBitmap read FBitmap write SetBitmap;
  210.     property Spacing: Integer read FSpacing write SetSpacing default 0;
  211.     property Stretch: Boolean read FStretch write SetStretch default false;
  212.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  213.     property Transparent default false;
  214. {$IFDEF VER110}
  215.     property Anchors;
  216.     property Constraints;
  217. {$ENDIF}
  218.     property Color default clBlack;
  219.     property DragCursor;
  220. {$IFDEF VER110}
  221.     property DragKind;
  222. {$ENDIF}
  223.     property DragMode;
  224.     property Hint;
  225.     property ParentColor default false;
  226.     property ParentShowHint;
  227.     property PopupMenu;
  228.     property ShowHint;
  229.     property Visible;
  230.     property OnClick;
  231. {$IFDEF VER130}
  232.     property OnContextPopup;
  233. {$ENDIF}
  234.     property OnDblClick;    
  235.     property OnDragDrop;
  236.     property OnDragOver;
  237. {$IFDEF VER110}
  238.     property OnEndDock;
  239. {$ENDIF}
  240.     property OnEndDrag;
  241.     property OnMouseDown;
  242.     property OnMouseMove;
  243.     property OnMouseUp;
  244. {$IFDEF VER110}
  245.     property OnStartDock;
  246. {$ENDIF}
  247.     property OnStartDrag;
  248.   end;
  250.   TVrCheckBoxState = (vcbUnchecked, vcbChecked, vcbGrayed);
  251.   TVrCheckBoxGlyphs = 1..3;
  252.   TVrCheckBoxTexture = (cbtTile, cbtStretch);
  253.   TVrBitmapCheckBox = class(TVrCustomImageControl)
  254.   private
  255.     FSpacing: Integer;
  256.     FMargin: Integer;
  257.     FLayout: TVrImageTextLayout;
  258.     FState: TVrCheckBoxState;
  259.     FNumGlyphs: TVrCheckBoxGlyphs;
  260.     FEnabledGlyphs: TBitmap;
  261.     FEnabledGlyphIndex: Integer;
  262.     FDisabledGlyphs: TBitmap;
  263.     FDisabledGlyphIndex: Integer;
  264.     FTransparentColor: TColor;
  265.     FTextureIndex: Integer;
  266.     FTextureStyle: TVrCheckBoxTexture;
  267.     FAllowGrayed: Boolean;
  268.     FFont3D: TVrFont3D;
  269.     FFocusColor: TColor;
  270.     FFocusOffset: Integer;
  271.     FFocused: Boolean;
  272.     FSize: TPoint;
  273.     FImageRect: TRect;
  274.     FTextBounds: TRect;
  275.     FBitmapList: TVrBitmapList;
  276.     FBitmapListLink: TVrChangeLink;
  277.     FButtonDown: Boolean;
  278.     FOnChange: TNotifyEvent;
  279.     function GetChecked: Boolean;
  280.     function GetBitmap(Index: Integer): TBitmap;
  281.     procedure SetLayout(Value: TVrImageTextLayout);
  282.     procedure SetMargin(Value: Integer);
  283.     procedure SetSpacing(Value: Integer);
  284.     procedure SetState(Value: TVrCheckBoxState);
  285.     procedure SetEnabledGlyphIndex(Value: Integer);
  286.     procedure SetDisabledGlyphIndex(Value: Integer);
  287.     procedure SetNumGlyphs(Value: TVrCheckBoxGlyphs);
  288.     procedure SetTransparentColor(Value: TColor);
  289.     procedure SetTextureIndex(Value: Integer);
  290.     procedure SetTextureStyle(Value: TVrCheckBoxTexture);
  291.     procedure SetFont3D(Value: TVrFont3D);
  292.     procedure SetBitmapList(Value: TVrBitmapList);
  293.     procedure SetChecked(Value: Boolean);
  294.     procedure SetFocusColor(Value: TColor);
  295.     procedure SetFocusOffset(Value: Integer);
  296.     procedure Font3DChanged(Sender: TObject);
  297.     procedure BitmapListChanged(Sender: TObject);
  298.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  299.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  300.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  301.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  302.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  303.     procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
  304.   protected
  305.     procedure CreateParams(var Params: TCreateParams); override;
  306.     procedure UpdateGlyphs;
  307.     procedure CalcPaintParams(Repaint: Boolean);
  308.     procedure Paint; override;
  309.     procedure Changed; dynamic;
  310.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  311.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  312.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  313.     procedure Keypress(var Key: Char); override;
  314.   public
  315.     constructor Create(AOwner: TComponent); override;
  316.     destructor Destroy; override;
  317.     procedure Toggle;
  318.   published
  319.     property Layout: TVrImageTextLayout read FLayout write SetLayout default ImageLeft;
  320.     property Margin: Integer read FMargin write SetMargin default -1;
  321.     property Spacing: Integer read FSpacing write SetSpacing default 5;
  322.     property State: TVrCheckBoxState read FState write SetState default vcbUnchecked;
  323.     property EnabledGlyphIndex: Integer read FEnabledGlyphIndex write SetEnabledGlyphIndex default -1;
  324.     property DisabledGlyphIndex: Integer read FDisabledGlyphIndex write SetDisabledGlyphIndex default -1;
  325.     property NumGlyphs: TVrCheckBoxGlyphs read FNumGlyphs write SetNumGlyphs default 3;
  326.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;
  327.     property Font3D: TVrFont3D read FFont3D write SetFont3D;
  328.     property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
  329.     property TextureIndex: Integer read FTextureIndex write SetTextureIndex default -1;
  330.     property TextureStyle: TVrCheckBoxTexture read FTextureStyle write SetTextureStyle default cbtTile;
  331.     property Checked: Boolean read GetChecked write SetChecked;
  332.     property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed default false;
  333.     property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
  334.     property FocusOffset: Integer read FFocusOffset write SetFocusOffset default 0;
  335.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  336. {$IFDEF VER110}
  337.     property Anchors;
  338.     property Constraints;
  339. {$ENDIF}
  340.     property Caption;
  341.     property Color;
  342.     property DragCursor;
  343. {$IFDEF VER110}
  344.     property DragKind;
  345. {$ENDIF}
  346.     property DragMode;
  347.     property Enabled;
  348.     property Font;
  349.     property ParentFont;
  350.     property ParentColor;
  351.     property ParentShowHint;
  352.     property PopupMenu;
  353.     property ShowHint;
  354.     property TabOrder;
  355.     property TabStop default false;
  356.     property Visible;
  357.     property OnClick;
  358. {$IFDEF VER130}
  359.     property OnContextPopup;
  360. {$ENDIF}
  361.     property OnDragDrop;
  362.     property OnDragOver;
  363. {$IFDEF VER110}
  364.     property OnEndDock;
  365. {$ENDIF}
  366.     property OnEndDrag;
  367.     property OnEnter;
  368.     property OnExit;
  369.     property OnKeyDown;
  370.     property OnKeyPress;
  371.     property OnKeyUp;
  372.     property OnMouseDown;
  373.     property OnMouseMove;
  374.     property OnMouseUp;
  375. {$IFDEF VER110}
  376.     property OnStartDock;
  377. {$ENDIF}
  378.     property OnStartDrag;
  379.   end;
  381.   TVrRadioButtonState = (vrbUnchecked, vrbChecked);
  382.   TVrRadioButtonGlyphs = 1..2;
  383.   TVrRadioButtonTexture = (rbtTile, rbtStretch);
  384.   TVrBitmapRadioButton = class(TVrCustomImageControl)
  385.   private
  386.     FChecked: Boolean;
  387.     FSpacing: Integer;
  388.     FMargin: Integer;
  389.     FLayout: TVrImageTextLayout;
  390.     FNumGlyphs: TVrRadioButtonGlyphs;
  391.     FEnabledGlyphs: TBitmap;
  392.     FEnabledGlyphIndex: Integer;
  393.     FDisabledGlyphs: TBitmap;
  394.     FDisabledGlyphIndex: Integer;
  395.     FTransparentColor: TColor;
  396.     FTextureIndex: Integer;
  397.     FTextureStyle: TVrRadioButtonTexture;
  398.     FFont3D: TVrFont3D;
  399.     FFocusColor: TColor;
  400.     FFocusOffset: Integer;
  401.     FFocused: Boolean;
  402.     FSize: TPoint;
  403.     FImageRect: TRect;
  404.     FTextBounds: TRect;
  405.     FBitmapList: TVrBitmapList;
  406.     FBitmapListLink: TVrChangeLink;
  407.     FButtonDown: Boolean;
  408.     FOnChange: TNotifyEvent;
  409.     function GetBitmap(Index: Integer): TBitmap;
  410.     procedure SetLayout(Value: TVrImageTextLayout);
  411.     procedure SetMargin(Value: Integer);
  412.     procedure SetSpacing(Value: Integer);
  413.     procedure SetEnabledGlyphIndex(Value: Integer);
  414.     procedure SetDisabledGlyphIndex(Value: Integer);
  415.     procedure SetNumGlyphs(Value: TVrRadioButtonGlyphs);
  416.     procedure SetTransparentColor(Value: TColor);
  417.     procedure SetTextureIndex(Value: Integer);
  418.     procedure SetTextureStyle(Value: TVrRadioButtonTexture);
  419.     procedure SetFont3D(Value: TVrFont3D);
  420.     procedure SetBitmapList(Value: TVrBitmapList);
  421.     procedure SetChecked(Value: Boolean);
  422.     procedure SetFocusColor(Value: TColor);
  423.     procedure SetFocusOffset(Value: Integer);
  424.     procedure Font3DChanged(Sender: TObject);
  425.     procedure BitmapListChanged(Sender: TObject);
  426.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  427.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  428.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  429.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  430.     procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
  431.     procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
  432.   protected
  433.     procedure CreateParams(var Params: TCreateParams); override;
  434.     procedure UpdateGlyphs;
  435.     procedure CalcPaintParams(Repaint: Boolean);
  436.     procedure Paint; override;
  437.     procedure Changed; dynamic;
  438.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  439.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  440.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  441.     procedure Keypress(var Key: Char); override;
  442.   public
  443.     constructor Create(AOwner: TComponent); override;
  444.     destructor Destroy; override;
  445.   published
  446.     property Layout: TVrImageTextLayout read FLayout write SetLayout default ImageLeft;
  447.     property Margin: Integer read FMargin write SetMargin default -1;
  448.     property Spacing: Integer read FSpacing write SetSpacing default 5;
  449.     property EnabledGlyphIndex: Integer read FEnabledGlyphIndex write SetEnabledGlyphIndex default -1;
  450.     property DisabledGlyphIndex: Integer read FDisabledGlyphIndex write SetDisabledGlyphIndex default -1;
  451.     property NumGlyphs: TVrRadioButtonGlyphs read FNumGlyphs write SetNumGlyphs default 2;
  452.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;
  453.     property Font3D: TVrFont3D read FFont3D write SetFont3D;
  454.     property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
  455.     property TextureIndex: Integer read FTextureIndex write SetTextureIndex default -1;
  456.     property TextureStyle: TVrRadioButtonTexture read FTextureStyle write SetTextureStyle default rbtTile;
  457.     property Checked: Boolean read FChecked write SetChecked default false;
  458.     property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
  459.     property FocusOffset: Integer read FFocusOffset write SetFocusOffset default 0;    
  460.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  461. {$IFDEF VER110}
  462.     property Anchors;
  463.     property Constraints;
  464. {$ENDIF}
  465.     property Caption;
  466.     property Color;
  467.     property DragCursor;
  468. {$IFDEF VER110}
  469.     property DragKind;
  470. {$ENDIF}
  471.     property DragMode;
  472.     property Enabled;
  473.     property Font;
  474.     property ParentFont;
  475.     property ParentColor;
  476.     property ParentShowHint;
  477.     property PopupMenu;
  478.     property ShowHint;
  479.     property TabOrder;
  480.     property TabStop default false;
  481.     property Visible;
  482.     property OnClick;
  483. {$IFDEF VER130}
  484.     property OnContextPopup;
  485. {$ENDIF}
  486.     property OnDragDrop;
  487.     property OnDragOver;
  488. {$IFDEF VER110}
  489.     property OnEndDock;
  490. {$ENDIF}
  491.     property OnEndDrag;
  492.     property OnEnter;
  493.     property OnExit;
  494.     property OnKeyDown;
  495.     property OnKeyPress;
  496.     property OnKeyUp;
  497.     property OnMouseDown;
  498.     property OnMouseMove;
  499.     property OnMouseUp;
  500. {$IFDEF VER110}
  501.     property OnStartDock;
  502. {$ENDIF}
  503.     property OnStartDrag;
  504.   end;
  507. implementation
  509. { TVrBitmapButton }
  511. constructor TVrBitmapButton.Create(AOwner: TComponent);
  512. begin
  513.   inherited Create(AOwner);
  514.   ControlStyle := ControlStyle + [csOpaque, csReplicatable] -
  515.     [csDoubleClicks, csSetCaption];
  516.   Width := 50;
  517.   Height := 50;
  518.   Color := clBtnFace;
  519.   ParentColor := false;
  520.   FGlyph := TBitmap.Create;
  521.   FGlyph.OnChange := GlyphChanged;
  522.   FMask := TBitmap.Create;
  523.   FNumGlyphs := 1;
  524.   FAutoSize := false;
  525.   FVIndent := 2;
  526.   FHIndent := 2;
  527.   FTransparentMode := tmColor;
  528. end;
  530. destructor TVrBitmapButton.Destroy;
  531. begin
  532.   FMask.Free;
  533.   FGlyph.Free;
  534.   inherited Destroy;
  535. end;
  537. procedure TVrBitmapButton.Loaded;
  538. begin
  539.   inherited Loaded;
  540.   AdjustImageSize;
  541.   FMask.Assign(Glyph);
  542.   FMask.Mask(Self.Color);
  543. end;
  545. procedure TVrBitmapButton.Paint;
  546. var
  547.   Index: Integer;
  548. begin
  549.   AdjustBounds;
  551.   ClearBitmapCanvas;
  553.   Index := 0;
  554.   if FHasMouse then Index := 1;
  555.   if Down then Index := 2;
  556.   if not Enabled then Index := 3;
  557.   if Succ(Index) > NumGlyphs then Index := 0;
  559.   if not Glyph.Empty then
  560.     with BitmapCanvas do
  561.     begin
  562.       if Transparent then Brush.Style := bsClear
  563.       else Brush.Style := bsSolid;
  564.       BrushCopy(DestRect, FGlyph, GetImageRect(Index), GetTransparentColor);
  565.     end;
  567.   ShowDesignFrame(BitmapCanvas);
  569.   inherited Paint;
  570. end;
  572. function TVrBitmapButton.GetTransparentColor: TColor;
  573. begin
  574.   Result := Self.Color;
  575.   if (not Glyph.Empty) and (TransparentMode = tmPixel) then
  576.     Result := Glyph.Canvas.Pixels[0,0];
  577. end;
  579. function TVrBitmapButton.GetPalette: HPALETTE;
  580. begin
  581.   Result := 0;
  582.   if not Glyph.Empty then
  583.     Result := Glyph.Palette;
  584. end;
  586. procedure TVrBitmapButton.AdjustImageSize;
  587. begin
  588.   FImageWidth := 0;
  589.   FImageHeight := 0;
  590.   if not Glyph.Empty then
  591.   begin
  592.     FImageWidth := Glyph.Width div NumGlyphs;
  593.     FImageHeight := Glyph.Height;
  594.   end;
  595. end;
  597. function TVrBitmapButton.GetImageRect(Index: Integer): TRect;
  598. begin
  599.   Result := Bounds(Index * FImageWidth, 0, FImageWidth, FImageHeight)
  600. end;
  602. procedure TVrBitmapButton.AdjustBounds;
  603. begin
  604.   if (AutoSize) and (Align = alNone) then
  605.     if (FImageWidth > 0) and (FImageHeight > 0) then
  606.       SetBounds(Left, Top, FImageWidth + HIndent + 1, FImageHeight + VIndent + 1);
  607. end;
  609. function TVrBitmapButton.DestRect: TRect;
  610. var
  611.   MidX, MidY: Integer;
  612. begin
  613.   MidX := (ClientWidth - FImageWidth) div 2;
  614.   MidY := (ClientHeight - FImageHeight) div 2;
  615.   Result := Bounds(MidX, MidY, FImageWidth, FImageHeight);
  616.   if Down then OffsetRect(Result, HIndent, VIndent);
  617. end;
  619. procedure TVrBitmapButton.GlyphChanged(Sender: TObject);
  620. begin
  621.   AdjustImageSize;
  622.   UpdateControlCanvas;
  623. end;
  625. procedure TVrBitmapButton.SetGlyph(Value: TBitmap);
  626. begin
  627.   FGlyph.Assign(Value);
  628.   FMask.Assign(Value);
  629.   FMask.Mask(Self.Color);
  630. end;
  632. procedure TVrBitmapButton.SetNumGlyphs(Value: TVrNumGlyphs);
  633. begin
  634.   if (FNumGlyphs <> Value) then
  635.   begin
  636.     FNumGlyphs := Value;
  637.     AdjustImageSize;
  638.     UpdateControlCanvas;
  639.   end;
  640. end;
  642. procedure TVrBitmapButton.SetVIndent(Value: Integer);
  643. begin
  644.   if (FVIndent <> Value) and (Value >= 0) then
  645.   begin
  646.     FVIndent := Value;
  647.     UpdateControlCanvas;
  648.   end;
  649. end;
  651. procedure TVrBitmapButton.SetHIndent(Value: Integer);
  652. begin
  653.   if (FHIndent <> Value) and (Value >= 0) then
  654.   begin
  655.     FHIndent := Value;
  656.     UpdateControlCanvas;
  657.   end;
  658. end;
  660. procedure TVrBitmapButton.SetAutoSize(Value: Boolean);
  661. begin
  662.   if FAutoSize <> Value then
  663.   begin
  664.     FAutoSize := Value;
  665.     UpdateControlCanvas;
  666.   end;
  667. end;
  669. procedure TVrBitmapButton.SetTransparentMode(Value: TVrTransparentMode);
  670. begin
  671.   if FTransparentMode <> Value then
  672.   begin
  673.     FTransparentMode := Value;
  674.     UpdateControlCanvas;
  675.   end;
  676. end;
  678. function TVrBitmapButton.InControl(X, Y: Integer): Boolean;
  679. var
  680.   R: TRect;
  681. begin
  682.   R := ClientRect;
  683.   Result := (PtInRect(R, Point(X, Y))) and
  684.             (FMask.Canvas.Pixels[X, Y] = clBlack);
  685. end;
  687. procedure TVrBitmapButton.DoMouseDown(XPos, YPos: Integer);
  688. begin
  689.   if InControl(XPos, YPos) then
  690.   begin
  691.     Pressed := True;
  692.     Down := True;
  693.     MouseCapture := true;
  694.     UpdateControlCanvas;
  695.   end;
  696. end;
  698. procedure TVrBitmapButton.WMLButtonDown(var Message: TWMLButtonDown);
  699. begin
  700.   inherited;
  701.   DoMouseDown(Message.XPos, Message.YPos);
  702. end;
  704. procedure TVrBitmapButton.WMMouseMove(var Message: TWMMouseMove);
  705. var
  706.   P: TPoint;
  707. begin
  708.   inherited;
  709.   if Pressed then
  710.   begin
  711.     P := Point(Message.XPos, Message.YPos);
  712.     if InControl(P.X, P.Y) <> Down then
  713.     begin
  714.       Down := not Down;
  715.       UpdateControlCanvas;
  716.     end;
  717.   end;
  718. end;
  720. procedure TVrBitmapButton.WMLButtonUp(var Message: TWMLButtonUp);
  721. var
  722.   DoClick: Boolean;
  723. begin
  724.   MouseCapture := false;
  725.   DoClick := Pressed and Down;
  726.   Down := false;
  727.   Pressed := false;
  728.   if DoClick then
  729.   begin
  730.     UpdateControlCanvas;
  731.     inherited; // Click;
  732.   end;
  733. end;
  735. procedure TVrBitmapButton.CMMouseEnter(var Message: TMessage);
  736. begin
  737.   inherited;
  738.   FHasMouse := True;
  739.   UpdateControlCanvas;
  740. end;
  742. procedure TVrBitmapButton.CMMouseLeave(var Message: TMessage);
  743. begin
  744.   inherited;
  745.   FHasMouse := false;
  746.   UpdateControlCanvas;
  747. end;
  749. procedure TVrBitmapButton.CMEnabledChanged(var Message: TMessage);
  750. begin
  751.   inherited;
  752.   UpdateControlCanvas;
  753. end;
  756. { TVrBitmapImage }
  758. constructor TVrBitmapImage.Create(AOwner: TComponent);
  759. begin
  760.   inherited Create(AOwner);
  761.   ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  762.   Width := 105;
  763.   Height := 105;
  764.   Color := clBtnFace;
  765.   ParentColor := false;
  766.   FAutoSize := false;
  767.   FCenter := True;
  768.   FStretch := false;
  769.   FBitmapIndex := -1;
  770.   FBitmapListLink := TVrChangeLink.Create;
  771.   FBitmapListLink.OnChange := BitmapListChanged;
  772. end;
  774. destructor TVrBitmapImage.Destroy;
  775. begin
  776.   FBitmapListLink.Free;
  777.   inherited Destroy;
  778. end;
  780. function TVrBitmapImage.GetBitmap: TBitmap;
  781. begin
  782.   Result := nil;
  783.   if Assigned(FBitmapList) then
  784.     Result := FBitmapList.GetBitmap(BitmapIndex);
  785. end;
  787. procedure TVrBitmapImage.SetBitmapList(Value: TVrBitmapList);
  788. begin
  789.   if FBitmapList <> nil then
  790.     FBitmapList.RemoveLink(FBitmapListLink);
  791.   FBitmapList := Value;
  792.   if FBitmapList <> nil then
  793.     FBitmapList.InsertLink(FBitmapListLink);
  794.   UpdateControlCanvas;
  795. end;
  797. procedure TVrBitmapImage.BitmapListChanged(Sender: TObject);
  798. begin
  799.   UpdateControlCanvas;
  800. end;
  802. function TVrBitmapImage.GetPalette: HPALETTE;
  803. begin
  804.   Result := 0;
  805.   if GetBitmap <> nil then
  806.     Result := GetBitmap.Palette;
  807. end;
  809. procedure TVrBitmapImage.Notification(AComponent: TComponent;
  810.   Operation: TOperation);
  811. begin
  812.   inherited Notification(AComponent, Operation);
  813.   if (Operation = opRemove) then
  814.     if AComponent = BitmapList then BitmapList := nil;
  815. end;
  817. function TVrBitmapImage.DestRect: TRect;
  818. begin
  819.   if Stretch then
  820.     Result := ClientRect
  821.   else if Center then
  822.     Result := Bounds((Width - FBitmap.Width) div 2, (Height - FBitmap.Height) div 2,
  823.       FBitmap.Width, FBitmap.Height)
  824.   else
  825.     Result := Rect(0, 0, FBitmap.Width, FBitmap.Height);
  826. end;
  828. procedure TVrBitmapImage.AdjustBounds;
  829. begin
  830.   if (AutoSize) and (Align = alNone) then
  831.     if (FBitmap.Width > 0) and (FBitmap.Height > 0) then
  832.       SetBounds(Left, Top, FBitmap.Width, FBitmap.Height);
  833. end;
  835. procedure TVrBitmapImage.Paint;
  836. begin
  837.   FBitmap := GetBitmap;
  838.   if FBitmap <> nil then AdjustBounds;
  839.   ClearBitmapCanvas;
  840.   if FBitmap <> nil then
  841.     with BitmapCanvas do
  842.     begin
  843.       if Transparent then Brush.Style := bsClear
  844.         else Brush.Style := bsSolid;
  845.       BrushCopy(DestRect, FBitmap, BitmapRect(FBitmap), Self.Color);
  846.     end;
  847.   ShowDesignFrame(BitmapCanvas);
  848.   inherited Paint;
  849. end;
  851. procedure TVrBitmapImage.SetAutoSize(Value: Boolean);
  852. begin
  853.   if FAutoSize <> Value then
  854.   begin
  855.     FAutoSize := Value;
  856.     UpdateControlCanvas;
  857.   end;
  858. end;
  860. procedure TVrBitmapImage.SetCenter(Value: Boolean);
  861. begin
  862.   if FCenter <> Value then
  863.   begin
  864.     FCenter := Value;
  865.     UpdateControlCanvas;
  866.   end;
  867. end;
  869. procedure TVrBitmapImage.SetStretch(Value: Boolean);
  870. begin
  871.   if FStretch <> Value then
  872.   begin
  873.     FStretch := Value;
  874.     UpdateControlCanvas;
  875.   end;
  876. end;
  878. procedure TVrBitmapImage.SetBitmapIndex(Value: Integer);
  879. begin
  880.   if FBitmapIndex <> Value then
  881.   begin
  882.     FBitmapIndex := Value;
  883.     UpdateControlCanvas;
  884.   end;
  885. end;
  887. { TVrCounter }
  889. constructor TVrCounter.Create(AOwner: TComponent);
  890. begin
  891.   inherited Create(AOwner);
  892.   ControlStyle := ControlStyle + [csOpaque];
  893.   Width := 150;
  894.   Height := 25;
  895.   Color := clBtnFace;
  896.   ParentColor := false;
  897.   Transparent := false;
  898.   FValue := 0;
  899.   FDigits := 8;
  900.   FAutoSize := True;
  901.   FSpacing := 0;
  902.   FStretch := false;
  903.   FBitmap := TBitmap.Create;
  904.   FBitmap.OnChange := BitmapChanged;
  905.   FImage := TBitmap.Create;
  906. end;
  908. destructor TVrCounter.Destroy;
  909. begin
  910.   FImage.Free;
  911.   FBitmap.Free;
  912.   inherited Destroy;
  913. end;
  915. procedure TVrCounter.Changed;
  916. begin
  917.   if Assigned(FOnChange) then FOnChange(Self);
  918. end;
  920. procedure TVrCounter.BitmapChanged(Sender: TObject);
  921. begin
  922.   UpdateControlCanvas;
  923. end;
  925. procedure TVrCounter.Paint;
  926. var
  927.   str: string;
  928.   I, V, MidX, MidY: Integer;
  929. begin
  930.   CalcPaintParams;
  931.   ClearBitmapCanvas;
  933.   with FImage, FImage.Canvas do
  934.   begin
  935.     Brush.Color := Self.Color;
  936.     Brush.Style := bsSolid;
  937.     FillRect(Bounds(0, 0, Width, Height));
  938.   end;
  940.   MidX := 0;
  941.   MidY := 0;
  942.   if not Bitmap.Empty then
  943.   begin
  944.     str := Format('%.' + IntToStr(Digits) + 'd', [Value]);
  945.     for I := 1 to Length(str) do
  946.     begin
  947.       V := StrToInt(str[I]);
  948.       FImage.Canvas.BrushCopy(Bounds(MidX, MidY, FDigitSize.X, FDigitSize.Y),
  949.         Bitmap, Bounds(V * FDigitSize.X, 0, FDigitSize.X, FDigitSize.Y),
  950.         Self.Color);
  951.       Inc(MidX, FSpacing + FDigitSize.X);
  952.     end;
  953.   end;
  955.   if Transparent then BitmapCanvas.Brush.Style := bsClear
  956.     else BitmapCanvas.Brush.Style := bsSolid;
  958.   if (Stretch) and (not AutoSize) then
  959.     BitmapCanvas.BrushCopy(ClientRect, FImage,
  960.       BitmapRect(FImage), Self.Color)
  961.   else
  962.   begin
  963.     MidX := (ClientWidth - FImage.Width) div 2;
  964.     MidY := (ClientHeight - FImage.Height) div 2;
  965.     BitmapCanvas.BrushCopy(Bounds(MidX, MidY, FImage.Width, FImage.Height),
  966.       FImage, BitmapRect(FImage), Self.Color);
  967.   end;
  968.   ShowDesignFrame(BitmapCanvas);
  969.   inherited Paint;
  970. end;
  972. procedure TVrCounter.CalcPaintParams;
  973. begin
  974.   if not Bitmap.Empty then
  975.   begin
  976.     FDigitSize.X := Bitmap.Width div 10;
  977.     FDigitSize.Y := Bitmap.Height;
  978.     FImage.Width := (Spacing * Pred(Digits)) + (FDigitSize.X * Digits);
  979.     FImage.Height := Bitmap.Height;
  980.     if AutoSize then
  981.       BoundsRect := Bounds(Left, Top, FImage.Width, FImage.Height);
  982.   end;
  983. end;
  985. function TVrCounter.GetPalette: HPalette;
  986. begin
  987.   if FBitmap.Empty then Result := inherited GetPalette
  988.   else Result := FBitmap.Palette;
  989. end;
  991. procedure TVrCounter.SetValue(Value: TVrCounterValue);
  992. begin
  993.   if FValue <> Value then
  994.   begin
  995.     FValue := Value;
  996.     UpdateControlCanvas;
  997.     Changed;
  998.   end;
  999. end;
  1001. procedure TVrCounter.SetDigits(Value: TVrCounterDigits);
  1002. begin
  1003.   if FDigits <> Value then
  1004.   begin
  1005.     FDigits := Value;
  1006.     UpdateControlCanvas;
  1007.   end;
  1008. end;
  1010. procedure TVrCounter.SetAutoSize(Value: Boolean);
  1011. begin
  1012.   if FAutoSize <> Value then
  1013.   begin
  1014.     FAutoSize := Value;
  1015.     UpdateControlCanvas;
  1016.   end;
  1017. end;
  1019. procedure TVrCounter.SetBitmap(Value: TBitmap);
  1020. begin
  1021.   FBitmap.Assign(Value);
  1022. end;
  1024. procedure TVrCounter.SetSpacing(Value: Integer);
  1025. begin
  1026.   if FSpacing <> Value then
  1027.   begin
  1028.     FSpacing := Value;
  1029.     UpdateControlCanvas;
  1030.   end;
  1031. end;
  1033. procedure TVrCounter.SetStretch(Value: Boolean);
  1034. begin
  1035.   if FStretch <> Value then
  1036.   begin
  1037.     FStretch := Value;
  1038.     UpdateControlCanvas;
  1039.   end;
  1040. end;
  1042. { TVrBitmapCheckBox }
  1044. constructor TVrBitmapCheckBox.Create(AOwner: TComponent);
  1045. begin
  1046.   inherited Create(AOwner);
  1047.   ControlStyle := ControlStyle + [csOpaque, csSetCaption] - [csDoubleClicks];
  1048.   Width := 140;
  1049.   Height := 17;
  1050.   TabStop := false;
  1051.   FSpacing := 5;
  1052.   FMargin := -1;
  1053.   FLayout := ImageLeft;
  1054.   FState := vcbUnchecked;
  1055.   FTransparentColor := clOlive;
  1056.   FTextureIndex := -1;
  1057.   FTextureStyle := cbtTile;
  1058.   FAllowGrayed := false;
  1059.   FFocusColor := clBlue;
  1060.   FFocusOffset := 0;
  1061.   FNumGlyphs := 3;
  1062.   FFont3D := TVrFont3D.Create;
  1063.   FFont3D.OnChange := Font3DChanged;
  1064.   FEnabledGlyphIndex := -1;
  1065.   FDisabledGlyphIndex := -1;
  1066.   FBitmapListLink := TVrChangeLink.Create;
  1067.   FBitmapListLink.OnChange := BitmapListChanged;
  1068. end;
  1070. destructor TVrBitmapCheckBox.Destroy;
  1071. begin
  1072.   FFont3D.Free;
  1073.   FBitmapListLink.Free;
  1074.   inherited Destroy;
  1075. end;
  1077. procedure TVrBitmapCheckBox.CreateParams(var Params: TCreateParams);
  1078. begin
  1079.   inherited CreateParams(Params);
  1080.   with Params do
  1081.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1082. end;
  1084. procedure TVrBitmapCheckBox.UpdateGlyphs;
  1085. var
  1086.   NewX, NewY: Integer;
  1087. begin
  1088.   FEnabledGlyphs := GetBitmap(FEnabledGlyphIndex);
  1089.   FDisabledGlyphs := GetBitmap(FDisabledGlyphIndex);
  1090.   NewX := -1;
  1091.   NewY := -1;
  1092.   FSize.X := 0;
  1093.   FSize.Y := 0;
  1094.   if FEnabledGlyphs <> nil then
  1095.   begin
  1096.     FSize.X := FEnabledGlyphs.Width div NumGlyphs;
  1097.     FSize.Y := FEnabledGlyphs.Height;
  1098.   end;
  1099.   if FDisabledGlyphs <> nil then
  1100.   begin
  1101.     NewX := FDisabledGlyphs.Width div NumGlyphs;
  1102.     NewY := FDisabledGlyphs.Height;
  1103.   end;
  1104.   if NewX > FSize.X then FSize.X := NewX;
  1105.   if NewY > FSize.Y then FSize.Y := NewY;
  1106. end;
  1108. procedure TVrBitmapCheckBox.Paint;
  1109. var
  1110.   Index, X, Y: Integer;
  1111.   iWidth, iHeight: Integer;
  1112.   R: TRect;
  1113.   BackImage, Glyphs: TBitmap;
  1114. begin
  1115.   BackImage := GetBitmap(FTextureIndex);
  1116.   if BackImage = nil then ClearBitmapCanvas
  1117.   else
  1118.   begin
  1119.     if TextureStyle = cbtTile then
  1120.       DrawTiledBitmap(BitmapCanvas, ClientRect, BackImage)
  1121.     else BitmapCanvas.CopyRect(ClientRect, BackImage.Canvas, BitmapRect(BackImage));
  1122.   end;
  1124.   if (Enabled) or (FDisabledGlyphs = nil) then
  1125.     Glyphs := FEnabledGlyphs
  1126.   else Glyphs := FDisabledGlyphs;
  1128.   with BitmapCanvas do
  1129.   begin
  1130.     Index := Ord(State); //0, 1 or 2
  1131.     if (Glyphs <> nil) and (Index < NumGlyphs) then
  1132.     begin
  1133.       iWidth := Glyphs.Width div NumGlyphs;
  1134.       iHeight := Glyphs.Height;
  1135.       X := (WidthOf(FImageRect) - iWidth) div 2;
  1136.       Y := (HeightOf(FImageRect) - iHeight) div 2;
  1138.       R := Bounds(FImageRect.Left + X, FImageRect.Top + Y, iWidth, iHeight);
  1140.       Brush.Style := bsClear;
  1141.       BrushCopy(R, Glyphs,
  1142.         Bounds(Index * iWidth, 0, iWidth, iHeight), TransparentColor);
  1143.     end;
  1145.     Font := Self.Font;
  1146.     FFont3D.Paint(BitmapCanvas, FTextBounds, Caption,
  1147.       DT_LEFT or DT_VCENTER or DT_SINGLELINE);
  1149.     if (Focused) and (FocusOffset > -1) then
  1150.     begin
  1151.       R := ClientRect;
  1152.       InflateRect(R, -FocusOffset, -FocusOffset);
  1153.       Brush.Color := FocusColor;
  1154.       FrameRect(R);
  1155.     end;
  1156.   end;
  1158.   inherited Paint;
  1159. end;
  1161. procedure TVrBitmapCheckBox.CalcPaintParams(Repaint: Boolean);
  1162. var
  1163.   ImagePos: TPoint;
  1164. begin
  1165.   UpdateGlyphs;
  1166.   Canvas.Font.Assign(Self.Font);
  1167.   CalcImageTextLayout(Canvas, ClientRect, Point(1, 1), Caption, FLayout,
  1168.     FMargin, FSpacing, Point(FSize.X, FSize.Y), ImagePos, FTextBounds);
  1169.   FImageRect := Bounds(ImagePos.X, ImagePos.Y, FSize.X, FSize.Y);
  1170.   if Repaint then UpdateControlCanvas;
  1171. end;
  1173. procedure TVrBitmapCheckBox.WMSize(var Message: TMessage);
  1174. begin
  1175.   inherited;
  1176.   CalcPaintParams(True);
  1177. end;
  1179. procedure TVrBitmapCheckBox.CMFontChanged(var Message: TMessage);
  1180. begin
  1181.   inherited;
  1182.   CalcPaintParams(True);
  1183. end;
  1185. procedure TVrBitmapCheckBox.CMTextChanged(var Message: TMessage);
  1186. begin
  1187.   inherited;
  1188.   if HandleAllocated then
  1189.     CalcPaintParams(True);
  1190. end;
  1192. procedure TVrBitmapCheckBox.CMEnabledChanged(var Message: TMessage);
  1193. begin
  1194.   inherited;
  1195.   UpdateControlCanvas;
  1196. end;
  1198. procedure TVrBitmapCheckBox.CMDialogChar(var Message: TCMDialogChar);
  1199. begin
  1200.   with Message do
  1201.     if IsAccel(CharCode, Caption) and CanFocus then
  1202.     begin
  1203.       SetFocus;
  1204.       if Focused then Toggle;
  1205.       Result := 1;
  1206.     end else inherited;
  1207. end;
  1209. procedure TVrBitmapCheckBox.CMFocusChanged(var Message: TCMFocusChanged);
  1210. var
  1211.   Active: Boolean;
  1212. begin
  1213.   with Message do Active := (Sender = Self);
  1214.   if Active <> FFocused then
  1215.   begin
  1216.     FFocused := Active;
  1217.     UpdateControlCanvas;
  1218.   end;
  1219.   inherited;
  1220. end;
  1222. procedure TVrBitmapCheckBox.Notification(AComponent: TComponent;
  1223.   Operation: TOperation);
  1224. begin
  1225.   inherited Notification(AComponent, Operation);
  1226.   if (Operation = opRemove) then
  1227.     if AComponent = BitmapList then BitmapList := nil;
  1228. end;
  1230. function TVrBitmapCheckBox.GetBitmap(Index: Integer): TBitmap;
  1231. begin
  1232.   Result := nil;
  1233.   if Assigned(FBitmapList) then
  1234.     Result := FBitmapList.GetBitmap(Index);
  1235. end;
  1237. procedure TVrBitmapCheckBox.SetBitmapList(Value: TVrBitmapList);
  1238. begin
  1239.   if FBitmapList <> nil then
  1240.     FBitmapList.RemoveLink(FBitmapListLink);
  1241.   FBitmapList := Value;
  1242.   if FBitmapList <> nil then
  1243.     FBitmapList.InsertLink(FBitmapListLink);
  1244.   CalcPaintParams(True);
  1245. end;
  1247. procedure TVrBitmapCheckBox.BitmapListChanged(Sender: TObject);
  1248. begin
  1249.   CalcPaintParams(True);
  1250. end;
  1252. procedure TVrBitmapCheckBox.SetEnabledGlyphIndex(Value: Integer);
  1253. begin
  1254.   if FEnabledGlyphIndex <> Value then
  1255.   begin
  1256.     FEnabledGlyphIndex := Value;
  1257.     CalcPaintParams(True);
  1258.   end;
  1259. end;
  1261. procedure TVrBitmapCheckBox.SetDisabledGlyphIndex(Value: Integer);
  1262. begin
  1263.   if FDisabledGlyphIndex <> Value then
  1264.   begin
  1265.     FDisabledGlyphIndex := Value;
  1266.     CalcPaintParams(True);
  1267.   end;
  1268. end;
  1270. procedure TVrBitmapCheckBox.Font3DChanged(Sender: TObject);
  1271. begin
  1272.   UpdateControlCanvas;
  1273. end;
  1275. procedure TVrBitmapCheckBox.SetFont3D(Value: TVrFont3D);
  1276. begin
  1277.   FFont3D.Assign(Value);
  1278. end;
  1280. procedure TVrBitmapCheckBox.SetLayout(Value: TVrImageTextLayout);
  1281. begin
  1282.   if FLayout <> Value then
  1283.   begin
  1284.     FLayout := Value;
  1285.     CalcPaintParams(True);
  1286.   end;
  1287. end;
  1289. procedure TVrBitmapCheckBox.SetMargin(Value: Integer);
  1290. begin
  1291.   if FMargin <> Value then
  1292.   begin
  1293.     FMargin := Value;
  1294.     CalcPaintParams(True);
  1295.   end;
  1296. end;
  1298. procedure TVrBitmapCheckBox.SetSpacing(Value: Integer);
  1299. begin
  1300.   if FSpacing <> Value then
  1301.   begin
  1302.     FSpacing := Value;
  1303.     CalcPaintParams(True);
  1304.   end;
  1305. end;
  1307. procedure TVrBitmapCheckBox.SetState(Value: TVrCheckBoxState);
  1308. begin
  1309.   if FState <> Value then
  1310.   begin
  1311.     FState := Value;
  1312.     UpdateControlCanvas;
  1313.     Changed;
  1314.   end;
  1315. end;
  1317. procedure TVrBitmapCheckBox.SetNumGlyphs(Value: TVrCheckBoxGlyphs);
  1318. begin
  1319.   if FNumGlyphs <> Value then
  1320.   begin
  1321.     FNumGlyphs := Value;
  1322.     CalcPaintParams(True);
  1323.   end;
  1324. end;
  1326. procedure TVrBitmapCheckBox.SetTransparentColor(Value: TColor);
  1327. begin
  1328.   if FTransparentColor <> Value then
  1329.   begin
  1330.     FTransparentColor := Value;
  1331.     UpdateControlCanvas;
  1332.   end;
  1333. end;
  1335. procedure TVrBitmapCheckBox.SetTextureIndex(Value: Integer);
  1336. begin
  1337.   if FTextureIndex <> Value then
  1338.   begin
  1339.     FTextureIndex := Value;
  1340.     UpdateControlCanvas;
  1341.   end;
  1342. end;
  1344. procedure TVrBitmapCheckBox.SetTextureStyle(Value: TVrCheckBoxTexture);
  1345. begin
  1346.   if FTextureStyle <> Value then
  1347.   begin
  1348.     FTextureStyle := Value;
  1349.     UpdateControlCanvas;
  1350.   end;
  1351. end;
  1353. procedure TVrBitmapCheckBox.SetFocusColor(Value: TColor);
  1354. begin
  1355.   if FFocusColor <> Value then
  1356.   begin
  1357.     FFocusColor := Value;
  1358.     UpdateControlCanvas;
  1359.   end;
  1360. end;
  1362. procedure TVrBitmapCheckBox.SetFocusOffset(Value: Integer);
  1363. begin
  1364.   if FFocusOffset <> Value then
  1365.   begin
  1366.     FFocusOffset := Value;
  1367.     UpdateControlCanvas;
  1368.   end;
  1369. end;
  1371. function TVrBitmapCheckBox.GetChecked: Boolean;
  1372. begin
  1373.   Result := State = vcbChecked;
  1374. end;
  1376. procedure TVrBitmapCheckBox.SetChecked(Value: Boolean);
  1377. begin
  1378.   if Value then State := vcbChecked else State := vcbUnchecked;
  1379. end;
  1381. procedure TVrBitmapCheckBox.Changed;
  1382. begin
  1383.   if Assigned(FOnChange) then FOnChange(Self);
  1384. end;
  1386. procedure TVrBitmapCheckBox.Toggle;
  1387. begin
  1388.   case State of
  1389.     vcbUnchecked:
  1390.       if AllowGrayed then State := vcbGrayed else State := vcbChecked;
  1391.     vcbChecked: State := vcbUnchecked;
  1392.     vcbGrayed: State := vcbChecked;
  1393.   end;
  1394. end;
  1396. procedure TVrBitmapCheckBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1397.   X, Y: Integer);
  1398. begin
  1399.   inherited MouseDown(Button, Shift, X, Y);
  1400.   if Button = mbLeft then
  1401.   begin
  1402.     if TabStop then SetFocus;
  1403.     FButtonDown := True;
  1404.   end;
  1405. end;
  1407. procedure TVrBitmapCheckBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1408.   X, Y: Integer);
  1409. begin
  1410.   if FButtonDown then
  1411.   begin
  1412.     FButtonDown := false;
  1413.     if PtInRect(ClientRect, Point(X, Y)) then
  1414.       Toggle;
  1415.   end;
  1416.   inherited MouseUp(Button, Shift, X, Y);
  1417. end;
  1419. procedure TVrBitmapCheckBox.Keypress(var Key: Char);
  1420. begin
  1421.   if Key = #32 then Toggle;
  1422.   inherited;
  1423. end;
  1425. { TVrBitmapRadioButton }
  1427. constructor TVrBitmapRadioButton.Create(AOwner: TComponent);
  1428. begin
  1429.   inherited Create(AOwner);
  1430.   ControlStyle := ControlStyle + [csOpaque, csSetCaption] - [csDoubleClicks];
  1431.   Width := 140;
  1432.   Height := 17;
  1433.   FSpacing := 5;
  1434.   FMargin := -1;
  1435.   FLayout := ImageLeft;
  1436.   FChecked := false;
  1437.   FTransparentColor := clOlive;
  1438.   FTextureIndex := -1;
  1439.   FTextureStyle := rbtTile;
  1440.   FFocusColor := clBlue;
  1441.   FFocusOffset := 0;
  1442.   FNumGlyphs := 2;
  1443.   FFont3D := TVrFont3D.Create;
  1444.   FFont3D.OnChange := Font3DChanged;
  1445.   FEnabledGlyphIndex := -1;
  1446.   FDisabledGlyphIndex := -1;
  1447.   FBitmapListLink := TVrChangeLink.Create;
  1448.   FBitmapListLink.OnChange := BitmapListChanged;
  1449. end;
  1451. destructor TVrBitmapRadioButton.Destroy;
  1452. begin
  1453.   FFont3D.Free;
  1454.   FBitmapListLink.Free;
  1455.   inherited Destroy;
  1456. end;
  1458. procedure TVrBitmapRadioButton.CreateParams(var Params: TCreateParams);
  1459. begin
  1460.   inherited CreateParams(Params);
  1461.   with Params do
  1462.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  1463. end;
  1465. procedure TVrBitmapRadioButton.UpdateGlyphs;
  1466. var
  1467.   NewX, NewY: Integer;
  1468. begin
  1469.   FEnabledGlyphs := GetBitmap(FEnabledGlyphIndex);
  1470.   FDisabledGlyphs := GetBitmap(FDisabledGlyphIndex);
  1471.   NewX := -1;
  1472.   NewY := -1;
  1473.   FSize.X := 0;
  1474.   FSize.Y := 0;
  1475.   if FEnabledGlyphs <> nil then
  1476.   begin
  1477.     FSize.X := FEnabledGlyphs.Width div NumGlyphs;
  1478.     FSize.Y := FEnabledGlyphs.Height;
  1479.   end;
  1480.   if FDisabledGlyphs <> nil then
  1481.   begin
  1482.     NewX := FDisabledGlyphs.Width div NumGlyphs;
  1483.     NewY := FDisabledGlyphs.Height;
  1484.   end;
  1485.   if NewX > FSize.X then FSize.X := NewX;
  1486.   if NewY > FSize.Y then FSize.Y := NewY;
  1487. end;
  1489. procedure TVrBitmapRadioButton.Paint;
  1490. var
  1491.   Index, X, Y: Integer;
  1492.   iWidth, iHeight: Integer;
  1493.   R: TRect;
  1494.   BackImage, Glyphs: TBitmap;
  1495. begin
  1496.   BackImage := GetBitmap(FTextureIndex);
  1497.   if BackImage = nil then ClearBitmapCanvas
  1498.   else
  1499.   begin
  1500.     if TextureStyle = rbtTile then
  1501.       DrawTiledBitmap(BitmapCanvas, ClientRect, BackImage)
  1502.     else BitmapCanvas.CopyRect(ClientRect, BackImage.Canvas, BitmapRect(BackImage));
  1503.   end;
  1505.   if (Enabled) or (FDisabledGlyphs = nil) then
  1506.     Glyphs := FEnabledGlyphs
  1507.   else Glyphs := FDisabledGlyphs;
  1509.   with BitmapCanvas do
  1510.   begin
  1511.     Index := Ord(FChecked); //0 or 1
  1512.     if (Glyphs <> nil) and (Index < NumGlyphs) then
  1513.     begin
  1514.       iWidth := Glyphs.Width div NumGlyphs;
  1515.       iHeight := Glyphs.Height;
  1516.       X := (WidthOf(FImageRect) - iWidth) div 2;
  1517.       Y := (HeightOf(FImageRect) - iHeight) div 2;
  1519.       R := Bounds(FImageRect.Left + X, FImageRect.Top + Y, iWidth, iHeight);
  1521.       Brush.Style := bsClear;
  1522.       BrushCopy(R, Glyphs,
  1523.         Bounds(Index * iWidth, 0, iWidth, iHeight), TransparentColor);
  1524.     end;
  1526.     Font := Self.Font;
  1527.     FFont3D.Paint(BitmapCanvas, FTextBounds, Caption,
  1528.       DT_LEFT or DT_VCENTER or DT_SINGLELINE);
  1530.     if (Focused) and (FocusOffset > -1) then
  1531.     begin
  1532.       R := ClientRect;
  1533.       InflateRect(R, -FocusOffset, -FocusOffset);
  1534.       Brush.Color := FocusColor;
  1535.       FrameRect(R);
  1536.     end;
  1537.   end;
  1539.   inherited Paint;
  1540. end;
  1542. procedure TVrBitmapRadioButton.CalcPaintParams(Repaint: Boolean);
  1543. var
  1544.   ImagePos: TPoint;
  1545. begin
  1546.   UpdateGlyphs;
  1547.   Canvas.Font.Assign(Self.Font);
  1548.   CalcImageTextLayout(Canvas, ClientRect, Point(1, 1), Caption, FLayout,
  1549.     FMargin, FSpacing, Point(FSize.X, FSize.Y), ImagePos, FTextBounds);
  1550.   FImageRect := Bounds(ImagePos.X, ImagePos.Y, FSize.X, FSize.Y);
  1551.   if Repaint then UpdateControlCanvas;
  1552. end;
  1554. procedure TVrBitmapRadioButton.WMSize(var Message: TMessage);
  1555. begin
  1556.   inherited;
  1557.   CalcPaintParams(True);
  1558. end;
  1560. procedure TVrBitmapRadioButton.CMFontChanged(var Message: TMessage);
  1561. begin
  1562.   inherited;
  1563.   CalcPaintParams(True);
  1564. end;
  1566. procedure TVrBitmapRadioButton.CMTextChanged(var Message: TMessage);
  1567. begin
  1568.   inherited;
  1569.   if HandleAllocated then
  1570.     CalcPaintParams(True);
  1571. end;
  1573. procedure TVrBitmapRadioButton.CMEnabledChanged(var Message: TMessage);
  1574. begin
  1575.   inherited;
  1576.   UpdateControlCanvas;
  1577. end;
  1579. procedure TVrBitmapRadioButton.CMDialogChar(var Message: TCMDialogChar);
  1580. begin
  1581.   with Message do
  1582.     if IsAccel(CharCode, Caption) and CanFocus then
  1583.     begin
  1584.       SetFocus;
  1585.       Result := 1;
  1586.     end else inherited;
  1587. end;
  1589. procedure TVrBitmapRadioButton.CMFocusChanged(var Message: TCMFocusChanged);
  1590. var
  1591.   Active: Boolean;
  1592. begin
  1593.   with Message do Active := (Sender = Self);
  1594.   if Active <> FFocused then
  1595.   begin
  1596.     FFocused := Active;
  1597.     UpdateControlCanvas;
  1598.   end;
  1599.   inherited;
  1600. end;
  1602. procedure TVrBitmapRadioButton.Notification(AComponent: TComponent;
  1603.   Operation: TOperation);
  1604. begin
  1605.   inherited Notification(AComponent, Operation);
  1606.   if (Operation = opRemove) then
  1607.     if AComponent = BitmapList then BitmapList := nil;
  1608. end;
  1610. function TVrBitmapRadioButton.GetBitmap(Index: Integer): TBitmap;
  1611. begin
  1612.   Result := nil;
  1613.   if Assigned(FBitmapList) then
  1614.     Result := FBitmapList.GetBitmap(Index);
  1615. end;
  1617. procedure TVrBitmapRadioButton.SetBitmapList(Value: TVrBitmapList);
  1618. begin
  1619.   if FBitmapList <> nil then
  1620.     FBitmapList.RemoveLink(FBitmapListLink);
  1621.   FBitmapList := Value;
  1622.   if FBitmapList <> nil then
  1623.     FBitmapList.InsertLink(FBitmapListLink);
  1624.   CalcPaintParams(True);
  1625. end;
  1627. procedure TVrBitmapRadioButton.BitmapListChanged(Sender: TObject);
  1628. begin
  1629.   CalcPaintParams(True);
  1630. end;
  1632. procedure TVrBitmapRadioButton.SetEnabledGlyphIndex(Value: Integer);
  1633. begin
  1634.   if FEnabledGlyphIndex <> Value then
  1635.   begin
  1636.     FEnabledGlyphIndex := Value;
  1637.     CalcPaintParams(True);
  1638.   end;
  1639. end;
  1641. procedure TVrBitmapRadioButton.SetDisabledGlyphIndex(Value: Integer);
  1642. begin
  1643.   if FDisabledGlyphIndex <> Value then
  1644.   begin
  1645.     FDisabledGlyphIndex := Value;
  1646.     CalcPaintParams(True);
  1647.   end;
  1648. end;
  1650. procedure TVrBitmapRadioButton.Font3DChanged(Sender: TObject);
  1651. begin
  1652.   UpdateControlCanvas;
  1653. end;
  1655. procedure TVrBitmapRadioButton.SetFont3D(Value: TVrFont3D);
  1656. begin
  1657.   FFont3D.Assign(Value);
  1658. end;
  1660. procedure TVrBitmapRadioButton.SetLayout(Value: TVrImageTextLayout);
  1661. begin
  1662.   if FLayout <> Value then
  1663.   begin
  1664.     FLayout := Value;
  1665.     CalcPaintParams(True);
  1666.   end;
  1667. end;
  1669. procedure TVrBitmapRadioButton.SetMargin(Value: Integer);
  1670. begin
  1671.   if FMargin <> Value then
  1672.   begin
  1673.     FMargin := Value;
  1674.     CalcPaintParams(True);
  1675.   end;
  1676. end;
  1678. procedure TVrBitmapRadioButton.SetSpacing(Value: Integer);
  1679. begin
  1680.   if FSpacing <> Value then
  1681.   begin
  1682.     FSpacing := Value;
  1683.     CalcPaintParams(True);
  1684.   end;
  1685. end;
  1687. procedure TVrBitmapRadioButton.SetNumGlyphs(Value: TVrRadioButtonGlyphs);
  1688. begin
  1689.   if FNumGlyphs <> Value then
  1690.   begin
  1691.     FNumGlyphs := Value;
  1692.     CalcPaintParams(True);
  1693.   end;
  1694. end;
  1696. procedure TVrBitmapRadioButton.SetTransparentColor(Value: TColor);
  1697. begin
  1698.   if FTransparentColor <> Value then
  1699.   begin
  1700.     FTransparentColor := Value;
  1701.     UpdateControlCanvas;
  1702.   end;
  1703. end;
  1705. procedure TVrBitmapRadioButton.SetTextureIndex(Value: Integer);
  1706. begin
  1707.   if FTextureIndex <> Value then
  1708.   begin
  1709.     FTextureIndex := Value;
  1710.     UpdateControlCanvas;
  1711.   end;
  1712. end;
  1714. procedure TVrBitmapRadioButton.SetTextureStyle(Value: TVrRadioButtonTexture);
  1715. begin
  1716.   if FTextureStyle <> Value then
  1717.   begin
  1718.     FTextureStyle := Value;
  1719.     UpdateControlCanvas;
  1720.   end;
  1721. end;
  1723. procedure TVrBitmapRadioButton.SetFocusColor(Value: TColor);
  1724. begin
  1725.   if FFocusColor <> Value then
  1726.   begin
  1727.     FFocusColor := Value;
  1728.     UpdateControlCanvas;
  1729.   end;
  1730. end;
  1732. procedure TVrBitmapRadioButton.SetFocusOffset(Value: Integer);
  1733. begin
  1734.   if FFocusOffset <> Value then
  1735.   begin
  1736.     FFocusOffset := Value;
  1737.     UpdateControlCanvas;
  1738.   end;
  1739. end;
  1741. procedure TVrBitmapRadioButton.SetChecked(Value: Boolean);
  1743.   procedure TurnSiblingsOff;
  1744.   var
  1745.     I: Integer;
  1746.     Sibling: TControl;
  1747.   begin
  1748.     if Parent <> nil then
  1749.       with Parent do
  1750.         for I := 0 to ControlCount - 1 do
  1751.         begin
  1752.           Sibling := Controls[I];
  1753.           if (Sibling <> Self) and (Sibling is TVrBitmapRadioButton) then
  1754.             TVrBitmapRadioButton(Sibling).SetChecked(False);
  1755.         end;
  1756.   end;
  1758. begin
  1759.   if FChecked <> Value then
  1760.   begin
  1761.     FChecked := Value;
  1762.     TabStop := Value;
  1763.     if Value then TurnSiblingsOff;
  1764.     UpdateControlCanvas;
  1765.     Changed;
  1766.   end;
  1767. end;
  1769. procedure TVrBitmapRadioButton.Changed;
  1770. begin
  1771.   if Assigned(FOnChange) then FOnChange(Self);
  1772. end;
  1774. procedure TVrBitmapRadioButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  1775.   X, Y: Integer);
  1776. begin
  1777.   inherited MouseDown(Button, Shift, X, Y);
  1778.   if Button = mbLeft then
  1779.   begin
  1780.     if CanFocus then SetFocus;
  1781.     FButtonDown := True;
  1782.   end;
  1783. end;
  1785. procedure TVrBitmapRadioButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  1786.   X, Y: Integer);
  1787. begin
  1788.   if FButtonDown then
  1789.   begin
  1790.     FButtonDown := false;
  1791.     if PtInRect(ClientRect, Point(X, Y)) then
  1792.       Checked := True;
  1793.   end;
  1794.   inherited MouseUp(Button, Shift, X, Y);
  1795. end;
  1797. procedure TVrBitmapRadioButton.Keypress(var Key: Char);
  1798. begin
  1799.   if Key = #32 then Checked := True;
  1800.   inherited;
  1801. end;
  1804. end.