盒子论坛 v2.1

Windows操作系统自带的画图中的标签(透明组件源代码公布)

unit TouMingMapLabel;
{$R-}

interface

uses
  Windows, Messages, Controls, StdCtrls, Classes , Graphics ,Forms,ExtCtrls, Buttons,
  ExtDlgs, Menus, SysUtils, Dialogs;

const
  TMWM__SpecialInvalidate = WM_USER + 1111;
  sc_DragMove: Longint = $F012;

type
  TTransparentMemo = class(TMemo)
  private
    FRectList: array [1..8] of TRect;
    FPosList: array [1..8] of Integer;
    FCanvas: TControlCanvas;
    FBB:Boolean;
    FMapText:String;
    function GetCanvas:TControlCanvas;
    procedure WmSize (var Msg: TWmSize);message wm_Size;
    procedure WmLButtonDown (var Msg: TWmLButtonDown);message wm_LButtonDown;
    procedure WmNcHitTest (var Msg: TWmNcHitTest);message wm_NcHitTest;
    procedure SpecialInvalidate(var Message:TMessage); message TMWM__SpecialInvalidate;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMSetText(var Message:TWMSetText); message WM_SETTEXT;
    procedure SizerEnter(Sender:TObject);
    procedure SizerExit(Sender:TObject);
    procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message CN_CTLCOLOREDIT;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure SetMapText(const Value: String);
    procedure cmMousemove(var Msg:TWMMouseMove);message WM_MouseMove;
    procedure Change(Sender:TObject);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    property MapText:String read FMapText write SetMapText;
    property Canvas:TControlCanvas read GetCanvas;
end;

var
  a:Byte;

implementation

{ TTransparentMemo }
procedure TTransparentMemo.WMHScroll(var Message: TWMHScroll);
begin
  inherited;
  PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;

procedure TTransparentMemo.WMVScroll(var Message: TWMVScroll);
begin
  SendMessage(Handle,TMWM__SpecialInvalidate,0,0);
  inherited;
  PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;

procedure c(X,Y:Integer;t:TCanvas);stdcall;
begin
  a:=a shl 1;
  if a =0 then a:=1;
  if (a and 224)>0 then
    t.Pixels[X,Y]:=clWhite
  else
    t.Pixels[X,Y]:=clBlack;
end;

procedure TTransparentMemo.CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT);
var
  i:integer;
begin
  with Message do
    begin
      SetBkMode(ChildDC,TRANSPARENT);
      Result:=GetStockObject(HOLLOW_BRUSH);
      if FBB then Exit;
      Canvas.Brush.Color := clBlack;
      Canvas.Pen.Width:=1;
      LineDDA(0,0,Width,0,@c,LongInt(Canvas));
      LineDDA(Width-1,0,Width-1,Height,@c,LongInt(Canvas));
      LineDDA(0,0,0,Height,@c,LongInt(Canvas));
      LineDDA(0,Height-1,Width,Height-1,@c,LongInt(Canvas));
      for I := 1 to 8 do
        Canvas.Rectangle (FRectList [I].Left-1, FRectList [I].Top-1,FRectList [I].Right-1, FRectList [I].Bottom-1);
    end;
end;

procedure TTransparentMemo.WMSetText(var Message:TWMSetText);
begin
  inherited;
  if not (csDesigning in ComponentState) then
    PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;

procedure TTransparentMemo.SpecialInvalidate(var Message:TMessage);
var
  r:TRect;
begin
  if Parent<>nil then
    begin
      r:=ClientRect;
      r.TopLeft:=Parent.ScreenToClient(ClientToScreen(r.TopLeft));
      r.BottomRight:=Parent.ScreenToClient(ClientToScreen(r.BottomRight));
      InvalidateRect(Parent.Handle,@r,true);
      RedrawWindow(Handle,nil,0,RDW_FRAME+RDW_INVALIDATE);
    end;
end;

procedure TTransparentMemo.WMKeyDown(var Message: TWMKeyDown);
begin
  SendMessage(Handle,TMWM__SpecialInvalidate,0,0);
  inherited;
  PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;

procedure TTransparentMemo.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
  if SelText=' then
    PostMessage(Handle,WM_KEYDOWN,0,0);
end;

