vrdesign.pas

作工控的好控件

    property Font3D: TVrFont3D read FFont3D write SetFont3D;
    property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
    property TextureIndex: Integer read FTextureIndex write SetTextureIndex default -1;
    property TextureStyle: TVrRadioButtonTexture read FTextureStyle write SetTextureStyle default rbtTile;
    property Checked: Boolean read FChecked write SetChecked default false;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
    property FocusOffset: Integer read FFocusOffset write SetFocusOffset default 0;    
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Caption;
    property Color;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Enabled;
    property Font;
    property ParentFont;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop default false;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;


implementation

{ TVrBitmapButton }

constructor TVrBitmapButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csReplicatable] -
    [csDoubleClicks, csSetCaption];
  Width := 50;
  Height := 50;
  Color := clBtnFace;
  ParentColor := false;
  FGlyph := TBitmap.Create;
  FGlyph.OnChange := GlyphChanged;
  FMask := TBitmap.Create;
  FNumGlyphs := 1;
  FAutoSize := false;
  FVIndent := 2;
  FHIndent := 2;
  FTransparentMode := tmColor;
end;

destructor TVrBitmapButton.Destroy;
begin
  FMask.Free;
  FGlyph.Free;
  inherited Destroy;
end;

procedure TVrBitmapButton.Loaded;
begin
  inherited Loaded;
  AdjustImageSize;
  FMask.Assign(Glyph);
  FMask.Mask(Self.Color);
end;

procedure TVrBitmapButton.Paint;
var
  Index: Integer;
begin
  AdjustBounds;

  ClearBitmapCanvas;

  Index := 0;
  if FHasMouse then Index := 1;
  if Down then Index := 2;
  if not Enabled then Index := 3;
  if Succ(Index) > NumGlyphs then Index := 0;

  if not Glyph.Empty then
    with BitmapCanvas do
    begin
      if Transparent then Brush.Style := bsClear
      else Brush.Style := bsSolid;
      BrushCopy(DestRect, FGlyph, GetImageRect(Index), GetTransparentColor);
    end;

  ShowDesignFrame(BitmapCanvas);

  inherited Paint;
end;

function TVrBitmapButton.GetTransparentColor: TColor;
begin
  Result := Self.Color;
  if (not Glyph.Empty) and (TransparentMode = tmPixel) then
    Result := Glyph.Canvas.Pixels[0,0];
end;

function TVrBitmapButton.GetPalette: HPALETTE;
begin
  Result := 0;
  if not Glyph.Empty then
    Result := Glyph.Palette;
end;

procedure TVrBitmapButton.AdjustImageSize;
begin
  FImageWidth := 0;
  FImageHeight := 0;
  if not Glyph.Empty then
  begin
    FImageWidth := Glyph.Width div NumGlyphs;
    FImageHeight := Glyph.Height;
  end;
end;

function TVrBitmapButton.GetImageRect(Index: Integer): TRect;
begin
  Result := Bounds(Index * FImageWidth, 0, FImageWidth, FImageHeight)
end;

procedure TVrBitmapButton.AdjustBounds;
begin
  if (AutoSize) and (Align = alNone) then
    if (FImageWidth > 0) and (FImageHeight > 0) then
      SetBounds(Left, Top, FImageWidth + HIndent + 1, FImageHeight + VIndent + 1);
end;

function TVrBitmapButton.DestRect: TRect;
var
  MidX, MidY: Integer;
begin
  MidX := (ClientWidth - FImageWidth) div 2;
  MidY := (ClientHeight - FImageHeight) div 2;
  Result := Bounds(MidX, MidY, FImageWidth, FImageHeight);
  if Down then OffsetRect(Result, HIndent, VIndent);
end;

procedure TVrBitmapButton.GlyphChanged(Sender: TObject);
begin
  AdjustImageSize;
  UpdateControlCanvas;
end;

procedure TVrBitmapButton.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  FMask.Assign(Value);
  FMask.Mask(Self.Color);
end;

procedure TVrBitmapButton.SetNumGlyphs(Value: TVrNumGlyphs);
begin
  if (FNumGlyphs <> Value) then
  begin
    FNumGlyphs := Value;
    AdjustImageSize;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapButton.SetVIndent(Value: Integer);
begin
  if (FVIndent <> Value) and (Value >= 0) then
  begin
    FVIndent := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapButton.SetHIndent(Value: Integer);
begin
  if (FHIndent <> Value) and (Value >= 0) then
  begin
    FHIndent := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapButton.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapButton.SetTransparentMode(Value: TVrTransparentMode);
