fcbutton.pas

一套及时通讯的原码

  begin
    FDown := Value;
    ChangeButtonDown;
    if FDown then NotifyChanging;
    if DoUpdateExclusive then UpdateExclusive;
    if DoInvalidate then Invalidate;
  end;
  if (GroupIndex > 0) and (boAutoBold in Options) then
  begin
    if FDown then Font.Style := Font.Style + [fsBold] else Font.Style := Font.Style - [fsBold];
  end;
end;

procedure TfcCustomBitBtn.UpdateExclusive;
var
  Msg: TMessage;
begin
  if (FGroupIndex <> 0) and (Parent <> nil) then
  begin
    Msg.Msg := CM_BUTTONPRESSED;
    Msg.WParam := FGroupIndex;
    Msg.LParam := Longint(Self);
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;

procedure TfcCustomBitBtn.SizeToDefault;
begin
end;

procedure TfcCustomBitBtn.UpdateShadeColors(Color: TColor);
begin
  ShadeColors.BtnShadow := fcModifyColor(Color, -50, True);
  ShadeColors.BtnBlack := fcModifyColor(ShadeColors.BtnShadow, -50, True);
  ShadeColors.Btn3dLight := fcModifyColor(Color, 50, True);
  ShadeColors.BtnHighlight := fcModifyColor(ShadeColors.Btn3dLight, 50, True);
end;

procedure TfcCustomBitBtn.RegisterChanges(Value: TfcChangeLink);
begin
   if FChangeLinks<>nil then { RSW - 3/5/99 }
      FChangeLinks.Add(Value);
end;

procedure TfcCustomBitBtn.UnRegisterChanges(Value: TfcChangeLink);
begin
   if FChangeLinks<>nil then { RSW - 3/5/99 }
      FChangeLinks.Remove(Value);
end;

{$ifdef fcDelphi4Up}
procedure TfcCustomBitBtn.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  begin
    with Glyph do
    begin
      Width := ImageList.Width;
      Height := ImageList.Height;
      Canvas.Brush.Color := clFuchsia;  // !!! Why clFuchsia?  Is this going to cause problems? -ksw
      Canvas.FillRect(Rect(0,0, Width, Height));
      ImageList.Draw(Canvas, 0, 0, Index);
    end;
  end;
begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if not (Glyph.Empty) then begin
        // Put Somethign Here
      end;
      // Copy image from action's imagelist
      if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
        CopyImage(ActionList.Images, ImageIndex);
    end;
end;
{$endif}

procedure TfcCustomBitBtn.Click;
var
  Form: TCustomForm;
  Control: TWinControl;
begin
  if DisableButton then exit;
  BasePatch[0]:= True;

  case FKind of
    bkClose: begin
      Form := GetParentForm(Self);
      if Form <> nil then Form.Close
      else inherited Click;
    end;
    bkHelp: begin
      Control := Self;
      while (Control <> nil) and (Control.HelpContext = 0) do
        Control := Control.Parent;
      if Control <> nil then Application.HelpContext(Control.HelpContext)
      else inherited Click;
    end;
    else begin
      Form := GetParentForm(Self);
      if Form <> nil then Form.ModalResult := ModalResult;
      inherited Click;
    end;
  end;
  BasePatch[0]:= False;
  invalidate;
end;

procedure TfcCustomBitBtn.Loaded;
begin
  inherited;
  if not (boFocusable in Options) then TabStop := False;
  ApplyRegion;

  NotifyLoaded;
end;

procedure TfcCustomBitBtn.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if Key = VK_SPACE then
  begin
    ProcessMouseDown;
    ProcessMouseUp(-1, -1, True, True);
    Click; { 7/26/99 - Call click on space }
  end;
end;

procedure TfcCustomBitBtn.ProcessMouseDown;
begin
  if DisableButton then exit;
  FInitialDown := Down;
  if not (boToggleOnUp in Options) or (GroupIndex = 0) then
  begin
    if (boFocusable in Options) then SetFocus; { 7/26/99 - Set focus when mouse is pressed on button }
    SetButtonDown(True, True, False, False);
  end;
  if FInitialDown <> Down then Redraw;
end;

