文字だけ表示するフォーム (ID:30273)

名前

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

本文

これやったの４年前ですが
情報源がちゃんと書いてありました、えらいぞおれ！
リンク先は健在です。
//FDelphiより
//"不定形なフォーム(Windows2000専用)"
//http://delfusa.main.jp/delfusafloor/archive/www.nifty.ne.jp_forum_fdelphi/samples/01218.html
//
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDblClick(Sender: TObject);
  private
    { Private 宣言 }
    BMP32:TBitmap;
  public
    { Public 宣言 }
  end;

function UpdateLayeredWindow(_hwnd:HWND; dstHDC:HDC; pptDst:PPoint;
         ASize:PSize; srcHDC:HDC; pptSrc:PPoint; crKey:COLORREF;
         var bf : BLENDFUNCTION; dwFlag:DWORD):BOOL; stdcall;
const
  WS_EX_LAYERED = $80000;
  LWA_COLORKEY  = 1;
  LWA_ALPHA     = 2;
  ULW_COLORKEY  = 1;
  ULW_ALPHA     = 2;
  ULW_OPAQUE    = 4;
  AC_SRC_ALPHA  = 1;

function UpdateLayeredWindow;
  external 'user32.dll' name 'UpdateLayeredWindow';

var
  Form1: TForm1;

implementation

{$R *.dfm}
function MakeLayer(wHandle:HWND; LayerBmp:TBitmap):boolean;
var
  bf : TBlendFunction;
  zerop : TPoint;
  formsz : TSize;
begin
  result:=false;
  with bf do begin
    BlendOp:=AC_SRC_OVER;
    BlendFlags:=0;
    SourceConstantAlpha:=255; // 完全にALPHAをBITMAPに依存する場合
    AlphaFormat:=AC_SRC_ALPHA;
  end;
  //２度め以降は不要？
  SetWindowLong(wHandle, GWL_EXSTYLE, GetWindowLong(wHandle, GWL_EXSTYLE) or
                WS_EX_LAYERED);
  zerop.x:=0; zerop.y:=0;
  formsz.cx:=LayerBmp.Width; formsz.cy:=LayerBmp.Height;
  if not UpdateLayeredWindow(
        wHandle, 0,
        nil, // palleteを気にしないならnilでよろし
        @formsz, // フォームの大きさの指定 : 必須！
        LayerBmp.canvas.handle, // サーフェイスを定義するDC
        @zerop, // サーフェイスを定義する画像の開始点
        0, bf, ULW_ALPHA) then begin
    ShowMessage(SysErrorMessage(GetLastError));
    Exit;
  end;
  result:=true;
end;

procedure TForm1.Button1Click(Sender: TObject);
var x,y:integer;
    P1,P2:PByteArray;
    Alpha:Integer;
    MaskBMP:TBitmap;
    deg,i,p:Integer;
begin
  deg:=30;

BMP32.Canvas.Font:=Label1.Font;
  BMP32.Height:=BMP32.Canvas.TextHeight(Label1.Caption)+deg;
  BMP32.Width :=BMP32.Canvas.TextWidth(Label1.Caption)+deg;
  BMP32.Canvas.Brush.Style:=bsSolid;
  BMP32.Canvas.Pen.Color:=clBlack;
  BMP32.Canvas.Brush.Color:=clBlack;
  BMP32.Canvas.Rectangle(0,0,BMP32.Width,BMP32.Height);
  BMP32.Canvas.TextOut(0,0,Label1.Caption);

//マスクは32bitである必要ありません。(分かり易く今回は32bitです)
  MaskBMP:=TBitmap.Create;
  MaskBMP.Canvas.Font:=Label1.Font;
  MaskBMP.Assign(BMP32);
  MaskBMP.Canvas.Pen.Color:=clBlack;
  MaskBMP.Canvas.Brush.Color:=clBlack;
  MaskBMP.Canvas.Rectangle(0,0,MaskBMP.Width,MaskBMP.Height);
  MaskBMP.Canvas.Brush.Style:=bsClear;
  for i:=deg-1 downto 1 do
  begin
    p:= 255-round(255/deg)*i;
    MaskBMP.Canvas.Font.Color:=RGB(p,p,p) ;
    MaskBMP.Canvas.TextOut(i,i,Label1.Caption);
  end;

MaskBMP.Canvas.Font.Color:=clWhite;
  MaskBMP.Canvas.TextOut(0,0,Label1.Caption);

{形の元となるビットマップは、以下のことに気をつけてください。
R=255, G=127, B=63 の点を ALPHA=100(0なら透明、255なら不透明)
で抜きたいときは、32BIT BITMAPのその点のデータを
  R = 255 * 100 div 255 = 100
  G = 127 * 100 div 255 =  49
  B =  63 * 100 div 255 =  24
  Alpha = 100
にしてください。}

for Y:=0 to BMP32.Height-1 do
  begin
    P1 :=BMP32.ScanLine[y];
    P2 :=MaskBMP.ScanLine[y];
    for X:=0 to BMP32.Width -1 do
    begin
      //もっと美しく処理した方がいいと思いますが
      //分かりやすいようにしてあります。
      Alpha:=(P2[x*4+0 ] +
              P2[x*4+1 ] +
              P2[x*4+2 ]) div 3;
      P1[x*4+0 ]:=  P1[x*4+0 ] * Alpha div 255;
      P1[x*4+1 ]:=  P1[x*4+1 ] * Alpha div 255;
      P1[x*4+2 ]:=  P1[x*4+2 ] * Alpha div 255;
      P1[x*4+3 ]:=  Alpha;
    end;
  end;

MakeLayer(Handle, BMP32);
  ClientHeight:=BMP32.Height;
  ClientWidth :=BMP32.Width;
  MaskBMP.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);

begin
  BMP32:=TBitmap.Create;
  BMP32.PixelFormat:=pf32bit;
  FormStyle:=fsStayOnTop;
  BorderStyle:=bsNone;

Label1.Font.Size:=22;
  Label1.Font.Color:=clRed;
  Label1.Caption:='東京都特許許可局';
  Label1.OnDblClick:=FormDblClick;
  OnDblClick       :=FormDblClick;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  BMP32.Free;
end;

procedure TForm1.FormDblClick(Sender: TObject);
begin
  Close;
end;

end.

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

戻る