constructor TTransparentMemo.Create(AOwner: TComponent);
begin
inherited;
  FCanvas:=TControlCanvas.Create;
  FCanvas.Control:=Self;
  OnEnter:=SizerEnter;
  OnExit:=SizerExit;
  OnChange:=Change;
  ControlStyle := [csCaptureMouse, csDesignInteractive, csClickEvents,
  csSetCaption, csOpaque, csDoubleClicks, csReplicatable, csNoStdEvents];
  FBB:=True;
  BorderStyle:=bsNone;
  FPosList [1] := htTopLeft;
  FPosList [2] := htTop;
  FPosList [3] := htTopRight;
  FPosList [4] := htRight;
  FPosList [5] := htBottomRight;
  FPosList [6] := htBottom;
  FPosList [7] := htBottomLeft;
  FPosList [8] := htLeft;
end;

procedure TTransparentMemo.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    begin
      ExStyle:=ExStyle or WS_EX_TRANSPARENT and not WS_EX_WINDOWEDGE
      and not WS_EX_STATICEDGE and not WS_EX_DLGMODALFRAME and not WS_EX_CLIENTEDGE;
    end;
end;

function TTransparentMemo.GetCanvas: TControlCanvas;
begin
  Result:=FCanvas;
end;

procedure TTransparentMemo.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
  I: Integer;
begin
  Pt := Point (Msg.XPos, Msg.YPos);
  Pt := ScreenToClient (Pt);
  Msg.Result := 0;
  for I := 1 to 8 do
    if PtInRect (FRectList [I], Pt) then
      Msg.Result := FPosList [I];
  if Msg.Result = 0 then
  inherited;
end;

procedure TTransparentMemo.WmSize(var Msg: TWmSize);
begin
  FRectList [1] := Rect (0, 0, 5, 5);
  FRectList [2] := Rect (Width div 2 - 3, 0,Width div 2 + 2, 5);
  FRectList [3] := Rect (Width - 5, 0, Width, 5);
  FRectList [4] := Rect (Width - 5, Height div 2 - 3,Width, Height div 2 + 2);
  FRectList [5] := Rect (Width - 5, Height - 5,Width, Height);
  FRectList [6] := Rect (Width div 2 - 3, Height - 5,Width div 2 + 2, Height);
  FRectList [7] := Rect (0, Height - 5, 5, Height);
  FRectList [8] := Rect (0, Height div 2 - 3,5, Height div 2 + 2);
  inherited;
end;

procedure TTransparentMemo.SizerEnter(Sender: TObject);
begin
  FBB:=False;
  PostMessage(Handle,WM_SIZE,0,0);
end;

procedure TTransparentMemo.SizerExit(Sender: TObject);
begin
  if Text=' then
    begin
      Free;
      Exit;
    end;
  FBB:=True;
  if SelText<>' then
    PostMessage(Handle,WM_ERASEBKGND,0,0);
  PostMessage(Handle,WM_SIZE,0,0);
end;

procedure TTransparentMemo.SetMapText(const Value: String);
begin
  FMapText := Value;
  Lines.Text:=Value;
end;

procedure TTransparentMemo.WmLButtonDown(var Msg: TWmLButtonDown);
begin
  if (Msg.XPos<=2) or (Msg.YPos<=2) or ((Msg.XPos<=Width) and (Msg.XPos>=(Width-2))) or
   ((Msg.YPos<=Height) and (Msg.YPos>=(Height-2))) then
  begin
    Perform (wm_SysCommand, sc_DragMove, 0);
    PostMessage(Handle,WM_Size,0,0);
  end
  else inherited;
end;

procedure TTransparentMemo.cmMousemove(var Msg: TWMMouseMove);
begin
  if (Msg.XPos<=2) or (Msg.YPos<=2) or ((Msg.XPos<=Width) and (Msg.XPos>=(Width-2))) or
   ((Msg.YPos<=Height) and (Msg.YPos>=(Height-2))) then
     Cursor:=crHandPoint
  else Cursor:=crDefault;
end;

procedure TTransparentMemo.Change(Sender: TObject);
begin
  FMapText:=Lines.Text;
end;

end.
----------------------------------------------
-

作者：

YueJun_98 (YueJun_98)	★☆☆☆☆	-
	盒子活跃会员

2003/8/1 14:53:46

1楼：

如图:

----------------------------------------------
-

信息

登陆以后才能回复