vrdesign.pas

作工控的好控件

    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapCheckBox.SetFocusOffset(Value: Integer);
begin
  if FFocusOffset <> Value then
  begin
    FFocusOffset := Value;
    UpdateControlCanvas;
  end;
end;

function TVrBitmapCheckBox.GetChecked: Boolean;
begin
  Result := State = vcbChecked;
end;

procedure TVrBitmapCheckBox.SetChecked(Value: Boolean);
begin
  if Value then State := vcbChecked else State := vcbUnchecked;
end;

procedure TVrBitmapCheckBox.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrBitmapCheckBox.Toggle;
begin
  case State of
    vcbUnchecked:
      if AllowGrayed then State := vcbGrayed else State := vcbChecked;
    vcbChecked: State := vcbUnchecked;
    vcbGrayed: State := vcbChecked;
  end;
end;

procedure TVrBitmapCheckBox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if Button = mbLeft then
  begin
    if TabStop then SetFocus;
    FButtonDown := True;
  end;
end;

procedure TVrBitmapCheckBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if FButtonDown then
  begin
    FButtonDown := false;
    if PtInRect(ClientRect, Point(X, Y)) then
      Toggle;
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TVrBitmapCheckBox.Keypress(var Key: Char);
begin
  if Key = #32 then Toggle;
  inherited;
end;

{ TVrBitmapRadioButton }

constructor TVrBitmapRadioButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csSetCaption] - [csDoubleClicks];
  Width := 140;
  Height := 17;
  FSpacing := 5;
  FMargin := -1;
  FLayout := ImageLeft;
  FChecked := false;
  FTransparentColor := clOlive;
  FTextureIndex := -1;
  FTextureStyle := rbtTile;
  FFocusColor := clBlue;
  FFocusOffset := 0;
  FNumGlyphs := 2;
  FFont3D := TVrFont3D.Create;
  FFont3D.OnChange := Font3DChanged;
  FEnabledGlyphIndex := -1;
  FDisabledGlyphIndex := -1;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
end;

destructor TVrBitmapRadioButton.Destroy;
begin
  FFont3D.Free;
  FBitmapListLink.Free;
  inherited Destroy;
end;

procedure TVrBitmapRadioButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure TVrBitmapRadioButton.UpdateGlyphs;
var
  NewX, NewY: Integer;
begin
  FEnabledGlyphs := GetBitmap(FEnabledGlyphIndex);
  FDisabledGlyphs := GetBitmap(FDisabledGlyphIndex);
  NewX := -1;
  NewY := -1;
  FSize.X := 0;
  FSize.Y := 0;
  if FEnabledGlyphs <> nil then
  begin
    FSize.X := FEnabledGlyphs.Width div NumGlyphs;
    FSize.Y := FEnabledGlyphs.Height;
  end;
  if FDisabledGlyphs <> nil then
  begin
    NewX := FDisabledGlyphs.Width div NumGlyphs;
    NewY := FDisabledGlyphs.Height;
  end;
  if NewX > FSize.X then FSize.X := NewX;
  if NewY > FSize.Y then FSize.Y := NewY;
end;

procedure TVrBitmapRadioButton.Paint;
var
  Index, X, Y: Integer;
  iWidth, iHeight: Integer;
  R: TRect;
  BackImage, Glyphs: TBitmap;
begin
  BackImage := GetBitmap(FTextureIndex);
  if BackImage = nil then ClearBitmapCanvas
  else
  begin
    if TextureStyle = rbtTile then
      DrawTiledBitmap(BitmapCanvas, ClientRect, BackImage)
    else BitmapCanvas.CopyRect(ClientRect, BackImage.Canvas, BitmapRect(BackImage));
  end;

  if (Enabled) or (FDisabledGlyphs = nil) then
    Glyphs := FEnabledGlyphs
  else Glyphs := FDisabledGlyphs;

  with BitmapCanvas do
  begin
    Index := Ord(FChecked); //0 or 1
    if (Glyphs <> nil) and (Index < NumGlyphs) then
    begin
      iWidth := Glyphs.Width div NumGlyphs;
      iHeight := Glyphs.Height;
      X := (WidthOf(FImageRect) - iWidth) div 2;
      Y := (HeightOf(FImageRect) - iHeight) div 2;

      R := Bounds(FImageRect.Left + X, FImageRect.Top + Y, iWidth, iHeight);

      Brush.Style := bsClear;
      BrushCopy(R, Glyphs,
        Bounds(Index * iWidth, 0, iWidth, iHeight), TransparentColor);
    end;

    Font := Self.Font;
    FFont3D.Paint(BitmapCanvas, FTextBounds, Caption,
      DT_LEFT or DT_VCENTER or DT_SINGLELINE);

    if (Focused) and (FocusOffset > -1) then
    begin
      R := ClientRect;
      InflateRect(R, -FocusOffset, -FocusOffset);
      Brush.Color := FocusColor;
      FrameRect(R);
    end;
  end;

  inherited Paint;