procedure TfcCustomBitBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin

  { 3/9/00 - Don't check key state as mouse could already be released }
  if (Button = mbLeft) {and (GetKeyState(VK_LBUTTON) < 0) }then
  begin
    FClicked := True;
    SetCaptureControl(self);
//    MouseCapture:= True; { Equivalent - Perhaps change to this in the future }

    ProcessMouseDown;
  end;
  { 5/1/00 - Added flag because sendmessage in MouseActivate causes some recursion when using the OnMouseDown.  Specifically the MenuForm example project}
  if (not FInMouseSendForMouseActivate) or (BasePatch[1] = True) then
     inherited;
//  else inherited
end;

procedure TfcCustomBitBtn.MouseMove(Shift: TShiftState; X, Y: Integer);
var IsMouseInControl: Boolean;
begin
  if DisableButton then exit;

  inherited;

  if ((boToggleOnUp in Options)) or not FClicked or (GetKeyState(VK_LBUTTON) >= 0) then Exit;

  IsMouseInControl := MouseInControl(x, y, True);

  if (IsMouseInControl and not Down) or
     ((not IsMouseInControl and Down) and not FInitialDown) then
  begin
    SetButtonDown(IsMouseInControl, False, False, False);
    Redraw;
  end;
end;

procedure TfcCustomBitBtn.ProcessMouseUp(X, Y: Integer; AMouseInControl: Boolean; AClicked: Boolean);
begin
  if DisableButton then exit;
  if (GroupIndex = 0) then
  begin
    SetButtonDown(False, False, False, False);
    Redraw;
  end else begin
    UpdateExclusive;
    if AMouseInControl or (boToggleOnUp in Options) then
    begin
      if ((FInitialDown and AllowAllUp) or (not FInitialDown)) then
      begin
        SetButtonDown(not FInitialDown, True, True, False);
        Redraw;
        SelChange;
      end;
    end;
  end;
end;

procedure TfcCustomBitBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;

  {7/13/99 - PYW - Changed to always process mouse up in fcoutlookbar}
  if (not ShowDownAsUp) and fcIsClass(Parent.ClassType, 'TfcCustomOutlookBar') then
     ProcessMouseUp(x, y, True, FClicked)
  else
     ProcessMouseUp(x, y, MouseInControl(x, y, True), FClicked);

//  MouseCapture:= False; { 4/2/99  Equivalent - Perhaps change to this in the future }
  SetCaptureControl(nil);

  //2/26/99 - Check for ToggleOnUp so that Click will be fired when button has
  //          different up/down regions.
  if MouseInControl(x, y, True) or (boToggleOnUp in Options) then Click;

  FClicked := False;
end;

procedure TfcCustomBitBtn.SetName(const Value: TComponentName);
begin
  inherited;
  if Assigned(FOnSetName) then FOnSetName(self);
end;

procedure TfcCustomBitBtn.CMButtonPressed(var Message: TMessage);
var
  Sender: TfcCustomBitBtn;
begin
  if Message.WParam = FGroupIndex then
  begin
    if not (TObject(Message.LParam) is TfcCustomBitBtn) then Exit;
    Sender := TfcCustomBitBtn(Message.LParam);
    if (Sender.Down) then
    begin
       if Sender<>Self then
          SetButtonDown(False, False, False, True);
       if Sender<>Self then
          SelChange // 7/22/01 Call SelChange so that is selected
       else
          FSelected := Down; // 9/20/01 - Don't call SelChange if Sender=Self, but just set FSelected
                             // This corrects slowness when outlookbar is changning pages
    end;

  end;
end;

procedure TfcCustomBitBtn.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
  begin
    if  (((CharCode = VK_RETURN) and FActive) or
      ((CharCode = VK_ESCAPE) and FCancel)) and
      (KeyDataToShiftState(Message.KeyData) = []) and CanFocus then
    begin
      Click;
      Result := 1;
    end else if IsAccel(CharCode, GetDBCaption) and CanFocus then begin
      //Down := not Down;
      // 1/3/2000 - Use SetButtonDown procedure so AllowAllUp is considered.
      if GroupIndex > 0 then  // 10/15/2001- Only set this if groupindex > 0.
         SetButtonDown(True, True, True, False);

      Click;
      Invalidate;
      Result := 1;
    end else inherited;
  end;
end;

procedure TfcCustomBitBtn.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TfcCustomBitBtn.CMFocusChanged(var Message: TCMFocusChanged);
begin
  with Message do
    if Sender is TfcCustomBitBtn then
      FActive := Sender = Self
    else
      FActive := FDefault;
  inherited;
end;

procedure TfcCustomBitBtn.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if (ShadeStyle = fbsFlat) or (NumGlyphs = 4) then Invalidate;
  if fcUseThemes(self) then Invalidate;
//  if ThemeServices.ThemesEnabled then Invalidate;
  if Assigned(FOnMouseEnter) then FOnMouseEnter(self);
  FHot:= True;
end;

procedure TfcCustomBitBtn.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if (ShadeStyle = fbsFlat) or (NumGlyphs = 4) then Invalidate;
  if fcUseThemes(self) then Invalidate;
//  if ThemeServices.ThemesEnabled then Invalidate;
  if Assigned(FOnMouseLeave) then FOnMouseLeave(self);
  FHot:= False;
end;

procedure TfcCustomBitBtn.CNMeasureItem(var Message: TWMMeasureItem);
begin
  with Message.MeasureItemStruct^ do
  begin
    ItemWidth := Width;
    ItemHeight := Height;
  end;
end;

procedure TfcCustomBitBtn.CNDrawItem(var Message: TWMDrawItem);
begin
  DrawItem(Message.DrawItemStruct^);
end;

procedure TfcCustomBitBtn.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TfcCustomBitBtn.WMLButtonDown(var Message: TWMLButtonDown);
begin
  SendCancelMode(Self);
  if csCaptureMouse in ControlStyle then MouseCapture := True;
  if csClickEvents in ControlStyle then ControlState := ControlState + [csClicked];
  with Message do
    MouseDown(mbLeft, KeysToShiftState(Keys) + [], XPos, YPos);
end;

procedure TfcCustomBitBtn.WMMouseActivate(var Message: TWMMouseActivate);
var Button: TMouseButton;
    Shift: TShiftState;

  function GetShiftState: TShiftState;
  begin
    Result := [];
    if GetKeyState(VK_SHIFT) < 0 then Include(Result, ssShift);
    if GetKeyState(VK_CONTROL) < 0 then Include(Result, ssCtrl);
  end;

  function ShiftStateToKeys(State: TShiftState): Word;
  begin
     Result := 0;
     if ssShift in State then Result:= Result + MK_SHIFT;
     if ssCtrl in State then Result:= Result + MK_CONTROL;
     if ssLeft in State then Result:= Result + MK_LBUTTON;
     if ssRight in State then Result:= Result + MK_RBUTTON;
  end;

begin
  { 6/19/2000 - PYW -  Solve mousedown problems with nonfocusable buttons.}
  if BasePatch[1] = False then begin
     inherited;
     exit;
  end;

  if (csDesigning in ComponentState) or (boFocusable in Options) then inherited
  else begin
    Message.result := MA_NOACTIVATEANDEAT;
    if Message.MouseMsg = WM_LBUTTONDOWN then Button := mbLeft else Button := mbRight;
    Shift := GetShiftState;
    if Button = mbLeft then include(Shift, ssLeft) else include(Shift, ssRight);

    GetParentForm(self).BringToFront; // Added to make sure form is shown when user clicks on button. (Avoid IE5 scroll button problems) -ksw (2/19/99)

    with ScreenToClient(fcGetCursorPos) do
      if (x>=0) and (y>=0) then { RSW - 4/16/99 }
      begin
         if Button=mbLeft then begin
            { 3/9/00 - Changed to SendMessage to ensure button down processed before button up }
            { 5/1/00 - Added flag because sendmessage causes some recursion when using the OnMouseDown.  Specifically the MenuForm example project}
            FInMouseSendForMouseActivate := True;
            SendMessage(Handle, WM_LBUTTONDOWN, ShiftStateToKeys(Shift), MAKELPARAM(x, y));
            FInMouseSendForMouseActivate := False;
//             {4/12/00 - Added back the postmessage because sendmessage causes some recursion when using the OnMouseDown.  Specifically the MenuForm example project}
//              PostMessage(Handle, WM_LBUTTONDOWN, ShiftStateToKeys(Shift), MAKELPARAM(x, y))
         end
         else
            PostMessage(Handle, WM_RBUTTONDOWN, ShiftStateToKeys(Shift), MAKELPARAM(x, y))
      end
  end;
end;

function TfcCustomBitBtn.GetKind: TBitBtnKind;
begin
  if FKind <> bkCustom then