vrdesign.pas

作工控的好控件

  FImage := TBitmap.Create;
end;

destructor TVrCounter.Destroy;
begin
  FImage.Free;
  FBitmap.Free;
  inherited Destroy;
end;

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

procedure TVrCounter.BitmapChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrCounter.Paint;
var
  str: string;
  I, V, MidX, MidY: Integer;
begin
  CalcPaintParams;
  ClearBitmapCanvas;

  with FImage, FImage.Canvas do
  begin
    Brush.Color := Self.Color;
    Brush.Style := bsSolid;
    FillRect(Bounds(0, 0, Width, Height));
  end;

  MidX := 0;
  MidY := 0;
  if not Bitmap.Empty then
  begin
    str := Format('%.' + IntToStr(Digits) + 'd', [Value]);
    for I := 1 to Length(str) do
    begin
      V := StrToInt(str[I]);
      FImage.Canvas.BrushCopy(Bounds(MidX, MidY, FDigitSize.X, FDigitSize.Y),
        Bitmap, Bounds(V * FDigitSize.X, 0, FDigitSize.X, FDigitSize.Y),
        Self.Color);
      Inc(MidX, FSpacing + FDigitSize.X);
    end;
  end;

  if Transparent then BitmapCanvas.Brush.Style := bsClear
    else BitmapCanvas.Brush.Style := bsSolid;

  if (Stretch) and (not AutoSize) then
    BitmapCanvas.BrushCopy(ClientRect, FImage,
      BitmapRect(FImage), Self.Color)
  else
  begin
    MidX := (ClientWidth - FImage.Width) div 2;
    MidY := (ClientHeight - FImage.Height) div 2;
    BitmapCanvas.BrushCopy(Bounds(MidX, MidY, FImage.Width, FImage.Height),
      FImage, BitmapRect(FImage), Self.Color);
  end;
  ShowDesignFrame(BitmapCanvas);
  inherited Paint;
end;

procedure TVrCounter.CalcPaintParams;
begin
  if not Bitmap.Empty then
  begin
    FDigitSize.X := Bitmap.Width div 10;
    FDigitSize.Y := Bitmap.Height;
    FImage.Width := (Spacing * Pred(Digits)) + (FDigitSize.X * Digits);
    FImage.Height := Bitmap.Height;
    if AutoSize then
      BoundsRect := Bounds(Left, Top, FImage.Width, FImage.Height);
  end;
end;

function TVrCounter.GetPalette: HPalette;
begin
  if FBitmap.Empty then Result := inherited GetPalette
  else Result := FBitmap.Palette;
end;

procedure TVrCounter.SetValue(Value: TVrCounterValue);
begin
  if FValue <> Value then
  begin
    FValue := Value;
    UpdateControlCanvas;
    Changed;
  end;
end;

procedure TVrCounter.SetDigits(Value: TVrCounterDigits);
begin
  if FDigits <> Value then
  begin
    FDigits := Value;
    UpdateControlCanvas;
  end;
end;

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

procedure TVrCounter.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;

procedure TVrCounter.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    UpdateControlCanvas;
  end;
end;

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

{ TVrBitmapCheckBox }

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

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

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

procedure TVrBitmapCheckBox.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 TVrBitmapCheckBox.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 = cbtTile 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(State); //0, 1 or 2
    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 TVrBitmapCheckBox.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 TVrBitmapCheckBox.WMSize(var Message: TMessage);
begin
  inherited;
  CalcPaintParams(True);
end;

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

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

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

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

procedure TVrBitmapCheckBox.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 TVrBitmapCheckBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = BitmapList then BitmapList := nil;
end;

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

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

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

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

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

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

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

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

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

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

procedure TVrBitmapCheckBox.SetState(Value: TVrCheckBoxState);
begin
  if FState <> Value then
  begin
    FState := Value;
    UpdateControlCanvas;
    Changed;
  end;
end;

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

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

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

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

procedure TVrBitmapCheckBox.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin