vrclasses.pas

作工控的好控件

end;

procedure TVrBevel.SetOuterWidth(Value: TVrBevelWidth);
begin
  if FOuterWidth <> Value then
  begin
    FOuterWidth := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetOuterStyle(Value: TVrBevelStyle);
begin
  if FOuterStyle <> Value then
  begin
    FOuterStyle := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetOuterOutline(Value: TVrBevelOutlineStyle);
begin
  if FOuterOutline <> Value then
  begin
    FOuterOutline := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetOuterSpace(Value: TVrBevelSpace);
begin
  if FOuterSpace <> Value then
  begin
    FOuterSpace := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetOuterColor(Value: TColor);
begin
  if FOuterColor <> Value then
  begin
    FOuterColor := Value;
    Changed;
  end;
end;

procedure TVrBevel.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    Changed;
  end;
end;


procedure TVrBevel.GetVisibleArea(var Rect: TRect);
var
  BevelPixels: Integer;
begin
  BevelPixels := 0;
  if Visible then
  begin
    if FBorderWidth <> 0 then Inc(BevelPixels, FBorderWidth);
    if FInnerOutline <> osNone then Inc(BevelPixels);
    if FOuterOutline <> osNone then Inc(BevelPixels);

    Inc(BevelPixels, FInnerSpace);
    Inc(BevelPixels, FOuterSpace);

    if FInnerStyle <> bsNone then Inc(BevelPixels, FInnerWidth);
    if FOuterStyle <> bsNone then Inc(BevelPixels, FOuterWidth);
  end;
  InflateRect(Rect, -BevelPixels, -BevelPixels);
end;

procedure TVrBevel.Paint(Canvas: TCanvas; var Rect: TRect);
var
  TopColor, BottomColor: TColor;

  procedure AdjustColors(BevelStyle: TVrBevelStyle;
    ShadowColor, HighlightColor: TColor);
  begin
    TopColor := HighlightColor;
    if (BevelStyle = bsLowered) then TopColor := ShadowColor;
    BottomColor := ShadowColor;
    if (BevelStyle = bsLowered) then BottomColor := HighlightColor;
  end;

begin
  if Visible then
  begin
    if BorderWidth > 0 then
      DrawFrame3D(Canvas, Rect, BorderColor, BorderColor, BorderWidth);

    if OuterOutline = osOuter then
      DrawFrame3D(Canvas, Rect, clBlack, clBlack, 1);

    if OuterStyle <> bsNone then
    begin
      AdjustColors(OuterStyle, OuterShadow, OuterHighlight);
      DrawFrame3D(Canvas, Rect, TopColor, BottomColor, OuterWidth);
    end;

    if OuterOutline = osInner then
      DrawFrame3D(Canvas, Rect, clBlack, clBlack, 1);

    DrawFrame3D(Canvas, Rect, OuterColor, OuterColor, OuterSpace);

    if InnerOutline = osOuter then
      DrawFrame3D(Canvas, Rect, clBlack, clBlack, 1);

    if InnerStyle <> bsNone then
    begin
      AdjustColors(InnerStyle, InnerShadow, InnerHighlight);
      DrawFrame3D(Canvas, Rect, TopColor, BottomColor, InnerWidth);
    end;

    if InnerOutline = osInner then
      DrawFrame3D(Canvas, Rect, clBlack, clBlack, 1);

    DrawFrame3D(Canvas, Rect, InnerColor, InnerColor, InnerSpace);
  end; //visible
end;


{ TVrPalette }

constructor TVrPalette.Create;
begin
  inherited Create;
  FLow := clGreen;
  FHigh := clLime;
end;

procedure TVrPalette.SetLow(Value: TColor);
begin
  if FLow <> Value then
  begin
    FLow := Value;
    Changed;
  end;
end;

procedure TVrPalette.SetHigh(Value: TColor);
begin
  if FHigh <> Value then
  begin
    FHigh := Value;
    Changed;
  end;
end;