begin
  if FTransparentMode <> Value then
  begin
    FTransparentMode := Value;
    UpdateControlCanvas;
  end;
end;

function TVrBitmapButton.InControl(X, Y: Integer): Boolean;
var
  R: TRect;
begin
  R := ClientRect;
  Result := (PtInRect(R, Point(X, Y))) and
            (FMask.Canvas.Pixels[X, Y] = clBlack);
end;

procedure TVrBitmapButton.DoMouseDown(XPos, YPos: Integer);
begin
  if InControl(XPos, YPos) then
  begin
    Pressed := True;
    Down := True;
    MouseCapture := true;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
  inherited;
  DoMouseDown(Message.XPos, Message.YPos);
end;

procedure TVrBitmapButton.WMMouseMove(var Message: TWMMouseMove);
var
  P: TPoint;
begin
  inherited;
  if Pressed then
  begin
    P := Point(Message.XPos, Message.YPos);
    if InControl(P.X, P.Y) <> Down then
    begin
      Down := not Down;
      UpdateControlCanvas;
    end;
  end;
end;

procedure TVrBitmapButton.WMLButtonUp(var Message: TWMLButtonUp);
var
  DoClick: Boolean;
begin
  MouseCapture := false;
  DoClick := Pressed and Down;
  Down := false;
  Pressed := false;
  if DoClick then
  begin
    UpdateControlCanvas;
    inherited; // Click;
  end;
end;

procedure TVrBitmapButton.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  FHasMouse := True;
  UpdateControlCanvas;
end;

procedure TVrBitmapButton.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  FHasMouse := false;
  UpdateControlCanvas;
end;

procedure TVrBitmapButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;


{ TVrBitmapImage }

constructor TVrBitmapImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csReplicatable];
  Width := 105;
  Height := 105;
  Color := clBtnFace;
  ParentColor := false;
  FAutoSize := false;
  FCenter := True;
  FStretch := false;
  FBitmapIndex := -1;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
end;

destructor TVrBitmapImage.Destroy;
begin
  FBitmapListLink.Free;
  inherited Destroy;
end;

function TVrBitmapImage.GetBitmap: TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(BitmapIndex);
end;

procedure TVrBitmapImage.SetBitmapList(Value: TVrBitmapList);
begin
  if FBitmapList <> nil then
    FBitmapList.RemoveLink(FBitmapListLink);
  FBitmapList := Value;
  if FBitmapList <> nil then
    FBitmapList.InsertLink(FBitmapListLink);
  UpdateControlCanvas;
end;

procedure TVrBitmapImage.BitmapListChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

function TVrBitmapImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if GetBitmap <> nil then
    Result := GetBitmap.Palette;
end;

procedure TVrBitmapImage.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = BitmapList then BitmapList := nil;
end;

function TVrBitmapImage.DestRect: TRect;
begin
  if Stretch then
    Result := ClientRect
  else if Center then
    Result := Bounds((Width - FBitmap.Width) div 2, (Height - FBitmap.Height) div 2,
      FBitmap.Width, FBitmap.Height)
  else
    Result := Rect(0, 0, FBitmap.Width, FBitmap.Height);
end;

procedure TVrBitmapImage.AdjustBounds;
begin
  if (AutoSize) and (Align = alNone) then
    if (FBitmap.Width > 0) and (FBitmap.Height > 0) then
      SetBounds(Left, Top, FBitmap.Width, FBitmap.Height);
end;

procedure TVrBitmapImage.Paint;
begin
  FBitmap := GetBitmap;
  if FBitmap <> nil then AdjustBounds;
  ClearBitmapCanvas;
  if FBitmap <> nil then
    with BitmapCanvas do
    begin
      if Transparent then Brush.Style := bsClear
        else Brush.Style := bsSolid;
      BrushCopy(DestRect, FBitmap, BitmapRect(FBitmap), Self.Color);
    end;
  ShowDesignFrame(BitmapCanvas);
  inherited Paint;
end;

procedure TVrBitmapImage.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapImage.SetStretch(Value: Boolean);
begin
  if FStretch <> Value then
  begin
    FStretch := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapImage.SetBitmapIndex(Value: Integer);
begin
  if FBitmapIndex <> Value then
  begin
    FBitmapIndex := Value;
    UpdateControlCanvas;
  end;
end;

{ TVrCounter }

constructor TVrCounter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 150;
  Height := 25;
  Color := clBtnFace;
  ParentColor := false;
  Transparent := false;
  FValue := 0;
  FDigits := 8;
  FAutoSize := True;
  FSpacing := 0;
  FStretch := false;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;