maskimagebutton.pas

机房管理系统 是用VB设计的简单的管理系统

    begin

      ShowHint := FPrevShowHint;
      FPrevShowHintSaved := False;
    end;
    if FPrevCursorSaved then
    begin
      Cursor := FPrevCursor;
      FPrevCursorSaved := False;
    end;
  end;

end;

procedure TMaskImgBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  DoClick := PtInMask(X, Y);
  if (FState = bsDown) then
    begin
      FState := bsUp;
      Repaint;
    end;
    if DoClick then Click;
end;

procedure TMaskImgBtn.Click;
begin
  inherited Click;
end;

function TMaskImgBtn.GetPalette: HPALETTE;
begin
  Result := FBitmap.Palette;
end;

procedure TMaskImgBtn.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;

procedure TMaskImgBtn.SetBitmapUp(Value: TBitmap);
begin
  FBitmapUp.Assign(Value);
end;

procedure TMaskImgBtn.SetBitmapDown(Value: TBitmap);
begin
  FBitmapDown.Assign(Value);
end;

procedure TMaskImgBtn.BitmapChanged(Sender: TObject);
var OldCursor: TCursor;
    W, H: Integer;
begin
  AdjustBounds;

  if not ((csReading in ComponentState) or (csLoading in ComponentState)) then
  begin
    if FBitmap.Empty then
    begin

      SetBitmapUp(nil);
      SetBitmapDown(nil);
    end
    else
    begin
      W := FBitmap.Width;
      H := FBitmap.Height;
      OldCursor := Screen.Cursor;
      Screen.Cursor := crHourGlass;
      try
        if (FBitmapUp.Width <> W) or (FBitmapUp.Height <> H) or
          (FBitmapDown.Width <> W) or (FBitmapDown.Height <> H) then
        begin
          FBitmapUp.Width := W;
          FBitmapUp.Height := H;
          FBitmapDown.Width := W;
          FBitmapDown.Height := H;
        end;
        Create3DBitmap(FBitmap, bsUp, FBitmapUp);
        Create3DBitmap(FBitmap, bsDown, FBitmapDown);

        FHitTestMask.Free;
        FHitTestMask := MakeMask(FBitmapUp, FBitmap.TransparentColor);

      finally
        Screen.Cursor := OldCursor;
      end;
    end;
  end;
  Invalidate;

end;

procedure TMaskImgBtn.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TMaskImgBtn.CMFontChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TMaskImgBtn.CMTextChanged(var Message: TMessage);
begin
  Invalidate;
end;

procedure TMaskImgBtn.CMSysColorChange(var Message: TMessage);
begin
  BitmapChanged(Self);
end;

function TMaskImgBtn.BevelColor(const AState: TButtonState; const TopLeft: Boolean): TColor;
begin
  if (AState = bsUp) then
  begin
    if TopLeft then Result := clBtnHighlight
    else Result := clBtnShadow
  end
  else { bsDown }
  begin
    if TopLeft then Result := clBtnShadow
    else Result := clBtnHighlight;
  end;
end;


procedure TMaskImgBtn.Create3DBitmap(Source: TBitmap; const AState: TButtonState; Target: TBitmap);
type OutlineOffsetPts = Array[1..3, 0..1, 0..12] of Apair;
const
  OutlinePts: OutlineOffsetPts =
    ( (((1,-1),(1,0),(1,1),(0,1),(-1,1),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
       ((-1,0),(-1,-1),(0,-1),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0))),
      (((2,-2),(2,-1),(2, 0),(2, 1),(2, 2),(1, 2),(0, 2),(-1,2),(-2,2),(0,0),(0,0),(0,0),(0,0)),
       ((-2,1),(-2,0),(-2,-1),(-2,-2),(-1,-2),(0,-2),(1,-2),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0))),
      (((3,-3),(3,-2),(3,-1),(3,0),(3,1),(3,2),(3,3),(2,3),(1,3),(0,3),(-1,3),(-2,3),(-3,3)),
       ((-3,2),(-3,1),(-3,0),(-3,-1),(-3,-2),(-3,-3),(-2,-3),(-1,-3),(0,-3),(1,-3),(2,-3),(0,0),(0,0)))
    );
var I, J, W, H, Outlines: Integer;
    R: TRect;
    OutlineMask, Overlay, NewSource: TBitmap;