procedure TVrPalette.Assign(Source: TPersistent);
begin
  if (Source <> nil) and (Source is TVrPalette) then
  begin
    BeginUpdate;
    try
      Low := TVrPalette(Source).Low;
      High := TVrPalette(Source).High;
    finally
      EndUpdate;
    end;
  end else inherited Assign(Source);
end;

function TVrPalette.GetColors(Index: Integer): TColor;
begin
  Result := FLow;
  if Index > 0 then Result := FHigh;
end;

procedure TVrPalette.ToBMP(Bitmap: TBitmap; DarkColor, LightColor: TColor);
const
  ROP_DSPDxax = $00E20746;
var
  DestDC: HDC;
  DDB, MonoBmp: TBitmap;
  IWidth, IHeight: Integer;
  IRect: TRect;
begin
  IWidth := Bitmap.Width;
  IHeight := Bitmap.Height;
  IRect := Rect(0, 0, IWidth, IHeight);

  MonoBmp := TBitmap.Create;
  DDB := TBitmap.Create;
  try
    DDB.Assign(Bitmap);
    DDB.HandleType := bmDDB;

    with Bitmap.Canvas do
    begin
      MonoBmp.Width := IWidth;
      MonoBmp.Height := IHeight;
      MonoBmp.Monochrome := True;

      { Convert DarkColor to FLow }
      DDB.Canvas.Brush.Color := DarkColor;
      MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, IRect);

      Brush.Color := FLow;
      DestDC := Bitmap.Canvas.Handle;

      SetTextColor(DestDC, clBlack);
      SetBkColor(DestDC, clWhite);
      BitBlt(DestDC, 0, 0, IWidth, IHeight,
        MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);

      { Convert LightColor to FHigh }
      DDB.Canvas.Brush.Color := LightColor;
      MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, IRect);
      Brush.Color := FHigh;
      DestDC := Handle;
      SetTextColor(DestDC, clBlack);
      SetBkColor(DestDC, clWhite);
      BitBlt(DestDC, 0, 0, IWidth, IHeight,
        MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);
    end;
  finally
    DDB.Free;
    MonoBmp.Free;
  end;
end;


{ TVrMinMax }

constructor TVrMinMax.Create;
begin
  inherited Create;
  FMinValue := 0;
  FMaxValue := 100;
  FPosition := 0;
end;

procedure TVrMinMax.SetMinValue(Value: Integer);
begin
  if (FMinValue <> Value) and (Value < FMaxValue) then
  begin
    FMinValue :=  Value;
    if Position < Value then Position := Value
    else Changed;
  end;
end;

procedure TVrMinMax.SetMaxValue(Value: Integer);
begin
  if (FMaxValue <> Value) and (Value > FMinValue) then
  begin
    FMaxValue := Value;
    if Position > Value then Position := Value
    else Changed;
  end;
end;

procedure TVrMinMax.SetPosition(Value: Integer);
begin
  if Value < FMinValue then Value := FMinValue;
  if Value > FMaxValue then Value := FMaxValue;
  if FPosition <> Value then
  begin
    FPosition := Value;
    Changed;
  end;
end;

procedure TVrMinMax.Assign(Source: TPersistent);
begin
  if Source is TVrMinMax then
  begin
    BeginUpdate;
    try
      MinValue := TVrMinMax(Source).MinValue;
      MaxValue := TVrMinMax(Source).MaxValue;
      Position := TVrMinMax(Source).Position;
    finally
      EndUpdate;
    end;
  end
  else inherited Assign(Source);
end;

{ TVrTextOutline }

constructor TVrTextOutline.Create;
begin
  inherited Create;
  FColor := clNavy;
  FVisible := True;
end;

procedure TVrTextOutline.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor :=  Value;
    Changed;
  end;
end;

