GetFormImageで自作のコンポーネントをBITMAPに出力するには？ (ID:21725)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

早速のお返事ありがとうございます。
やってみます。

あつかましいのですが、下記のソースに至らぬところがあるのでしょうか？
こうしたほうが良いと言うところがあれば是非アドバイスください。

unit ShadowFont;

//
//   縁取り文字を表示するコンポーネントです。
//
//
//   作成  2005/09/22 ROOSTER
//

interface

uses Windows, Messages, SysUtils, Classes, Controls, Graphics, ComCtrls;

type

TShadowFont = class(TGraphicControl)
  protected
    F_Caption         : string;
    F_CaptionColor    : TColor;                            // キャプションの色
    F_CaptionEdge     : TColor;                               // キャプションのふちの色
    F_CaptionEdgeBold : integer;                  // キャプションのふちの色
    F_BackColor       : TColor;                             // 背景色
    F_ShowCaption     : Boolean;                      // 文字表示フラグ
    F_ShowCaptionEdge : Boolean;                  // 文字の枠表示フラグ
    F_CaptionAlign    : TAlign;             // 表示位置
    F_BorderLine      : Boolean;            // ボーダー表示
    F_BorderWidth     : integer;            // ボーダーの太さ
    F_BorderColor     : TColor;                   // ボーダーの色

procedure CaptionAlign_W    ( Value : TAlign);
    procedure Caption_W         ( Value : string);
    procedure CaptionEdge_W     ( Value : TColor);
    procedure CaptionEdgeBold_W ( Value : integer);
    procedure BackColor_W       ( Value : TColor);
    procedure ShowCaption_W     ( Value : Boolean);
    procedure ShowCaptionEdge_W ( Value : Boolean);
    procedure BorderWidth_W     ( Value : integer);
    procedure BorderLine_W      ( Value : Boolean);
    procedure BorderColor_W     ( Value : TColor);

procedure Paint; override;

public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;

published
    property CaptionAlign    : TAlign   read F_CaptionAlign write CaptionAlign_W;
    property Caption         : string        read F_Caption             write Caption_W;
    property ColorCaptionEdge: TColor     read F_CaptionEdge write CaptionEdge_W;
    property ColorBack       : TColor  read F_BackColor   write BackColor_W;
    property CaptionEdgeBold : integer       read F_CaptionEdgeBold     write CaptionEdgeBold_W;
    property ShowCaption     : Boolean   read F_ShowCaption write ShowCaption_W;
    property ShowCaptionEdge : Boolean       read F_ShowCaptionEdge     write ShowCaptionEdge_W;
    property BorderLine      : Boolean      read F_BorderLine  write BorderLine_W;
    property BorderWidth     : integer   read F_BorderWidth write BorderWidth_W;
    property BorderColor     : TColor    read F_BorderColor write BorderColor_W;
    property Font;
    property ParentFont;
    property Enabled;
    property Visible;
  end;

procedure Register;

implementation

procedure Register;
  begin
    RegisterComponents('user', [TShadowFont]);
  end;

//-----------------------------------------------------------------------------

procedure TShadowFont.CaptionAlign_W    ( Value : TAlign);
  begin
    if Value <> F_CaptionAlign then begin
      F_CaptionAlign := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.Caption_W         ( Value : string);
  begin
    if Value <> F_Caption then begin
      F_Caption := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.CaptionEdge_W     ( Value : TColor);
  begin
    if Value <> F_CaptionEdge then begin
      F_CaptionEdge := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.BackColor_W       ( Value : TColor);
  begin
    if Value <> F_BackColor then begin
      F_BackColor := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.ShowCaption_W     ( Value : Boolean);
  begin
    if Value <> F_ShowCaption then begin
      F_ShowCaption := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.ShowCaptionEdge_W ( Value : Boolean);
  begin
    if Value <> F_ShowCaptionEdge then begin
      F_ShowCaptionEdge := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.CaptionEdgeBold_W ( Value : integer);
  begin
    if Value <> F_CaptionEdgeBold then begin
      F_CaptionEdgeBold := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.BorderWidth_W ( Value : integer);
  begin
    if Value <> F_BorderWidth then begin
      F_BorderWidth := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.BorderLine_W ( Value : Boolean);
  begin
    if Value <> F_BorderLine then begin
      F_BorderLine := Value;
      Refresh;
    end;
  end;

