mmbmpbtn.pas

一套及时通讯的原码

         begin
            FSaveBitmap := TBitmap.Create;
            FSaveBitmap.Width  := Width;
            FSaveBitmap.Height := 2*Height;
            Repaint;
         end;
      end;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.PrepareGlyphs;
var
   Bmp,Glyph: TBitmap;
   TmpWidth,Cnt: integer;
   Dest,Source: TRect;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) or
      (csDestroying in ComponentState) then exit;

   if (Bitmap <> nil) and not Bitmap.Empty then
   begin
      Glyph := Bitmap;
      TmpWidth := Glyph.Width div FNumGlyphs;

      if AutoSize and (TmpWidth > 0) and (Glyph.Height > 0) then
         SetBounds(Left, Top, TmpWidth, Glyph.Height);

      Cnt := FNumGlyphs;
      if (FNumGlyphs = 1) or
         (((ButtonStyle = bsExplorer) or (ButtonStyle = bsHighLight)) and FAutoGray) then
            inc(Cnt,2);

      if (Cnt > FNumGlyphs) then
      begin
         if (FTempGlyph = nil) or not FFreeTempGlyph then
         begin
            FTempGlyph := TBitmap.Create;
            FFreeTempGlyph := True;
         end;

         FTempGlyph.Width := Cnt*TmpWidth;
         FTempGlyph.Height := Glyph.Height;
         FTempGlyph.HandleType := Bitmap.HandleType;

         { create the Temp Glyph }
         FTempGlyph.Canvas.Draw(0,0,Glyph);

         Bmp := TBitmap.Create;
         try
            Bmp.Width := TmpWidth;
            Bmp.Height := Glyph.Height;

            Dest := GetSrcRect(FNumGlyphs);
            Source := GetSrcRect(0);
            Bmp.Canvas.CopyRect(Source,Glyph.Canvas,Source);

            { create the disabled and grayed bitmaps too }
            CreateMonoBitmap(Bmp,11,59,30);
            FTempGlyph.Canvas.CopyRect(Dest,Bmp.Canvas,Source);

            Dest := GetSrcRect(FNumGlyphs+1);

            Bmp.Canvas.CopyRect(Source,Glyph.Canvas,Source);
            CreateBWBitmap(Bmp);
            FTempGlyph.Canvas.CopyRect(Dest,Bmp.Canvas,Source);
         finally
            Bmp.Free;
         end;
      end
      else
      begin
         if (FTempGlyph <> nil) and FFreeTempGlyph then
         begin
            FTempGlyph.Free;
            FTempGlyph := nil;
         end;
         FFreeTempGlyph := False;
         FTempGlyph := Glyph;
      end;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.Loaded;
begin
   inherited Loaded;

   PrepareGlyphs;
   SetDoubleBuffer(FDoubleBuffer);
end;

{-- TMMBitmapButton -----------------------------------------------------------}
function TMMBitmapButton.GetSrcRect(index: integer): TRect;
begin
   Result.Left := index * (Bitmap.Width div FNumGlyphs);
   Result.Top := 0;
   Result.Right := (index+1) * (Bitmap.Width div FNumGlyphs);
   Result.Bottom := Bitmap.Height;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.DetectNumGlyphs;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) or
      (csDestroying in ComponentState) then exit;

   if BitmapValid and (Bitmap.Height > 0) and (FNumGlyphs = 1) then
   with Bitmap do
   begin
      if Width mod Height = 0 then
      begin
         FNumGlyphs := Min(Width div Height,4);
      end;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetNumGlyphs(aValue: integer);
begin
   if (FNumGlyphs <> aValue) then
   begin
      FNumGlyphs := Max(aValue,1);
      PrepareGlyphs;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetAutoSize(Value: Boolean);
begin
   FAutoSize := Value;
   PrepareGlyphs;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetAutoGray(aValue: Boolean);
begin
   if (aValue <> FAutoGray) then
   begin
      FAutoGray := aValue;
      PrepareGlyphs;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetShowDisabled(aValue: Boolean);
begin
   if (aValue <> FShowDisabled) then
   begin
      FShowDisabled := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetButtonStyle(aValue: TMMButtonStyle);
begin
   if (FStyle <> aValue) then
   begin
      FStyle := aValue;
      PrepareGlyphs;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetCaption(aValue: TCaption);
begin
   if (FCaption <> aValue) then
   begin
      FCaption := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetBorderWidth(aValue: Cardinal);
begin
   if (FBorderSize <> aValue) then
   begin
      FBorderSize := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetStayDown(aValue: Boolean);
