rm_tb97ctls.pas

中小企业管理系统------ ERP系统原代码

    Inc (X, Client.Left + Offset.X);
    Inc (Y, Client.Top + Offset.Y);
  end;
  OffsetRect (TextBounds, TextPos.X + Client.Left + Offset.X,
    TextPos.Y + Client.Top + Offset.X);
end;

function TButtonGlyph.Draw (Canvas: TCanvas; const Client: TRect;
  const Offset: TPoint; DrawGlyph, DrawCaption: Boolean; const Caption: string;
  WordWrap: Boolean; Alignment: TAlignment; Layout: TButtonLayout;
  Margin, Spacing: Integer; DropArrow: Boolean; DropArrowWidth: Integer;
  State: TButtonState97): TRect;
var
  GlyphPos, ArrowPos: TPoint;
begin
  CalcButtonLayout (Canvas, Client, Offset, DrawGlyph, DrawCaption, Caption,
    WordWrap, Layout, Margin, Spacing, DropArrow, DropArrowWidth, GlyphPos,
    ArrowPos, Result);
  if DrawGlyph then
    DrawButtonGlyph (Canvas, GlyphPos, State);
  if DrawCaption then
    DrawButtonText (Canvas, Caption, Result, WordWrap, Alignment, State);
  if DropArrow then
    DrawButtonDropArrow (Canvas, ArrowPos.X, ArrowPos.Y, DropArrowWidth, State);
end;


{ TDropdownList }

{$IFNDEF TB97D4}