end;

procedure TVrBitmapRadioButton.CalcPaintParams(Repaint: Boolean);
var
  ImagePos: TPoint;
begin
  UpdateGlyphs;
  Canvas.Font.Assign(Self.Font);
  CalcImageTextLayout(Canvas, ClientRect, Point(1, 1), Caption, FLayout,
    FMargin, FSpacing, Point(FSize.X, FSize.Y), ImagePos, FTextBounds);
  FImageRect := Bounds(ImagePos.X, ImagePos.Y, FSize.X, FSize.Y);
  if Repaint then UpdateControlCanvas;
end;

procedure TVrBitmapRadioButton.WMSize(var Message: TMessage);
begin
  inherited;
  CalcPaintParams(True);
end;

procedure TVrBitmapRadioButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  CalcPaintParams(True);
end;

procedure TVrBitmapRadioButton.CMTextChanged(var Message: TMessage);
begin
  inherited;
  if HandleAllocated then
    CalcPaintParams(True);
end;

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

procedure TVrBitmapRadioButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and CanFocus then
    begin
      SetFocus;
      Result := 1;
    end else inherited;
end;

procedure TVrBitmapRadioButton.CMFocusChanged(var Message: TCMFocusChanged);
var
  Active: Boolean;
begin
  with Message do Active := (Sender = Self);
  if Active <> FFocused then
  begin
    FFocused := Active;
    UpdateControlCanvas;
  end;
  inherited;
end;

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

function TVrBitmapRadioButton.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(Index);
end;

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

procedure TVrBitmapRadioButton.BitmapListChanged(Sender: TObject);
begin
  CalcPaintParams(True);
end;

procedure TVrBitmapRadioButton.SetEnabledGlyphIndex(Value: Integer);
begin
  if FEnabledGlyphIndex <> Value then
  begin
    FEnabledGlyphIndex := Value;
    CalcPaintParams(True);
  end;
end;

procedure TVrBitmapRadioButton.SetDisabledGlyphIndex(Value: Integer);
begin
  if FDisabledGlyphIndex <> Value then
  begin
    FDisabledGlyphIndex := Value;
    CalcPaintParams(True);
  end;
end;

procedure TVrBitmapRadioButton.Font3DChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrBitmapRadioButton.SetFont3D(Value: TVrFont3D);
begin
  FFont3D.Assign(Value);
end;

procedure TVrBitmapRadioButton.SetLayout(Value: TVrImageTextLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    CalcPaintParams(True);
  end;
end;

procedure TVrBitmapRadioButton.SetMargin(Value: Integer);
begin
  if FMargin <> Value then
  begin
    FMargin := Value;
    CalcPaintParams(True);
  end;
end;

procedure TVrBitmapRadioButton.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    CalcPaintParams(True);
  end;
end;

procedure TVrBitmapRadioButton.SetNumGlyphs(Value: TVrRadioButtonGlyphs);
begin
  if FNumGlyphs <> Value then
  begin
    FNumGlyphs := Value;
    CalcPaintParams(True);
  end;
end;

procedure TVrBitmapRadioButton.SetTransparentColor(Value: TColor);
begin
  if FTransparentColor <> Value then
  begin
    FTransparentColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapRadioButton.SetTextureIndex(Value: Integer);
begin
  if FTextureIndex <> Value then
  begin
    FTextureIndex := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapRadioButton.SetTextureStyle(Value: TVrRadioButtonTexture);
begin
  if FTextureStyle <> Value then
  begin
    FTextureStyle := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapRadioButton.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin
    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapRadioButton.SetFocusOffset(Value: Integer);
begin
  if FFocusOffset <> Value then
  begin
    FFocusOffset := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrBitmapRadioButton.SetChecked(Value: Boolean);

  procedure TurnSiblingsOff;
  var
    I: Integer;
    Sibling: TControl;
  begin
    if Parent <> nil then
      with Parent do
        for I := 0 to ControlCount - 1 do
        begin
          Sibling := Controls[I];
          if (Sibling <> Self) and (Sibling is TVrBitmapRadioButton) then
            TVrBitmapRadioButton(Sibling).SetChecked(False);
        end;
  end;

begin
  if FChecked <> Value then
  begin
    FChecked := Value;
    TabStop := Value;
    if Value then TurnSiblingsOff;
    UpdateControlCanvas;
    Changed;
  end;
end;

procedure TVrBitmapRadioButton.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TVrBitmapRadioButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if Button = mbLeft then
  begin
    if CanFocus then SetFocus;
    FButtonDown := True;
  end;
end;

procedure TVrBitmapRadioButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if FButtonDown then
  begin
    FButtonDown := false;
    if PtInRect(ClientRect, Point(X, Y)) then
      Checked := True;
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TVrBitmapRadioButton.Keypress(var Key: Char);
begin
  if Key = #32 then Checked := True;
  inherited;
end;


end.