vrsysutils.pas

作工控的好控件

end;

{ SetCanvasTextAngle }
procedure SetCanvasTextAngle(Canvas: TCanvas; Angle: Word);
var
  LogRec: TLOGFONT;
begin
  GetObject(Canvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
  LogRec.lfEscapement := Angle * 10;
  Canvas.Font.Handle := CreateFontIndirect(LogRec);
end;

{ CanvasTextOutAngle }
procedure CanvasTextOutAngle(Canvas: TCanvas; X, Y: Integer;
  Angle: Word; const Text: string);
var
  LogRec: TLOGFONT;
  OldFontHandle,
  NewFontHandle: HFONT;
begin
  GetObject(Canvas.Font.Handle, SizeOf(LogRec), Addr(LogRec));
  LogRec.lfEscapement := Angle * 10;
  NewFontHandle := CreateFontIndirect(LogRec);
  OldFontHandle := SelectObject(Canvas.Handle, NewFontHandle);
  Canvas.TextOut(X, Y, Text);
  NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
  DeleteObject(NewFontHandle);
end;

{ GetTextSize }
function GetTextSize(Canvas: TCanvas; const Text: string): TPoint;
var
  TextBounds: TRect;
begin
  TextBounds := Rect(0, 0, 0, 0);
  DrawText(Canvas.Handle, PChar(Text), Length(Text), TextBounds, DT_CALCRECT);
  Result := Point(TextBounds.Right - TextBounds.Left,
    TextBounds.Bottom - TextBounds.Top);
end;

{ Draw3DText }
procedure Draw3DText(Canvas: TCanvas; X, Y: Integer; const Text: String;
  HighEdge, LowEdge: TColor);
var
  OrgColor: TColor;
begin
  with Canvas do
  begin
    OrgColor := Font.Color;
    Brush.Style := bsClear;
    Font.Color := LowEdge;
    TextOut(X + 1, Y + 1, Text);
    Font.Color := HighEdge;
    TextOut(X - 1, Y - 1, Text);
    Font.Color := OrgColor;
    TextOut(X, Y, Text);
  end;
end;

{ DrawShadowTextExt }
procedure DrawShadowTextExt(Canvas: TCanvas; X, Y : Integer; const Text: string;
  ShadowColor: TColor; SX, SY: Integer);
var
  OrgColor: TColor;
begin
  with Canvas do
  begin
    OrgColor := Font.Color;
    Brush.Style := bsClear;
    Font.Color := ShadowColor;
    TextOut(X + SX, Y + SY, Text);
    Font.Color := OrgColor;
    TextOut(X, Y, Text);
  end;
end;

{ StretchPaintOnText }
procedure StretchPaintOnText(Dest: TCanvas; DestRect: TRect; X, Y : Integer;
  const Text: String; Bitmap: TBitmap; Angle: Word);
var
  R: TRect;
  FMask, FStore: TBitmap;
begin
  FMask := TBitmap.Create;
  try
    with FMask, FMask.Canvas do
    begin
      Monochrome := True;
      Font.Assign(Dest.Font);
      Font.Color := clBlack;
      Width := WidthOf(DestRect);
      Height := HeightOf(DestRect);
      SetCanvasTextAngle(FMask.Canvas, Angle);
      TextOut(X, Y, Text);
    end;

    FStore := TBitmap.Create;
    try
      with FStore do
      begin
        Width := FMask.Width;
        Height := FMask.Height;
        R := Rect(0, 0, Width, Height);
        with Canvas do
        begin
          CopyRect(R, Dest, Bounds(0, 0, Width, Height));
          CopyMode := cmSrcInvert;
          StretchDraw(R, Bitmap);
          CopyMode := cmSrcAnd;
          Draw(0, 0, FMask);
          CopyMode := cmSrcInvert;
          StretchDraw(R, Bitmap);
        end;
      end;
      Dest.Draw(0, 0, FStore);
    finally
      FStore.Free;
    end;

  finally
    FMask.Free;
  end;
end;

{ DrawOutlinedText }
procedure DrawOutlinedText(Canvas: TCanvas; X, Y : Integer; const Text: String;
  Color: TColor; Depth: Integer);
var
  I: Integer;
  Tmp: TColor;
begin
  with Canvas do
  begin
    Tmp := Font.Color;
    Font.Color := Color;
    Brush.Style := bsClear;
    for I := 1 to Depth do
    begin
      TextOut(X + I, Y + I, Text);
      TextOut(X - I, Y + I, Text);
      TextOut(X - I, Y - I, Text);
      TextOut(X + I, Y - I, Text);
    end;
    Font.Color := Tmp;
    TextOut(X, Y, Text);
  end;
end;

{ DrawRasterPattern }
procedure DrawRasterPattern(Canvas: TCanvas; Rect: TRect;
  ForeColor, BackColor: TColor; PixelSize, Spacing: Integer);
var
  R: TRect;
  X, Y: Integer;
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := (PixelSize + Spacing) * 20;
    Bitmap.Height := Bitmap.Width;

    with Bitmap do
    begin
      Canvas.Brush.Color := BackColor;
      Canvas.FillRect(Rect);
      Canvas.Brush.Color := ForeColor;
      X := 0;
      while X <= Width do
      begin
        Y := 0;
        while Y <= Height do
        begin
          R := Bounds(X, Y, PixelSize, PixelSize);
          Canvas.FillRect(R);
          Inc(Y, PixelSize + Spacing);
        end;
        Inc(X, PixelSize + Spacing);
      end;
    end;

    with Canvas do
    begin
      X := Rect.Left;
      while X < Rect.Right do
      begin
        Y := Rect.Top;
        while Y < Rect.Bottom do
        begin
          Draw(X, Y, Bitmap);
          Inc(Y, Bitmap.Height);
        end;
        Inc(X, Bitmap.Width);
      end;
    end;

  finally
    Bitmap.Free;
  end;
end;

{ StretchPaintOnText }
procedure StretchPaintOnRasterPattern(Dest: TCanvas; Rect: TRect;
  Image: TBitmap; ForeColor, BackColor: TColor; PixelSize, Spacing: Integer);
var
  R: TRect;
  FMask, FStore: TBitmap;
begin
  FMask := TBitmap.Create;
  try
    with FMask, FMask.Canvas do
    begin
      Width := WidthOf(Rect);
      Height := HeightOf(Rect);
      DrawRasterPattern(FMask.Canvas, Bounds(0, 0, Width, Height),
        clBlack, clWhite, PixelSize, Spacing);
    end;

    FStore := TBitmap.Create;
    try
      with FStore do
      begin
        Width := FMask.Width;
        Height := FMask.Height;
        R := Classes.Rect(0, 0, Width, Height);
        DrawRasterPattern(Canvas, R, ForeColor, BackColor,
          PixelSize, Spacing);
        with Canvas do
        begin
          CopyMode := cmSrcInvert;
          StretchDraw(R, Image);
          CopyMode := cmSrcAnd;
          Draw(0, 0, FMask);
          CopyMode := cmSrcInvert;
          StretchDraw(R, Image);
        end;
      end;

      Dest.Draw(0, 0, FStore);
    finally
      FStore.Free;
    end;
  finally
    FMask.Free;
  end;
end;

{ BitmapToLCD }
procedure BitmapToLCD(Dest: TBitmap; Source: TBitmap;
  ForeColor, BackColor: TColor; PixelSize, Spacing: Integer);
var
  R: TRect;
  FMask, FStore: TBitmap;
begin
  Dest.Width := Source.Width * (PixelSize + Spacing);
  Dest.Height := Source.Height * (PixelSize + Spacing);

  FMask := TBitmap.Create;
  try
    with FMask, FMask.Canvas do
    begin
      Width := Dest.Width;
      Height := Dest.Height;
      DrawRasterPattern(FMask.Canvas, Bounds(0, 0, Width, Height),
        clBlack, clWhite, PixelSize, Spacing);
    end;

    FStore := TBitmap.Create;
    try
      with FStore do
      begin
        Width := FMask.Width;
        Height := FMask.Height;
        R := Classes.Rect(0, 0, Width, Height);
        DrawRasterPattern(Canvas, R, ForeColor, BackColor,
          PixelSize, Spacing);
        with Canvas do
        begin
          CopyMode := cmSrcInvert;
          StretchDraw(R, Source);
          CopyMode := cmSrcAnd;
          Draw(0, 0, FMask);
          CopyMode := cmSrcInvert;
          StretchDraw(R, Source);
        end;
      end;

      Dest.Canvas.Draw(0, 0, FStore);
    finally
      FStore.Free;
    end;
  finally
    FMask.Free;
  end;
end;

{ DrawTiledBitmap - no clipping}
procedure DrawTiledBitmap(Canvas: TCanvas; const Rect: TRect; Glyph: TBitmap);
var
  X, Y: Integer;
begin
  X := Rect.Left;
  while X < Rect.Right do
  begin
    Y := Rect.Top;
    while Y < Rect.Bottom do
    begin
      Canvas.Draw(X, Y, Glyph);
      Inc(Y, Glyph.Height);
    end;
    Inc(X, Glyph.Width);
  end;
end;

{ BitmapRect }
function BitmapRect(Bitmap: TBitmap): TRect;
begin
  Result := Bounds(0, 0, Bitmap.Width, Bitmap.Height);
end;

{ ChangeBitmapColor }
procedure ChangeBitmapColor(Bitmap: TBitmap; FromColor, ToColor: 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 white to clBtnHighlight }
      DDB.Canvas.Brush.Color := FromColor;
      MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, IRect);

      Brush.Color := ToColor;
      DestDC := Bitmap.Canvas.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;

{DrawBitmap}
procedure DrawBitmap(Canvas: TCanvas; DestRect: TRect;
  Bitmap: TBitmap; SourceRect: TRect; Transparent: Boolean; TransColor: TColor);
begin
  with Canvas do
  begin
    if Transparent then
    begin
      Brush.Style := bsClear;
      BrushCopy(DestRect, Bitmap, SourceRect, TransColor);
    end
    else
    begin
      Brush.Style := bsSolid;
      StretchDraw(DestRect, Bitmap);
    end;
  end;
end;



end.