begin
   if (FStayDown <> aValue) then
   begin
      FStayDown := aValue;
      if FStayDown then
      begin
         FMouseDown := True;
         FState := bsDown;
      end
      else
      begin
         FMouseDown := False;
         FState := bsUp;
      end;
      Refresh;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetWordWrap(aValue: Boolean);
begin
   if (FWordWrap <> aValue) then
   begin
      FWordwrap := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetSpacing(aValue: integer);
begin
   if (aValue <> FSpacing) then
   begin
      FSpacing := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetTextAlign(aValue: TMMTextAlign);
begin
   if (FTextAlign <> aValue) then
   begin
      FTextAlign := aValue;
      Invalidate;
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.SetDownIndent(index, aValue: integer);
begin
   aValue := Max(aValue,0);
   case index of
       0: if FDownIndentH = aValue then exit else FDownIndentH := aValue;
       1: if FDownIndentV = aValue then exit else FDownIndentV := aValue;
   end;
   Invalidate;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.CMDialogChar(var Message: TCMDialogChar);
begin
   { Handle speedkeys (Alt + key) }
   with Message do
   if IsAccel(CharCode, FCaption) and Enabled then
   begin
      Click;
      Result := 1;
   end
   else inherited;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.CMTransColorChanged(var message: TMessage);
begin
   PrepareGlyphs;
   inherited;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.CMEnabledChanged(var Message: TMessage);
begin
   if not Enabled then
   begin
      FState     := bsUp;
      FMousedown := False;
      FIsDown    := False;
      FInButton  := False;
   end;
   Repaint;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.CMMouseEnter(var Msg: TMessage);
begin
   if Enabled and not FStayDown then
   begin
      FInButton := True;
      if (ButtonStyle = bsExplorer) or (ButtonStyle = bsHighLight) then RedrawButton;
      if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.CMMouseLeave(var msg: TMessage);
begin
   if Enabled and not FStayDown then
   begin
      FInButton := False;
      if (ButtonStyle = bsExplorer) or (ButtonStyle = bsHighLight) then RedrawButton;
      if Assigned(FOnMouseExit) then FOnMouseExit(Self);
   end;
end;

{-- TMMBitmapButton -----------------------------------------------------------}
function TMMBitmapButton.InBtn(X, Y: Integer): Boolean;
begin
   Result := PtInRect(ClientRect,Point(X,Y));
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
   Pt: TPoint;
   Msg: TMsg;

begin
   if (Button = mbLeft) or (AllowRightMouse and (Button = mbRight)) then
   begin
      if not Enabled or FIsDown then exit;

      MouseCapture := True;

      FIsDown := True;

      if InBtn(X,Y) then
      begin
         FMouseDown := True;
         FState := bsDown;
         RedrawButton;
      end;

      inherited MouseDown(Button,Shift,X,Y);

      if Assigned(PopUpMenu) and PopupMenu.AutoPopup then
      begin
         { calc where to put menu }
         Pt := ClientToScreen(Point(0, Height+2));

         PopupMenu.PopupComponent := Self;

         PopUpMenu.Popup(Pt.X, Pt.Y);

         { wait 'til menu is done }
         while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do;

         { release button }
         MouseUp(Button,Shift,X,Y);

         MouseCapture := False;
      end;
   end
   else inherited MouseDown(Button,Shift,X,Y);
end;

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) or (AllowRightMouse and (Button = mbRight)) then
   begin
      if not Enabled or not FIsDown then exit;

      FIsDown := False;

      FMouseDown := False;
      if not FStayDown then FState := bsUp;

      FInButton := InBtn(X,Y);

      if not Switch then
      begin
         RedrawButton;
      end
      else if FInButton then
      begin
         SetStayDown(not FStayDown);
      end;

      inherited MouseUp(Button,Shift,X,Y);

      MouseCapture := False;

      if FInButton then Click;
   end
   else inherited MouseUp(Button,Shift,X,Y);
end;

{$IFDEF BUILD_ACTIVEX}
{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.DoMouseTimer(Sender: TObject);
var
   P: TPoint;
begin
  GetCursorPos(P);
  if (FindDragTarget(P, True) <> Self) then
  begin
     FTimer.Free;
     FTimer := nil;
     Perform(CM_MOUSELEAVE, 0, 0);
  end;
end;
{$ENDIF}

{-- TMMBitmapButton -----------------------------------------------------------}
procedure TMMBitmapButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
   {$IFDEF BUILD_ACTIVEX}
   if InBtn(X,Y) then
   begin