type
  TDropdownList = class(TComponent)
  private
    List: TList;
    Window: HWND;
    procedure WndProc (var Message: TMessage);
  protected
    procedure Notification (AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddMenu (Menu: TPopupMenu);
  end;
var
  DropdownList: TDropdownList;

constructor TDropdownList.Create (AOwner: TComponent);
begin
  inherited;
  List := TList.Create;
end;

destructor TDropdownList.Destroy;
begin
  inherited;
  if Window <> 0 then
    DeallocateHWnd (Window);
  List.Free;
end;

procedure TDropdownList.WndProc (var Message: TMessage);
{ This procedure is based on code from TPopupList.WndProc (menus.pas) }
var
  I: Integer;
  MenuItem: TMenuItem;
  FindKind: TFindItemKind;
  ContextID: Integer;
begin
  try
    with List do
      case Message.Msg of
        WM_COMMAND:
          for I := 0 to Count-1 do
            if TPopupMenu(Items[I]).DispatchCommand(TWMCommand(Message).ItemID) then
              Exit;
        WM_INITMENUPOPUP:
          for I := 0 to Count-1 do
            if TPopupMenu(Items[I]).DispatchPopup(TWMInitMenuPopup(Message).MenuPopup) then
              Exit;
        WM_MENUSELECT:
          with TWMMenuSelect(Message) do begin
            FindKind := fkCommand;
            if MenuFlag and MF_POPUP <> 0 then
              FindKind := fkHandle;
            for I := 0 to Count-1 do begin
              MenuItem := TPopupMenu(Items[I]).FindItem(IDItem, FindKind);
              if MenuItem <> nil then begin
                Application.Hint := MenuItem.Hint;
                Exit;
              end;
            end;
            Application.Hint := '';
          end;
        WM_HELP:
          with TWMHelp(Message).HelpInfo^ do begin
            for I := 0 to Count-1 do
              if TPopupMenu(Items[I]).Handle = hItemHandle then begin
                ContextID := TPopupMenu(Items[I]).GetHelpContext(iCtrlID, True);
                if ContextID = 0 then
                  ContextID := TPopupMenu(Items[I]).GetHelpContext(hItemHandle, False);
                if Screen.ActiveForm = nil then Exit;
                if (biHelp in Screen.ActiveForm.BorderIcons) then
                  Application.HelpCommand (HELP_CONTEXTPOPUP, ContextID)
                else
                  Application.HelpContext (ContextID);
                Exit;
              end;
          end;
      end;
    with Message do
      Result := DefWindowProc(Window, Msg, wParam, lParam);
  except
    Application.HandleException (Self);
  end;
end;

procedure TDropdownList.AddMenu (Menu: TPopupMenu);
begin
  if List.IndexOf(Menu) = -1 then begin
    if Window = 0 then
      Window := AllocateHWnd(WndProc);
    Menu.FreeNotification (Self);
    List.Add (Menu);
  end;
end;

procedure TDropdownList.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then begin
    List.Remove (AComponent);
    if (List.Count = 0) and (Window <> 0) then begin
      DeallocateHWnd (Window);
      Window := 0;
    end;
  end;
end;

{$ENDIF}


{ TToolbarButton97 }

procedure ButtonHookProc (Code: THookProcCode; Wnd: HWND; WParam: WPARAM; LParam: LPARAM);
var
  P: TPoint;
begin
  case Code of
    hpSendActivateApp:
      if (WParam = 0) and Assigned(ButtonMouseInControl) and
         not ButtonMouseInControl.FShowBorderWhenInactive then
        ButtonMouseInControl.MouseLeft;
    hpPostMouseMove: begin
        if Assigned(ButtonMouseInControl) then begin
          GetCursorPos (P);
          if FindDragTarget(P, True) <> ButtonMouseInControl then
            ButtonMouseInControl.MouseLeft;
        end;
      end;
  end;
end;

constructor TToolbarButton97.Create (AOwner: TComponent);
begin
  inherited;

  if ButtonMouseTimer = nil then begin
    ButtonMouseTimer := TTimer.Create(nil);
    ButtonMouseTimer.Enabled := False;
    ButtonMouseTimer.Interval := 125;  { 8 times a second }
  end;

  InstallHookProc (ButtonHookProc, [hpSendActivateApp, hpPostMouseMove],
    csDesigning in ComponentState);

  SetBounds (Left, Top, 23, 22);
  ControlStyle := [csCaptureMouse, csDoubleClicks, csOpaque];
  Color := clBtnFace;
  FGlyph := TButtonGlyph.Create;
  TButtonGlyph(FGlyph).OnChange := GlyphChanged;
  ParentFont := True;
  FAlignment := taCenter;
  FFlat := True;
  FHighlightWhenDown := True;
  FOpaque := True;
  FSpacing := 4;
  FMargin := -1;
  FLayout := blGlyphLeft;
  FDropdownArrow := True;
  FDropdownArrowWidth := DefaultDropdownArrowWidth;
  FRepeatDelay := 400;
  FRepeatInterval := 100;
  Inc (ButtonCount);
end;

destructor TToolbarButton97.Destroy;
begin
  RemoveButtonMouseTimer;
  TButtonGlyph(FGlyph).Free;
  { The Notification method, which is sometimes called while the component is
    being destroyed, reads FGlyph and expects it to be valid, so it must be
    reset to nil }
  FGlyph := nil;
  UninstallHookProc (ButtonHookProc);
  Dec (ButtonCount);
  if ButtonCount = 0 then begin
    Pattern.Free;
    Pattern := nil;
    ButtonMouseTimer.Free;
    ButtonMouseTimer := nil;
  end;
  inherited;
end;

procedure TToolbarButton97.Paint;
const
  EdgeStyles: array[Boolean, Boolean] of UINT = (
    (EDGE_RAISED, EDGE_SUNKEN),
    (BDR_RAISEDINNER, BDR_SUNKENOUTER));
  FlagStyles: array[Boolean] of UINT = (BF_RECT or BF_SOFT or BF_MIDDLE, BF_RECT);
var
  UseBmp: Boolean;
  Bmp: TBitmap;
  DrawCanvas: TCanvas;
  PaintRect, R: TRect;
  Offset: TPoint;
  StateDownOrExclusive, DropdownComboShown, UseDownAppearance, DrawBorder: Boolean;
begin
  UseBmp := FOpaque or not FFlat;
  if UseBmp then
    Bmp := TBitmap.Create
  else
    Bmp := nil;
  try
    if UseBmp then begin
      Bmp.Width := Width;
      Bmp.Height := Height;
      DrawCanvas := Bmp.Canvas;
      with DrawCanvas do begin
        Brush.Color := Color;
        FillRect (ClientRect);
      end;
    end
    else
      DrawCanvas := Canvas;
    DrawCanvas.Font := Self.Font;
    PaintRect := Rect(0, 0, Width, Height);

    StateDownOrExclusive := FState in [bsDown, bsExclusive];
    DropdownComboShown := FDropdownCombo and FUsesDropdown;
    UseDownAppearance := (FState = bsExclusive) or
      ((FState = bsDown) and (not DropdownComboShown or not FMenuIsDown));
    DrawBorder := (csDesigning in ComponentState) or
      (not FNoBorder and (not FFlat or StateDownOrExclusive or (FMouseInControl and (FState <> bsDisabled))));

    if DropdownComboShown then begin
      if DrawBorder then begin
        R := PaintRect;
        Dec (R.Right, DropdownComboSpace);
        R.Left := R.Right - DropdownArrowWidth;
        DrawEdge (DrawCanvas.Handle, R,
          EdgeStyles[FFlat, StateDownOrExclusive and FMenuIsDown],
          FlagStyles[FFlat]);
      end;
      Dec (PaintRect.Right, DropdownArrowWidth + DropdownComboSpace);
    end;
    if DrawBorder then
      DrawEdge (DrawCanvas.Handle, PaintRect, EdgeStyles[FFlat, UseDownAppearance],
        FlagStyles[FFlat]);
    if not FNoBorder then begin
      if FFlat then
        InflateRect (PaintRect, -1, -1)
      else
        InflateRect (PaintRect, -2, -2);
    end;

    if UseDownAppearance then begin
      if (FState = bsExclusive) and (not FFlat or not FMouseInControl) and
         not FMenuIsDown and FHighlightWhenDown then begin
        if Pattern = nil then CreateBrushPattern;
        DrawCanvas.Brush.Bitmap := Pattern;
        DrawCanvas.FillRect(PaintRect);
      end;
      Offset.X := 1;
      Offset.Y := 1;
    end
    else begin
      Offset.X := 0;
      Offset.Y := 0;
    end;

    TButtonGlyph(FGlyph).Draw (DrawCanvas, PaintRect, Offset,
      FDisplayMode <> dmTextOnly, FDisplayMode <> dmGlyphOnly,
      Caption, FWordWrap, FAlignment, FLayout, FMargin, FSpacing,
      FDropdownArrow and not FDropdownCombo and FUsesDropdown,
      DropdownArrowWidth, FState);
    if DropdownComboShown then
      TButtonGlyph(FGlyph).DrawButtonDropArrow (DrawCanvas, Width-DropdownArrowWidth-2,
        Height div 2 - 1, DropdownArrowWidth, FState);

    if UseBmp then
      Canvas.Draw (0, 0, Bmp);
  finally
    Bmp.Free;
  end;
end;

procedure TToolbarButton97.RemoveButtonMouseTimer;
begin
  if ButtonMouseInControl = Self then begin
    ButtonMouseTimer.Enabled := False;
    ButtonMouseInControl := nil;
  end;
end;

(* no longer used
procedure TToolbarButton97.UpdateTracking;
var
  P: TPoint;
begin
  if Enabled then begin
    GetCursorPos (P);
    { Use FindDragTarget instead of PtInRect since we want to check based on
      the Z order }
    FMouseInControl := not (FindDragTarget(P, True) = Self);
    if FMouseInControl then
      MouseLeft
    else
      MouseEntered;
  end;
end;
*)

procedure TToolbarButton97.Loaded;
var
  State: TButtonState97;
begin
  inherited;
  if Enabled then
    State := bsUp
  else
    State := bsDisabled;
  TButtonGlyph(FGlyph).CreateButtonGlyph (State);
end;

procedure TToolbarButton97.Notification (AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then begin
    if AComponent = DropdownMenu then DropdownMenu := nil;
    if Assigned(FGlyph) and (AComponent = Images) then Images := nil;
  end;
end;

function TToolbarButton97.PointInButton (X, Y: Integer): Boolean;
begin
  Result := (X >= 0) and
    (X < ClientWidth-((DropdownArrowWidth+DropdownComboSpace) * Ord(FDropdownCombo and FUsesDropdown))) and
    (Y >= 0) and (Y < ClientHeight);
end;

procedure TToolbarButton97.MouseDown (Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if not Enabled then begin
    inherited;
    Exit;
  end;
  if Button <> mbLeft then begin
    MouseEntered;
    inherited;
  end
  else begin
    { We know mouse has to be over the control if the mouse went down. }
    MouseEntered;
    FMenuIsDown := FUsesDropdown and (not FDropdownCombo or
      (X >= Width-(DropdownArrowWidth+DropdownComboSpace)));
    try
      if not FDown then begin
        FState := bsDown;