begin
  if (Source = nil) or (Target = nil) then
    Exit;

  W := Source.Width;
  H := Source.Height;
  R := Rect(0, 0, W, H);

  Overlay := TBitmap.Create;
  NewSource := TBitmap.Create;

  try

    NewSource.Width := W;
    NewSource.Height := H;


    Target.Canvas.CopyMode := cmSrcCopy;
    Target.Canvas.CopyRect(R, Source.Canvas, R);

    Overlay.Width := W;
    Overlay.Height := H;

    Outlines := FBevelWidth;
      Inc(Outlines);

    for I := 1 to Outlines do
    begin
      with NewSource.Canvas do
      begin
        CopyMode := cmSrcCopy;
        CopyRect(R, Target.Canvas, R);
      end;

      for J := 0 to 1 do
      begin
        if (AState = bsDown) and (I = Outlines) and (J = 0) then
          Continue;

        OutlineMask := MakeBorder(Source, NewSource, OutlinePts[I, J],
                        FBitmap.TransparentColor);
        try
          with Overlay.Canvas do
          begin
            if (I = Outlines)  then
              Brush.Color := clBlack
            else
              Brush.Color := BevelColor(AState, (J = 1));
            CopyMode := $0030032A; { PSna }
            CopyRect(R, OutlineMask.Canvas, R);
          end;

          with Target.Canvas do
          begin

            CopyMode := cmSrcAnd; { DSa }
            CopyRect(R, OutlineMask.Canvas, R);

            CopyMode := cmSrcPaint; { DSo }
            CopyRect(R, Overlay.Canvas, R);
            CopyMode := cmSrcCopy;
          end;

        finally
          OutlineMask.Free;
        end;

      end;
    end;

  finally
    Overlay.Free;
    NewSource.Free;

  end;
end;

procedure TMaskImgBtn.DrawButtonText(Canvas: TCanvas; const Caption: String;
  TextBounds: TRect; State: TButtonState);
var
  CString: array[0..255] of Char;
begin
  StrPCopy(CString, Caption);
  Canvas.Brush.Style := bsClear;
  if State = bsDown then OffsetRect(TextBounds, 1, 1);
  DrawText(Canvas.Handle, CString, -1, TextBounds,
      DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;

procedure TMaskImgBtn.Loaded;
var BigMask: TBitmap;
    R: TRect;
begin
  inherited Loaded;
  if (FBitmap <> nil) and (FBitmap.Width > 0) and (FBitmap.Height > 0) then
  begin
    FHitTestMask.Free;
    FHitTestMask := MakeMask(FBitmap, FBitmap.TransparentColor);
    BigMask := MakeMask(FBitmapUp, FBitmap.TransparentColor);
    try
      R := Rect(0, 0, FBitmap.Width, FBitmap.Height);
      FHitTestMask.Canvas.CopyMode := cmSrcAnd;
      FHitTestMask.Canvas.CopyRect(R, BigMask.Canvas, R);
    finally
      BigMask.Free;
    end;
  end;
end;


procedure TMaskImgBtn.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('BitmapUp', ReadBitmapUpData, WriteBitmapUpData, not FBitmapUp.Empty);
  Filer.DefineBinaryProperty('BitmapDown', ReadBitmapDownData, WriteBitmapDownData, not FBitmapDown.Empty)
end;

procedure TMaskImgBtn.ReadBitmapUpData(Stream: TStream);
begin
  FBitmapUp.LoadFromStream(Stream);
end;

procedure TMaskImgBtn.WriteBitmapUpData(Stream: TStream);
begin
  FBitmapUp.SaveToStream(Stream);
end;

procedure TMaskImgBtn.ReadBitmapDownData(Stream: TStream);
begin
  FBitmapDown.LoadFromStream(Stream);
end;

procedure TMaskImgBtn.WriteBitmapDownData(Stream: TStream);
begin
  FBitmapDown.SaveToStream(Stream);
end;

procedure TMaskImgBtn.AdjustBounds;
begin
  SetBounds(Left, Top, Width, Height);
end;

procedure TMaskImgBtn.AdjustSize(var W, H: Integer);
begin
  if not (csReading in ComponentState) and FAutoSize and not FBitmap.Empty then
  begin
    W := FBitmap.Width;
    H := FBitmap.Height;
  end;
end;

procedure TMaskImgBtn.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    AdjustBounds;
  end;
end;

procedure TMaskImgBtn.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var W, H: Integer;
begin
  W := AWidth;
  H := AHeight;
  AdjustSize(W, H);
  inherited SetBounds(ALeft, ATop, W, H);
end;

procedure TMaskImgBtn.Invalidate;
var R: TRect;
begin
  if (Visible or (csDesigning in ComponentState)) and
    (Parent <> nil) and Parent.HandleAllocated then
  begin
    R := BoundsRect;
    InvalidateRect(Parent.Handle, @R, True);
  end;
end;

procedure Register;
begin
  RegisterComponents('Wuqiu', [TMaskImgBtn]);
end;

end.