mmcheck.pas

一套及时通讯的原码

end;

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

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.SetChecked(aValue: Boolean);

{$IFNDEF BUILD_ACTIVEX}
  procedure TurnSiblingsOff;
  var
     I: Integer;
     Sibling: TControl;
  begin
     if Parent <> nil then
     with Parent do
     for i := 0 to ControlCount - 1 do
     begin
        Sibling := Controls[I];
        if (Sibling <> Self) and (Sibling is TMMBitmapRadioButton) then
            TMMBitmapRadioButton(Sibling).SetChecked(False);
     end;
  end;
{$ELSE}
  procedure TurnSiblingsOff;
  var
    ControlX, C: TMMActiveXControl;
    Dispatcher: TMMDispatcher;
    i: Integer;
  begin
    ControlX := MMActiveXControls.ControlsByDelphiControl[Self];
    Dispatcher := MMActiveXControls.DispatcherOfControl(ControlX);
    if not Assigned(ControlX) or not Assigned(Dispatcher) then
      exit;
    for i := 0 to Dispatcher.List.Count-1 do
    begin
      C := TMMActiveXControl(Dispatcher.List[i]);
      if (C <> ControlX) and (C.Control is TMMBitmapRadioButton) then
        TMMBitmapRadioButton(C.Control).Checked := False;
    end;
  end;
{$ENDIF}

begin
   if (FChecked <> aValue) then
   begin
      FChecked := aValue;
      if aValue then TurnSiblingsOff;
      Redraw;
   end;
end;

{-- TMMBitmapRadioButton ------------------------------------------------------}
function TMMBitmapRadioButton.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;

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

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

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.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;

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

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

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

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

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

   Redraw;
end;

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

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

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.Click;
begin
   inherited Click;
   Checked := True;
end;

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

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.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;

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.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;

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.PaintControl(Canvas: TCanvas);
var
   SrcRect, DstRect, CaptRect: TRect;
   GlyphWidth, GlyphHeight: integer;
   uFormat: UINT;
begin
   if BitmapValid then
   begin
      if Enabled then
         if FChecked then
            SrcRect := GetSrcRect(1)
         else
            SrcRect := GetSrcRect(0)
      else
         SrcRect := GetSrcRect(2);

      GlyphWidth  := Bitmap.Width div NumGlyphs;
      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);

         Font.Assign(Self.Font);

         if FHasMouse then
         begin
            Font.Style := FFontActive.Style;
            Font.Color := FFontActive.Color;
         end
         else
         begin
            Font.Style := FFontInactive.Style;
            Font.Color := FFontInactive.Color;
         end;

         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;

         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);
         Rectangle(ClientRect.Left,ClientRect.Top,ClientRect.Right,ClientRect.Bottom);
      end;
   end;
end;

{-- TMMBitmapRadioButton ------------------------------------------------------}
procedure TMMBitmapRadioButton.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;

{== TMMBitmapCheckBox =========================================================}
constructor TMMBitmapCheckBox.Create(aOwner: TComponent);
begin
   inherited Create(AOwner);

   if not (csDesigning in ComponentState) then
      ControlStyle := ControlStyle + [csSetCaption];

   ControlStyle := ControlStyle - [csOpaque];

   FFontActive          := TMMFontStyle.Create;
   FFontActive.Parent   := Self;
   FFontActive.Color    := clRed;
   FFontActive.Style    := [];

   FFontInactive        := TMMFontStyle.Create;
   FFontInactive.Parent := Self;
   FFontInactive.Color  := clBlack;
   FFontInactive.Style  := [];

   FSaveBitmap          := TBitmap.Create;
   FAlignment           := taLeftJustify;
   FAllowGrayed         := False;
   FChecked             := False;
   FState               := cbUnchecked;
   FMargin              := 7;
   FNumGlyphs           := 4;
   FMouseOver           := False;
   Transparent          := True;

   SetBounds(0,0,100,17);

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
destructor TMMBitmapCheckBox.Destroy;
begin
   FSaveBitmap.Free;
   FSaveBitmap := nil;

   FFontActive.Free;
   FFontInActive.Free;

   inherited Destroy;
end;

{-- TMMBitmapCheckBox ---------------------------------------------------------}
procedure TMMBitmapCheckBox.BitmapChanged;
begin
   DetectNumGlyphs;