acmagn.pas

Alpha Controls 5.40,delphi上的alpha开发源码控件包。没有密码。5.40版的最新版。

unit acMagn;
{$I sDefs.inc}
{.$DEFINE LOGGED}

interface

uses
  Windows, Messages, Graphics, Forms, Menus, Classes, Controls,
  ExtCtrls{$IFDEF LOGGED}, sDebugMsgs, sPanel{$ENDIF};

type
  TPosChangingEvent = procedure(var X : integer; var Y : integer) of object;

  TsMagnifier = class(TComponent)
{$IFNDEF NOTFORHELP}
  private
    FScaling: integer;
    FPopupMenu: TPopupMenu;
    FOnMouseUp: TMouseEvent;
    FOnMouseDown: TMouseEvent;
    FOnPosChanging: TPosChangingEvent;
    FOnDblClick: TNotifyEvent;
    procedure SetScaling(const Value: integer);
  public
    IsModal : boolean;
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
{$ENDIF}
    procedure Execute(x : integer = -1; y : integer = -1);
    procedure Hide;
    function  IsVisible : Boolean;
    function  GetPosition : TPoint;
  published
    property PopupMenu : TPopupMenu read FPopupMenu write FPopupMenu;
    property Scaling : integer read FScaling write SetScaling default 2;

    property OnDblClick : TNotifyEvent read FOnDblClick write FOnDblClick;
    property OnMouseDown : TMouseEvent read FOnMouseDown write FOnMouseDown;
    property OnMouseUp : TMouseEvent read FOnMouseUp write FOnMouseUp;
    property OnPosChanging : TPosChangingEvent read FOnPosChanging write FOnPosChanging;
  end;