procedure TShadowFont.BorderColor_W       ( Value : TColor);
  begin
    if Value <> F_BorderColor then begin
      F_BorderColor := Value;
      Refresh;
    end;
  end;

//-----------------------------------------------------------------------------

constructor TShadowFont.Create(AOwner: TComponent);
  begin
    inherited Create(AOwner);
    ControlStyle := ControlStyle + [csFramed, csOpaque];

F_Caption         := 'Tadashi.Y';
    F_CaptionEdge     := $000000;
    F_BackColor       := clBtnFace;
    F_CaptionEdge     := clWhite;
    F_ShowCaption     := True;
    F_ShowCaptionEdge := True;
    F_CaptionEdgeBold := 4;
    F_CaptionAlign    := alNone;
    F_BorderLine      := false;
    F_BorderWidth     := 1;
    F_BorderColor     := clBlack;
    Width:=64;
    Height:=16;
  end;
destructor TShadowFont.Destroy;
  begin
    inherited;
  end;

//=============================================================================

procedure TShadowFont.Paint;

procedure DrawText(Image:TBitmap);
    var
      size:Tsize;
      sx,sy:integer;
      s:string;
      dc:HDC;
      Bold:integer;
    begin
      s:=F_Caption;
      Image.Canvas.Font := Font;

Bold:=(F_CaptionEdgeBold) + (ord(F_BorderLine) * (F_BorderWidth div 2));
      size:=Image.Canvas.TextExtent(s);

case F_CaptionAlign of
        alNone:begin
            sx:=Bold;
            sy:=Bold;
        end;
        alTop:begin
            sx:=(Image.Width-size.cx) div 2;
            sy:=Bold;
        end;
        alLeft:begin
            sx:=Bold;
            sy:=(Image.Height-size.cy) div 2;
        end;
        alRight:begin
            sx:=(Image.Width-size.cx)-Bold;
            sy:=(Image.Height-size.cy) div 2;
        end;
        alBottom:begin
            sx:=(Image.Width-size.cx)div 2;
            sy:=(Image.Height-size.cy)-Bold;
        end;
        else begin
            sx:=(Image.Width-size.cx) div 2;
            sy:=(Image.Height-size.cy) div 2;
        end;
      end;

Image.Canvas.Brush.Style := bsClear;
      if F_ShowCaptionEdge then begin
        with Image.Canvas do begin
          Pen.Color:=F_CaptionEdge;
          Pen.Style :=psSolid;
          Pen.Width:=F_CaptionEdgeBold;
          dc:=Handle;
          Windows.BeginPath(dc);
          Windows.TextOut(dc,sx,sy,PCHAR(s), Length(s));
          Windows.EndPath(dc);
          Windows.StrokePath(dc);
          Pen.Width:=0;
          Windows.TextOut(Handle,sx,sy,PCHAR(s), Length(s));
        end;
      end
      else begin
        with Image.Canvas do begin
          Pen.Width:=0;
          Windows.TextOut(Handle,sx,sy,PCHAR(s), Length(s));
        end;
      end;

end;

//============================================================================

var
    Image: TBitmap;
  begin
    Image := TBitmap.Create;
    try
      Image.PixelFormat:=pf32bit;
      Image.HandleType:=bmDIB;

Image.Height := Self.Height;
      Image.Width  := Self.Width;
      Image.Canvas.Brush.Color := F_BackColor;
      Image.Canvas.Brush.Style := bsSolid;
      Image.Canvas.FillRect(ClientRect);
      Image.Canvas.Brush.Style := bsClear;

if (F_BorderLine) and (F_BorderWidth<>0) then begin
        Image.Canvas.Pen.Width:=F_BorderWidth;
        Image.Canvas.Pen.Color := F_BorderColor;
        Image.Canvas.Pen.Style := psSolid;
        Image.Canvas.Rectangle(0,0,Self.Width, Self.Height);
      end;

if F_ShowCaption then begin
        DrawText(Image);
      end;

Canvas.CopyMode := cmSrcCopy;
      Canvas.Draw(0, 0, Image);
    finally
      Image.Destroy;
    end;
  end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る