mmcheck.pas

一套及时通讯的原码

end;

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

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

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
begin
   if (Width <> aWidth) or (Height <> aHeight) and (FSaveBitmap <> nil) then
   begin
      FSaveBitmap.Width  := aWidth;
      FSaveBitmap.Height := 2*aHeight;
   end;

   inherited SetBounds(aLeft, aTop, aWidth, aHeight);
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.Redraw;
begin
   if (csDesigning in ComponentState) then Repaint
   else
   begin
      { first copy the background to our bitmap }
      FSaveBitmap.Canvas.CopyRect(Rect(0,0,Width,Height),
                                  FSaveBitmap.Canvas,
                                  Rect(0,Height,Width,2*Height));
      { now draw the button to the bitmap }
      PaintControl(FSaveBitmap.Canvas);
      { copy to screen }
      Canvas.Draw(0,0,FSaveBitmap);
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetAlignment(aValue: TLeftRight);
begin
   if (aValue <> FAlignment) then
   begin
      FAlignment := aValue;
      Redraw;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetAllowGrayed(aValue: Boolean);
begin
   if (aValue <> FAllowGrayed) then
   begin
      FAllowGrayed := aValue;
      if not aValue then State := cbUnchecked;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetChecked(aValue: Boolean);
begin
   if (aValue <> FChecked) and Enabled then
   begin
      FChecked := aValue;
      if aValue then FState := cbChecked else FState := cbUnchecked;
      Redraw;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetState(aValue: TCheckBoxState);
begin
   if (aValue = cbGrayed) and not FAllowGrayed then Exit;
   if (aValue <> FState) and Enabled then
   begin
      FState := aValue;
      FChecked := FState = cbChecked;
      Redraw;
   end;
end;

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

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetMargin(aValue: TMargin);
begin
   if (aValue <> FMargin) then
   begin
      FMargin := aValue;
      Redraw;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.SetNumGlyphs(aValue: TNumGlyphs);
begin
   if (aValue <> FNumGlyphs) then
   begin
      FNumGlyphs := MinMax(aValue,1,4);
      Redraw;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.WMMouseMove(var Message: TWMMouseMove);
var
   CurrentPoint: TPoint;
begin
   CurrentPoint.X := Message.XPos;
   CurrentPoint.Y := Message.YPos;
   if FMouseOver and not FHasMouse and PtInRect(GetClientRect, CurrentPoint) then
   begin
      FHasMouse := True;
      Redraw;
   end;
   inherited;
end;

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

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.CMEnabledChanged(var Message: TWmNoParams);
begin
   inherited;
   Repaint;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.CMMouseEnter(var Message: TMessage);
begin
   inherited;
   if Enabled and AllowMouseOver  then
   begin
      FHasMouse := True;
      Redraw;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.CMMouseLeave(var Message: TMessage);
begin
   inherited;
   if Enabled and AllowMouseOver then
   begin
      FHasMouse := False;
      Redraw;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.CMTextChanged(var Message: TWmNoParams);
begin
   inherited;

   Redraw;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.CMVisibleChanged(var Message: TWmNoParams);
begin
   inherited;
   Repaint;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.CNCommand(var Message: TWMCommand);
begin
   if Message.NotifyCode = BN_CLICKED then Click;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.Click;
begin
   inherited Click;

   if AllowGrayed then
   case FState of
      cbUnchecked : FState := cbGrayed;
      cbGrayed    : FState := cbChecked;
      cbChecked   : FState := cbUnchecked;
   end
   else case FState of
      cbUnchecked : FState := cbChecked;
      cbChecked   : FState := cbUnchecked;
   end;
   Redraw;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.DblClick;
begin
   inherited DblClick;
   Click;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) and Enabled then
   begin
      FMouseIsDown := True;
      Redraw;
      inherited MouseDown(Button, Shift, X, Y);
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) and Enabled then
   begin
      FMouseIsDown := False;
      Redraw;
      inherited MouseUp(Button, Shift, X, Y);
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.PaintControl;
var
   SrcRect, DstRect, CaptRect: TRect;
   GlyphWidth, GlyphHeight: integer;
   uFormat: UINT;

begin
   if BitmapValid then
   begin
      if Enabled then
      begin
         case FState of
            cbUnchecked : SrcRect := GetSrcRect(0);
            cbChecked   : SrcRect := GetSrcRect(1);
            cbGrayed    : SrcRect := GetSrcRect(3);
         end;
      end
      else SrcRect := GetSrcRect(2);

      GlyphWidth  := Bitmap.Width div FNumGlyphs;
      GlyphHeight := Bitmap.Height;

      case Alignment of
          taLeftJustify  : begin
                              DstRect := Rect(1,
                                              (Height div 2)-(GlyphHeight div 2)-1,
                                              1+GlyphWidth,
                                              (Height div 2)-(GlyphHeight div 2)+GlyphHeight-1);
                           end;
          taRightJustify : begin
                              DstRect := Rect(ClientWidth-GlyphWidth-1,
                                              (Height div 2)-(GlyphHeight div 2)-1,
                                              ClientWidth-1,
                                              (Height div 2)-(GlyphHeight div 2)+GlyphHeight-1);
                           end;
      end;

      with Canvas do
      begin
         IntersectClipRect(Canvas.Handle,0,0,Width,Height);

         if not Transparent then
         begin
            Brush.Color := Color;
            Brush.Style := bsSolid;
            FillRect(ClientRect);
         end;

         DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle,
                                 DstRect.Left, DstRect.Top,
                                 SrcRect,
                                 GetTransparentColor);

         case Alignment of
           taLeftJustify  : CaptRect := Rect((GlyphWidth)+Margin, 0,
                                              ClientWidth-1, ClientHeight-1);
           taRightJustify : CaptRect := Rect(1, 0,
                                             ClientWidth-((GlyphWidth)+Margin),
                                             ClientHeight-1);
         end;
         uFormat := DT_SINGLELINE or DT_END_ELLIPSIS or DT_VCENTER;

         Font := Self.Font;

         if FHasMouse then
         begin
            Font.Style := FontActive.Style;
            Font.Color := FontActive.Color;
         end
         else
         begin
            Font.Style := FontInactive.Style;
            Font.Color := FontInactive.Color;
         end;

         Brush.Style := bsClear;

         if not Enabled then
         begin
            OffsetRect(CaptRect, 1, 1);
            Font.Color := clBtnHighlight;
            DrawText(Handle, PChar(Caption), Length(Caption), CaptRect, uFormat);
            OffsetRect(CaptRect, -1, -1);
            Font.Color := clBtnShadow;
         end;
         DrawText(Handle, PChar(Caption), Length(Caption), CaptRect, uFormat);

         Brush.Style := bsSolid;
      end;
   end
   else
   begin
      with Canvas do
      begin
         Font := Self.Font;
         Font.Color := clBlack;
         Brush.Style := bsClear;
         Pen.Style   := psDot;
         TextOut((ClientRect.Right-TextWidth(Caption)) div 2,(ClientRect.Bottom-TextHeight(Caption)) div 2,Caption);
         Canvas.Rectangle(ClientRect.Left,ClientRect.Top,ClientRect.Right,ClientRect.Bottom);
         Brush.Style := bsSolid;
         Pen.Style := psSolid;
      end;
   end;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.Paint;
begin
   if (FSaveBitmap <> nil) then
   begin
      { save the actual background }
      FSaveBitmap.Canvas.CopyRect(Rect(0,Height,Width,2*Height),Canvas,ClientRect);

      PaintControl(Canvas);
   end;
end;

end.