{$IFNDEF NOTFORHELP}
  TacMagnForm = class(TForm)
    PopupMenu1: TPopupMenu;
    Image1: TImage;
    N1x1: TMenuItem;
    N2x1: TMenuItem;
    N8x1: TMenuItem;
    N1: TMenuItem;
    Close1: TMenuItem;
    N16x1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure Close1Click(Sender: TObject);
    procedure Zoom1x1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormShow(Sender: TObject);
    procedure Image1DblClick(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  protected
    procedure WMPosChanging (var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  public
    Caller        : TObject;
    Fregion       : hrgn;
    FTempBmp     : TBitMap;
    FCacheBmp     : TBitmap;
    AlphaBmp      : TBitmap;
    MaskBmp       : TBitmap;
    Scale         : Smallint;
    Size          : Smallint;
    MagnBmp       : TBitmap;
    MagnShadowBmp : TBitmap;
    destructor Destroy; override;
    procedure WndProc(var Message : TMessage); override;
    procedure Loaded; override;
    procedure RefreshView;
    procedure SetZooming(k : integer);
    procedure ShowGlass(x, y : integer);
    procedure CreateAlphaBmp;
  end;

var
  FDowned      : boolean;
  OldTop       : integer = -1;
  Closing      : boolean = False;
  Showed       : boolean = False;
  Refreshing   : boolean = False;
  acIsDragging : boolean = False;
  
{$ENDIF}

implementation

{$R *.DFM}

uses sGraphUtils, sConst, {acntUtils, }SysUtils, sAlphaGraph, sSkinManager,
  sVclUtils, {sStyleSimply, }sMessages;

const
  HiddenTop = -300;
  lWidth = 230;
  lHeight = 230;

procedure TacMagnForm.ShowGlass(x, y : integer);
var
  R : TRect;
  DC : hdc;
  FBmpSize: TSize;
  FBmpTopLeft: TPoint;
  FBlend: TBlendFunction;
  FastMask : TacFast24;
  FastBody : TacFast24;
  FastDst : TacFast32;
  c : TsColor;
  XOffs, YOffs, i, p, StepCount : integer;
begin
  if MagnBmp = nil then Exit;
//  if not Active or (Top = HiddenTop) then Exit;
  if DefaultManager <> nil then DefaultManager.SkinableMenus.HookPopupMenu(Image1.PopupMenu, DefaultManager.Active);

  XOffs := Round(X + (Size - Size / Scale) / 2);
  YOffs := Round(Y + (Size - Size / Scale) / 2);

  if @UpdateLayeredWindow = nil then begin
    StretchBlt(FTempBmp.Canvas.Handle, 0, 0, 200, 200, FCacheBmp.Canvas.Handle,
               XOffs,
               YOffs,
               Size div Scale, Size div Scale, SrcCopy);
  end
  else begin
    DC := GetDC(0); 
    StretchBlt(FTempBmp.Canvas.Handle, 0, 0, 200, 200, DC,
                 XOffs,
                 YOffs,
                 Size div Scale, Size div Scale, SrcCopy);
    ReleaseDC(0, DC);
  end;

  R := Rect(0, 0, 200, 200);
  CopyByMask(R, R, FTempBmp, MagnBmp, EmptyCI, True);

  if @UpdateLayeredWindow <> nil then begin // If Layered

    FBmpSize.cx := lWidth;
    FBmpSize.cy := lHeight;
    FBmpTopLeft := Point(0, 0);

    with FBlend do begin
      BlendOp := AC_SRC_OVER;
      BlendFlags := 0;
      AlphaFormat := $01;
      SourceConstantAlpha := 255;
    end;

    if AlphaBmp = nil then CreateAlphaBmp;

    FastMask := TacFast24.Create;
    FastBody := TacFast24.Create;
    FastDst := TacFast32.Create;
    if FastDst.Attach(AlphaBmp) and FastMask.Attach(MaskBmp) and FastBody.Attach(FTempBmp) then begin
      for y := 0 to 200 - 1 do for x := 0 to 200 - 1 do begin
        if FastMask.Pixels[x, y].R = 0 then begin
          c := FastBody.Pixels[x, y];
          c.A := 255;
          FastDst[x + 10, y + 10] := c;
        end;
      end;
    end;
    FreeAndnil(FastMask);
    FreeAndnil(FastBody);
    FreeAndnil(FastDst);

    DC := GetDC(0);
    if not Showed and (DefaultManager <> nil) and DefaultManager.AnimEffects.DialogShow.Active then begin
      StepCount := 200{DefaultManager.AnimEffects.DialogShow.Time} div 10;
      if StepCount > 0 then begin
        p := 255 div StepCount;
        i := 0;
        while i <= StepCount do begin
          FBlend.SourceConstantAlpha := i * p;
          UpdateLayeredWindow(Handle, DC, nil, @FBmpSize, AlphaBmp.Canvas.Handle, @FBmpTopLeft, clNone, @FBlend, $00000002);
          inc(i);
          if (i > StepCount) then Break;
          if StepCount > 0 then Sleep(10);
        end;
      end;
    end
    else UpdateLayeredWindow(Handle, DC, nil, @FBmpSize, AlphaBmp.Canvas.Handle, @FBmpTopLeft, clNone, @FBlend, $00000002);
    Showed := True;
    ReleaseDC(0, DC);
  end
  else begin
    Image1.Picture.Assign(FTempBmp);
  end
end;

{$R magn.res}

procedure TacMagnForm.FormCreate(Sender: TObject);
begin
  Size := Width;
  if @UpdateLayeredWindow = nil then FCacheBmp := CreateBmp24(Screen.Width, Screen.Height);
  FTempBmp := CreateBmp24(200, 200);

  MagnBmp := TBitmap.Create;
  MagnBmp.LoadFromResourceName(HInstance, 'MAGN');
  MagnBmp.PixelFormat := pf24bit;
  MagnShadowBmp := TBitmap.Create;
  MagnShadowBmp.LoadFromResourceName(HInstance, 'MAGNSHADOW');
  MagnShadowBmp.PixelFormat := pf24bit;
end;

procedure TacMagnForm.Close1Click(Sender: TObject);
begin
  Close;
end;

procedure TacMagnForm.SetZooming(k: integer);
begin
  Scale := k;
  ShowGlass(Left, Top);
end;

procedure TacMagnForm.Zoom1x1Click(Sender: TObject);
begin
  TsMagnifier(Caller).Scaling := TMenuItem(Sender).Tag;
  TMenuItem(Sender).Checked := True;
end;

procedure TacMagnForm.WMPosChanging(var Message: TWMWindowPosChanging);
begin
  if not Showed or Closing or (csloading in ComponentState) or
    (csCreating in ControlState) or (OldTop <> -1) or (csDestroying in ComponentState) or
      (csDestroying in Application.ComponentState) then Exit;

  if Assigned(TsMagnifier(Caller).OnPosChanging) and (Message.WindowPos^.cx <> 0) and (Message.WindowPos^.cy <> 0) then begin
    TsMagnifier(Caller).OnPosChanging(Message.WindowPos^.X, Message.WindowPos^.Y)
  end
  else begin
    if Message.WindowPos^.X < - 100 then Message.WindowPos^.X := - 100 else
    if Message.WindowPos^.X + Width > Screen.Width + 100 then Message.WindowPos^.X := Screen.Width + 100 - Width;
    if Message.WindowPos^.Y < - 100 then Message.WindowPos^.Y := - 100 else
    if Message.WindowPos^.Y + Height > Screen.Height + 100 then Message.WindowPos^.Y := Screen.Height + 100 - Height;
  end;

  if (Message.WindowPos^.X = 0) and (Message.WindowPos^.Y = 0)
    then ShowGlass(Left, Top)
    else ShowGlass(Message.WindowPos^.X, Message.WindowPos^.Y);
end;

procedure TacMagnForm.Loaded;
begin
  inherited;
end;

procedure TacMagnForm.WndProc(var Message: TMessage);
begin
{$IFDEF LOGGED}
  case Message.Msg of
    WM_NCHITTEST, WM_MOUSEMOVE, WM_SETCURSOR, WM_WINDOWPOSCHANGING,
    WM_NCCALCSIZE, WM_NCPAINT, WM_MOVE, WM_MOVING, WM_ERASEBKGND,
    WM_WINDOWPOSCHANGED :
    else AddToLog(Message);
  end;
{$ENDIF}
  case Message.Msg of
    WM_ERASEBKGND, WM_NCPAINT : Exit;
  end;
  inherited;
  if Message.Msg = SM_ALPHACMD then case Message.WParamHi of
    AC_REFRESH : begin
      ShowGlass(Left, Top);
    end;
  end;
  case Message.Msg of
    WM_ACTIVATE : if not Refreshing and not (csDestroying in ComponentState) and not (csDestroying in Application.ComponentState) then begin
      RefreshView;
      ShowGlass(Left, Top);
    end;
  end;
end;

procedure TacMagnForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Showed := False;
  Closing := True;
  if Application.MainForm <> Self then begin
    Action := caFree;
    acMagnForm := nil;
  end;
end;

procedure TacMagnForm.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if Assigned(TsMagnifier(Caller).OnMouseDown) then TsMagnifier(Caller).OnMouseDown(Caller, Button, Shift, X, Y);
  if not Refreshing and (mbLeft = Button) then begin
    acIsDragging := True;
    ReleaseCapture;
    Perform(WM_SYSCOMMAND, $F012, 0);
  end;
end;

procedure TacMagnForm.CreateAlphaBmp;
var
  FastDst : TacFast32;
  FastShadow : TacFast24;
  x, y : integer;
  c : TsColor;
begin
  FastDst := TacFast32.Create;
  FastShadow := TacFast24.Create;

  AlphaBmp := CreateBmp32(lWidth, lHeight);
  FillDC(AlphaBmp.Canvas.Handle, Rect(0, 0, lWidth, lHeight), 0);

  MaskBmp := CreateBmp24(200, 200);
  MaskBmp.Canvas.Brush.Color := 0;
  MaskBmp.Canvas.Ellipse(0, 0, 200, 200);
  MaskBmp.PixelFormat := pf24bit;

  if FastDst.Attach(AlphaBmp) and FastShadow.Attach(MagnShadowBmp) then
  begin
    for y := 0 to lHeight - 1 do
    for x := 0 to lWidth  - 1 do
    begin
      c.I := 0;
      c.A := 255 - FastShadow.Pixels[x, y].R;
      FastDst[x, y] := c;
    end;
  end;

  FreeAndnil(FastDst);
  FreeAndnil(FastShadow);
end;

{ TsMagnifier }

constructor TsMagnifier.Create(AOwner: TComponent);
begin
  inherited;
  FScaling := 2;
  IsModal := False;
end;

destructor TsMagnifier.Destroy;
begin
  if Assigned(acMagnForm) then FreeAndNil(acMagnForm);
  inherited;
end;

procedure TsMagnifier.Execute(x : integer = -1; y : integer = -1);
var
  i : integer;
begin
  if acMagnForm = nil then begin
    acMagnForm := TacMagnForm.Create(nil);
    TacMagnForm(acMagnForm).Caller := Self;

    TacMagnForm(acMagnForm).Scale := FScaling;

    if FPopupMenu <> nil then TacMagnForm(acMagnForm).Image1.PopupMenu := FPopupMenu else begin
      for i := 0 to TacMagnForm(acMagnForm).PopupMenu1.Items.Count - 1 do if TacMagnForm(acMagnForm).PopupMenu1.Items[i].Tag = FScaling then begin
        TacMagnForm(acMagnForm).PopupMenu1.Items[i].Checked := True;
        Break;
      end;
    end;
    if (x <> -1) or (y <> -1) then begin
      TacMagnForm(acMagnForm).Position := poDesigned;
      acMagnForm.Left := x;
      acMagnForm.Top := y;
    end;

    if @UpdateLayeredWindow = nil then begin
      TacMagnForm(acMagnForm).FormStyle := fsNormal;
      TacMagnForm(acMagnForm).FRegion := CreateEllipticRgn(1, 1, 200, 200);
      SetWindowRgn(TacMagnForm(acMagnForm).Handle, TacMagnForm(acMagnForm).Fregion, true);
      TacMagnForm(acMagnForm).RefreshView;
    end
    else begin
      TacMagnForm(acMagnForm).Width := lWidth;
      TacMagnForm(acMagnForm).Height := lHeight;
      SetWindowLong(TacMagnForm(acMagnForm).Handle, GWL_EXSTYLE, GetWindowLong(acMagnForm.Handle, GWL_EXSTYLE) or $00080000);
    end;

    if IsModal then TacMagnForm(acMagnForm).ShowModal else TacMagnForm(acMagnForm).Show;
  end
  else TacMagnForm(acMagnForm).BringToFront
end;

var
  User32Lib: Cardinal = 0;

procedure TacMagnForm.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = 27 then Close;
end;

function TsMagnifier.IsVisible: Boolean;
begin
  if acMagnForm <> nil
    then Result := TForm(acMagnForm).Visible
    else Result := False;
end;

function TsMagnifier.GetPosition: TPoint;
begin
  if acMagnForm <> nil then begin
    Result.X := TForm(acMagnForm).Left;
    Result.Y := TForm(acMagnForm).Top ;
  end
  else begin
    Result.X := -1;
    Result.Y := -1;
  end;
end;

procedure TsMagnifier.Hide;
begin
  if acMagnForm <> nil then TForm(acMagnForm).Close //FreeAndNil(acMagnForm);
end;

procedure TsMagnifier.SetScaling(const Value: integer);
begin
  if FScaling = Value then Exit;
  if Value < 2 then FScaling := 2 else if Value > 16 then FScaling := 16 else FScaling := Value;
  if acMagnForm <> nil then TacMagnForm(acMagnForm).SetZooming(FScaling);
end;

procedure TacMagnForm.RefreshView;
var
  DC: HDC;
begin
  if (@UpdateLayeredWindow = nil) and not Refreshing and not (csDestroying in ComponentState) and (FCacheBmp <> nil) {and (Left > 0) and (Top > 0) and (Left + Width < Screen.Width) and (Top + Height < Screen.Height)} then begin
    Refreshing := True;
    OldTop := Top;
    Top := HiddenTop;
    Delay(100);

    DC := GetDC(0);
    BitBlt(FCacheBmp.Canvas.Handle, 0, 0, FCacheBmp.Width, FCacheBmp.Height, DC, 0, 0, SrcCopy);
    ReleaseDC(0, DC);

    Top := OldTop;

    OldTop := -1;
    Refreshing := False
  end;
end;

procedure TacMagnForm.FormShow(Sender: TObject);
begin
  Closing := False;
end;

procedure TacMagnForm.Image1DblClick(Sender: TObject);
begin
  if Assigned(TsMagnifier(Caller).OnDblClick) then TsMagnifier(Caller).OnDblClick(Caller);
end;

procedure TacMagnForm.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
{$IFDEF DELPHI7UP}
  if not Mouse.IsDragging and acIsDragging then
{$ENDIF}
  begin
    if Assigned(TsMagnifier(Caller).OnMouseUp) then TsMagnifier(Caller).OnMouseUp(Caller, mbLeft, Shift, X, Y);
    acIsDragging := False;
  end
end;

destructor TacMagnForm.Destroy;
begin
  if Assigned(MagnBmp) then FreeAndNil(MagnBmp);
  if Assigned(MagnShadowBmp) then FreeAndNil(MagnShadowBmp);

  if (@UpdateLayeredWindow = nil) and Assigned(FCacheBmp) then FreeAndNil(FCacheBmp);
  if Assigned(FTempBmp) then FreeAndNil(FTempBmp);
  if Assigned(AlphaBmp) then FreeAndNil(AlphaBmp);
  if Assigned(MaskBmp) then FreeAndNil(MaskBmp);
  inherited;
end;

initialization
  if @UpdateLayeredWindow = nil then begin
    User32Lib := LoadLibrary('USER32');
    try
      if User32Lib <> 0
        then UpdateLayeredWindow := GetProcAddress(User32Lib, 'UpdateLayeredWindow')
        else @UpdateLayeredWindow := nil;
    finally
    end;
  end;

finalization
  if User32Lib <> 0 then FreeLibrary(User32Lib);

end.