procedure TVrTextOutline.SetVisible(Value: Boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    Changed;
  end;
end;

procedure TVrTextOutline.Assign(Source: TPersistent);
begin
  if Source is TVrTextOutline then
  begin
    BeginUpdate;
    try
      Color := TVrTextOutline(Source).Color;
      Visible := TVrTextOutline(Source).Visible;
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

{ TVrFont3D }

constructor TVrFont3D.Create;
begin
  inherited Create;
  FStyle := f3dNone;
  FHighlightColor := clBtnHighlight;
  FShadowColor := clBtnShadow;
  FHighlightDepth := 1;
  FShadowDepth := 1;
end;

procedure TVrFont3D.Assign(Source: TPersistent);
begin
  if Source is TVrFont3D then
  begin
    BeginUpdate;
    try
      Style := TVrFont3D(Source).Style;
      HighlightColor := TVrFont3D(Source).HighlightColor;
      ShadowColor := TVrFont3D(Source).ShadowColor;
      HighlightDepth := TVrFont3D(Source).HighlightDepth;
      ShadowDepth := TVrFont3D(Source).ShadowDepth;
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TVrFont3D.SetStyle(Value: TVrFont3DStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    Changed;
  end;
end;

procedure TVrFont3D.SetHighlightColor(Value: TColor);
begin
  if FHighlightColor <> Value then
  begin
    FHighlightColor := Value;
    Changed;
  end;
end;

procedure TVrFont3D.SetShadowColor(Value: TColor);
begin
  if FShadowColor <> Value then
  begin
    FShadowColor := Value;
    Changed;
  end;
end;

procedure TVrFont3D.SetHighlightDepth(Value: Integer);
begin
  if FHighlightDepth <> Value then
  begin
    FHighlightDepth := Value;
    Changed;
  end;
end;

procedure TVrFont3D.SetShadowDepth(Value: Integer);
begin
  if FShadowDepth <> Value then
  begin
    FShadowDepth := Value;
    Changed;
  end;
end;

procedure TVrFont3D.Paint(Canvas: TCanvas; R: TRect; const Text: string; Flags: Integer);
var
  DestRect: TRect;
  OrgColor: TColor;
begin
  with Canvas do
  begin
    OrgColor := Font.Color;
    Brush.Style := bsClear;
    case Style of
      f3dNone: DrawText(Handle, PChar(Text), -1, R, Flags);
      f3dRaised:
        begin
          Font.Color := ShadowColor;
          DestRect := R;
          OffsetRect(DestRect, ShadowDepth, ShadowDepth);
          DrawText(Handle, PChar(Text), -1, DestRect, Flags);

          Font.Color := HighlightColor;
          DestRect := R;
          OffsetRect(DestRect, - HighlightDepth, - HighlightDepth);
          DrawText(Handle, PChar(Text), -1, DestRect, Flags);

          Font.Color := OrgColor;
          DrawText(Handle, PChar(Text), -1, R, Flags);
        end;
      f3dSunken:
        begin
          Font.Color := HighlightColor;
          DestRect := R;
          OffsetRect(DestRect, HighlightDepth, HighlightDepth);
          DrawText(Handle, PChar(Text), -1, DestRect, Flags);

          Font.Color := ShadowColor;
          DestRect := R;
          OffsetRect(DestRect, -ShadowDepth, -ShadowDepth);
          DrawText(Handle, PChar(Text), -1, DestRect, Flags);

          Font.Color := OrgColor;
          DrawText(Handle, PChar(Text), -1, R, Flags);
        end;
      f3dShadow:
        begin
          Font.Color := ShadowColor;
          DestRect := R;
          OffsetRect(DestRect, ShadowDepth, ShadowDepth);
          DrawText(Handle, PChar(Text), -1, DestRect, Flags);

          Font.Color := OrgColor;
          DrawText(Handle, PChar(Text), -1, R, Flags);
        end;
    end; //case
  end;
end;

{ TVrGlyphs }

constructor TVrGlyphs.Create;
begin
  inherited Create;
  FBitmap := TBitmap.Create;
  FNumGlyphs := 2;
end;

destructor TVrGlyphs.Destroy;
begin
  FBitmap.Free;
  inherited Destroy;
end;

procedure TVrGlyphs.Assign(Source: TPersistent);
begin
  if Source is TVrGlyphs then
  begin
    BeginUpdate;
    try
      Bitmap := TVrGlyphs(Source).Bitmap;
      NumGlyphs := TVrGlyphs(Source).NumGlyphs;
    finally