expertcad/SRC/Main/ToolBar.pas

{ TToolButton }

constructor TToolButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csSetCaption, csClickEvents];
  Width := 23;
  Height := 22;
  FImageIndex := -1;
  FStyle := tbsButton;
end;

procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (Style = tbsDropDown) and (Button = mbLeft) and Enabled then
    Down := not Down;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove(Shift, X, Y);
  if (Style = tbsDropDown) and MouseCapture then
    Down := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
end;

procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if (Button = mbLeft) and (X >= 0) and (X < ClientWidth) and (Y >= 0) and
    (Y <= ClientHeight) then
  if Style = tbsDropDown then Down := False;
end;

procedure TToolButton.Click;
begin
  inherited Click;
end;

procedure TToolButton.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = DropdownMenu then
      DropdownMenu := nil
    else if AComponent = MenuItem then
      MenuItem := nil;
  end;
end;

procedure TToolButton.CMTextChanged(var Message: TMessage);
begin
  inherited;
  UpdateControl;
  if not (csLoading in ComponentState) and (FToolBar <> nil) and FToolBar.ShowCaptions then
  begin
    FToolBar.FButtonWidth := 0;
    FToolBar.FButtonHeight := 0;
    FToolBar.RecreateButtons;
  end;
end;

procedure TToolButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
  Pos: Integer;
  Reordered, NeedsUpdate: Boolean;
  ResizeWidth, ResizeHeight: Boolean;
begin
  if ((ALeft <> Left) or (ATop <> Top) or
    (AWidth <> Width) or (AHeight <> Height)) and
    (FUpdateCount = 0) and not (csLoading in ComponentState) and
    (FToolBar <> nil) then
  begin
    Pos := Index;
    Reordered := FToolBar.ReorderButton(Pos, ALeft, ATop) <> Pos;
    if Reordered then
    begin
      NeedsUpdate := False;
      if Index < Pos then Pos := Index
    end
    else
    begin
      NeedsUpdate := (Style in [tbsSeparator, tbsDivider]) and (AWidth <> Width);
      Reordered := NeedsUpdate;
    end;
    if (Style = tbsDropDown) and ((GetComCtlVersion >= ComCtlVersionIE4) or
      { IE3 doesn't display drop-down arrows }
      not FToolBar.Flat) then
        AWidth := FToolBar.ButtonWidth + AWidth - Width;
    ResizeWidth := not (Style in [tbsSeparator, tbsDivider]) and
      (AWidth <> FToolBar.ButtonWidth);
    ResizeHeight := AHeight <> FToolBar.ButtonHeight;
    if NeedsUpdate then inherited SetBounds(ALeft, ATop, AWidth, AHeight);
    if csDesigning in ComponentState then
    begin
      if ResizeWidth then FToolBar.ButtonWidth := AWidth;
      if ResizeHeight then FToolBar.ButtonHeight := AHeight;
    end;
    if Reordered and not ResizeWidth and not ResizeHeight then
    begin
      if NeedsUpdate then
        if Style in [tbsSeparator, tbsDivider] then
          FToolBar.RefreshButton(Pos)
        else
          FToolBar.UpdateButton(Pos);
      FToolBar.ResizeButtons;
      FToolBar.RepositionButtons(0);
    end
    else
      FToolBar.RepositionButton(Pos);
  end
  else inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TToolButton.Paint;
const
  XorColor = $00FFD8CE;
  DropDownWidth = 14;
var
  R: TRect;
begin
  if FToolBar = nil then Exit;
  if (Style = tbsDropDown) and not FToolbar.Flat and not FToolBar.FMenuDropped
  and (GetComCtlVersion = ComCtlVersionIE5) then
  with Canvas do
  begin
    if not Down then
    begin
      R := Rect(Width - DropDownWidth, 1, Width, Height);
      DrawEdge(Handle, R, BDR_RAISEDOUTER, BF_TOP or BF_RIGHT or BF_BOTTOM);
      R.Top := 0;
      DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT);
    end
    else begin
      R := Rect(Width - DropDownWidth + 1, -1, Width, Height);
      DrawEdge(Handle, R, BDR_SUNKEN, BF_TOP or BF_RIGHT or BF_BOTTOM);
      DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT);
    end;
  end;
  if Style = tbsDivider then
    with Canvas do
    begin
      R := Rect(Width div 2 - 1, 0, Width, Height);
      DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT)
    end;
  if csDesigning in ComponentState then
    { Draw separator outline }
    if Style in [tbsSeparator, tbsDivider] then
      with Canvas do
      begin
        Pen.Style := psDot;
        Pen.Mode := pmXor;
        Pen.Color := XorColor;
        Brush.Style := bsClear;
        Rectangle(0, 0, ClientWidth, ClientHeight);
      end
    { Draw Flat button face }
    else if FToolBar.Flat and not Down then
      with Canvas do
      begin
        R := Rect(0, 0, Width, Height);
        DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT);
      end;
end;

function TToolButton.GetButtonState: Byte;
begin
  Result := 0;
  if FDown then
    if Style = tbsCheck then
      Result := Result or ButtonStates[tbsChecked]
    else
      Result := Result or ButtonStates[tbsPressed];
  if Enabled and ((FToolBar = nil) or FToolBar.Enabled) then
    Result := Result or ButtonStates[tbsEnabled];
  if not Visible and not (csDesigning in ComponentState) then
    Result := Result or ButtonStates[tbsHidden];
  if FIndeterminate then Result := Result or ButtonStates[tbsIndeterminate];
  if FWrap then Result := Result or ButtonStates[tbsWrap];
  if FMarked then Result := Result or ButtonStates[tbsMarked];
end;

procedure TToolButton.SetAutoSize(Value: Boolean);
begin
  if Value <> AutoSize then
  begin
    FAutoSize := Value;
    UpdateControl;
    if not (csLoading in ComponentState) and (FToolBar <> nil) and
      FToolBar.ShowCaptions then
    begin
      FToolBar.FButtonWidth := 0;
      FToolBar.FButtonHeight := 0;
      FToolBar.RecreateButtons;
    end;
  end;
end;

procedure TToolButton.SetButtonState(State: Byte);
begin
  FDown := State and (TBSTATE_CHECKED or TBSTATE_PRESSED) <> 0;
  Enabled := State and TBSTATE_ENABLED <> 0;
  if not (csDesigning in ComponentState) then
    Visible := State and TBSTATE_HIDDEN = 0;
  FIndeterminate := not FDown and (State and TBSTATE_INDETERMINATE <> 0);
  FWrap := State and TBSTATE_WRAP <> 0;
  FMarked := State and TBSTATE_MARKED <> 0;
end;

procedure TToolButton.SetToolBar(AToolBar: TToolBar);
begin
  if FToolBar <> AToolBar then
  begin
    if FToolBar <> nil then FToolBar.RemoveButton(Self);
    Parent := AToolBar;
    if AToolBar <> nil then AToolBar.InsertButton(Self);
  end;
end;

procedure TToolButton.CMVisibleChanged(var Message: TMessage);
var
  Button: TTBButton;
begin
  if not (csDesigning in ComponentState) and (FToolBar <> nil) then
  begin
    if FToolBar <> nil then
      with FToolBar do
      begin
        if Perform(TB_GETBUTTON, Index, Longint(@Button)) <> 0 then
          Perform(TB_HIDEBUTTON, Button.idCommand, MakeLong(Ord(not Self.Visible), 0));
        { Force a resize to occur }
        if AutoSize then AdjustSize;
      end;
    UpdateControl;
    FToolBar.RepositionButtons(Index);
  end;
end;

procedure TToolButton.CMEnabledChanged(var Message: TMessage);
begin
  if FToolBar <> nil then
    FToolBar.Perform(TB_ENABLEBUTTON, Index, Ord(Enabled));
end;

procedure TToolButton.CMHitTest(var Message: TCMHitTest);
begin
  Message.Result := Ord(not (Style in [tbsDivider, tbsSeparator]) or (DragKind = dkDock));
end;

procedure TToolButton.SetDown(Value: Boolean);
const
  DownMessage: array[Boolean] of Integer = (TB_PRESSBUTTON, TB_CHECKBUTTON);
begin
  if Value <> FDown then
  begin
    FDown := Value;
    if FToolBar <> nil then
    begin
      FToolBar.Perform(DownMessage[Style = tbsCheck], Index, MakeLong(Ord(Value), 0));
      FToolBar.UpdateButtonStates;
    end;
  end;
end;

procedure TToolButton.SetDropdownMenu(Value: TPopupMenu);
begin
  if Value <> FDropdownMenu then
  begin
    FDropdownMenu := Value;
    if Value <> nil then Value.FreeNotification(Self);
  end;
end;

procedure TToolButton.SetGrouped(Value: Boolean);
begin
  if FGrouped <> Value then
  begin
    FGrouped := Value;
    UpdateControl;
  end;
end;

procedure TToolButton.SetImageIndex(Value: TImageIndex);
begin
  if FImageIndex <> Value then
  begin
    FImageIndex := Value;
    if FToolBar <> nil then
    begin
      RefreshControl;
      FToolBar.Perform(TB_CHANGEBITMAP, Index, Value);
      if FToolBar.Transparent or FToolBar.Flat then Invalidate;
    end;
  end;
end;

procedure TToolButton.SetMarked(Value: Boolean);
begin
  if FMarked <> Value then
  begin
    FMarked := Value;
    if FToolBar <> nil then
      FToolBar.Perform(TB_MARKBUTTON, Index, Longint(Ord(Value)));
  end;
end;

procedure TToolButton.SetIndeterminate(Value: Boolean);
begin
  if FIndeterminate <> Value then
  begin
    if Value then SetDown(False);
    FIndeterminate := Value;
    if FToolBar <> nil then
      FToolBar.Perform(TB_INDETERMINATE, Index, Longint(Ord(Value)));
  end;
end;

procedure TToolButton.SetMenuItem(Value: TMenuItem);
begin
  { Copy all appropriate values from menu item }
  if Value <> nil then
  begin
    if FMenuItem <> Value then
      Value.FreeNotification(Self);
    Action := Value.Action;
    Caption := Value.Caption;
    Down := Value.Checked;
    Enabled := Value.Enabled;
    Hint := Value.Hint;
    ImageIndex := Value.ImageIndex;
    Visible := Value.Visible;
  end;
  FMenuItem := Value;
end;

procedure TToolButton.SetStyle(Value: TToolButtonStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    Invalidate;
    if not (csLoading in ComponentState) and (FToolBar <> nil) then
    begin
      if FToolBar.ShowCaptions then
      begin
        FToolBar.FButtonWidth := 0;
        FToolBar.FButtonHeight := 0;
        FToolBar.RecreateButtons
      end
      else
      begin
        if Style in [tbsDivider, tbsSeparator] then
          RefreshControl
        else
        if Style = tbsDropDown then
          FToolbar.RecreateButtons
        else
          UpdateControl;
        FToolBar.ResizeButtons;
        FToolbar.RepositionButtons(Index);
      end;
      FToolBar.AdjustSize;
    end;
  end;
end;

procedure TToolButton.SetWrap(Value: Boolean);
begin
  if FWrap <> Value then
  begin
    FWrap := Value;
    if FToolBar <> nil then
      RefreshControl;
  end;
end;

procedure TToolButton.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TToolButton.EndUpdate;
begin
  Dec(FUpdateCount);
end;

function TToolButton.GetIndex: Integer;
begin
  if FToolBar <> nil then
    Result := FToolBar.FButtons.IndexOf(Self)
  else
    Result := -1;
end;

function TToolButton.IsWidthStored: Boolean;
begin
  Result := Style in [tbsSeparator, tbsDivider];
end;

procedure TToolButton.RefreshControl;
begin
  if (FToolBar <> nil) and FToolBar.RefreshButton(Index) then
  begin
{    R := BoundsRect;
    R.Left := 0;
    ValidateRect(FToolBar.Handle, @R);
    R.Bottom := R.Top;
    R.Top := 0;
    R.Right := FToolBar.ClientWidth;
    ValidateRect(FToolBar.Handle, @R);}
  end;
end;

procedure TToolButton.UpdateControl;
begin
  if FToolBar <> nil then FToolBar.UpdateButton(Index);
end;

function TToolButton.CheckMenuDropdown: Boolean;
begin
  Result := not (csDesigning in ComponentState) and ((DropdownMenu <> nil) and
    DropdownMenu.AutoPopup or (MenuItem <> nil)) and (FToolBar <> nil) and
    FToolBar.CheckMenuDropdown(Self);
end;

function TToolButton.IsCheckedStored: Boolean;
begin
  Result := (ActionLink = nil) or not TToolButtonActionLink(ActionLink).IsCheckedLinked;
end;

function TToolButton.IsImageIndexStored: Boolean;
begin
  Result := (ActionLink = nil) or not TToolButtonActionLink(ActionLink).IsImageIndexLinked;
end;

procedure TToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if not CheckDefaults or (Self.Down = False) then
        Self.Down := Checked;
      if not CheckDefaults or (Self.ImageIndex = -1) then
        Self.ImageIndex := ImageIndex;
    end;
end;

function TToolButton.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TToolButtonActionLink;
end;

procedure TToolButton.AssignTo(Dest: TPersistent);
begin
  inherited AssignTo(Dest);
  if Dest is TCustomAction then
    with TCustomAction(Dest) do
    begin
      Checked := Self.Down;
      ImageIndex := Self.ImageIndex;
    end;
end;

procedure TToolButton.ValidateContainer(AComponent: TComponent);
var
  W: Integer;
begin
  inherited ValidateContainer(AComponent);
  { Update non-stored Width and Height if inserting into TToolBar }
  if (csLoading in ComponentState) and (AComponent is TToolBar) then
  begin
    if Style in [tbsDivider, tbsSeparator] then
      W := Width else
      W := TToolBar(AComponent).ButtonWidth;
    SetBounds(Left, Top, W, TToolBar(AComponent).ButtonHeight);
  end;
end;

{ TToolBar }

constructor TToolBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csDoubleClicks, csMenuEvents, csSetCaption];
  Width := 150;
  Height := 29;
  Align := alTop;
  EdgeBorders := [ebTop];
  FButtonWidth := 23;
  FButtonHeight := 22;
  FCustomizable := False;
  FCustomizing := False;
  FNewStyle := True;
  FWrapable := True;
  FButtons := TList.Create;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
  FDisabledImageChangeLink := TChangeLink.Create;
  FDisabledImageChangeLink.OnChange := DisabledImageListChange;
  FHotImageChangeLink := TChangeLink.Create;
  FHotImageChangeLink.OnChange := HotImageListChange;
  FNullBitmap := TBitmap.Create;
  with FNullBitmap do
  begin
    Width := 1;
    Height := 1;
    Canvas.Brush.Color := clBtnFace;
    Canvas.FillRect(Rect(0,0,1,1));
  end;
  FloatingDockSiteClass := TToolDockForm;
end;

destructor TToolBar.Destroy;
var
  I: Integer;
begin
  FNullBitmap.Free;
  FHotImageChangeLink.Free;
  FDisabledImageChangeLink.Free;
  FImageChangeLink.Free;
  for I := 0 to FButtons.Count - 1 do
    if TControl(FButtons[I]) is TToolButton then
      TToolButton(FButtons[I]).FToolBar := nil;
  FButtons.Free;
  FCanvas.Free;
  inherited Destroy;
end;

procedure TToolBar.CreateParams(var Params: TCreateParams);
const
  TBSTYLE_TRANSPARENT = $8000;  // IE4 style
  DefaultStyles = CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE or CCS_NODIVIDER;
  ListStyles: array[Boolean] of DWORD = (0, TBSTYLE_LIST);
  FlatStyles: array[Boolean] of DWORD = (0, TBSTYLE_FLAT);
  TransparentStyles: array[Boolean] of DWORD = (0, TBSTYLE_TRANSPARENT);
  CustomizeStyles: array[Boolean] of DWORD = (0, CCS_ADJUSTABLE);
begin
  FNewStyle := InitCommonControl(ICC_BAR_CLASSES);
  inherited CreateParams(Params);
  CreateSubClass(Params, TOOLBARCLASSNAME);
  with Params do
  begin
    Style := Style or DefaultStyles or FlatStyles[FFlat] or ListStyles[FList] or
      TransparentStyles[FTransparent] or CustomizeStyles[FCustomizable];
    //! WINBUG: Without this style the toolbar has a two pixel margin above
    //! the buttons when ShowCaptions = True.
    if ShowCaptions then
      Style := Style xor TBSTYLE_TRANSPARENT;//!
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  end;
end;

procedure TToolBar.CreateWnd;
const
  { IE4 support }
  TB_SETEXTENDEDSTYLE     = (WM_USER + 84); // For TBSTYLE_EX_*
  TB_GETEXTENDEDSTYLE     = (WM_USER + 85); // For TBSTYLE_EX_*
  TBSTYLE_EX_DRAWDDARROWS = $0001;          // IE4 toolbar style
var
  DisplayDC: HDC;
  SaveFont, StockFont: HFONT;
  TxtMetric: TTextMetric;
begin
  inherited CreateWnd;
  { Maintain backward compatibility with IE3 which always draws drop-down arrows
    for buttons in which Style = tbsDropDown. }
  if GetComCtlVersion >= ComCtlVersionIE4 then
    Perform(TB_SETEXTENDEDSTYLE, 0, Perform(TB_GETEXTENDEDSTYLE, 0, 0) or
      TBSTYLE_EX_DRAWDDARROWS);
  FOldHandle := 0;
  StockFont := GetStockObject(SYSTEM_FONT);
  if StockFont <> 0 then
  begin
    DisplayDC := GetDC(0);
    if (DisplayDC <> 0) then
    begin
      SaveFont := SelectObject(DisplayDC, StockFont);
      if (GetTextMetrics(DisplayDC, TxtMetric)) then
        with TxtMetric do
          FHeightMargin := tmHeight - tmInternalLeading - tmExternalLeading + 1;
      SelectObject(DisplayDC, SaveFont);
      ReleaseDC(0, DisplayDC);
    end;
  end;
  RecreateButtons;
  Invalidate;
end;

procedure TToolBar.CreateButtons(NewWidth, NewHeight: Integer);

  function ToolButtonVisible: Boolean;
  var
    I: Integer;
    Control: TControl;
  begin
    for I := 0 to FButtons.Count - 1 do
    begin
      Control := TControl(FButtons[I]);
      if (Control is TToolButton) and ((csDesigning in ComponentState) or
        Control.Visible) and not (TToolButton(Control).Style in
        [tbsSeparator, tbsDivider]) then
      begin
        Result := True;
        Exit;
      end;
    end;
    Result := False;
  end;

var
  ImageWidth, ImageHeight: Integer;
  I: Integer;
begin
  BeginUpdate;
  try
    HandleNeeded;
    Perform(TB_BUTTONSTRUCTSIZE, SizeOf(TTBButton), 0);
    Perform(TB_SETINDENT, FIndent, 0);
    if FImages <> nil then
    begin
      ImageWidth := 14;
      //<2F>᪠<EFBFBD><E1AAA0>     //! WINBUG: Without this style the toolbar has a two pixel margin above
      //Common control requries at least a space is used when showing button
      ImageHeight := FImages.Height;
    end
    else if FDisabledImages <> nil then
    begin
      ImageWidth := FDisabledImages.Width;
      ImageHeight := FDisabledImages.Height;
    end
    else if FHotImages <> nil then
    begin
      ImageWidth := FHotImages.Width;
      ImageHeight := FHotImages.Height;
    end
    else
    begin
      ImageWidth := 0;
      ImageHeight := 0;
    end;
    Perform(TB_SETBITMAPSIZE, 0, MakeLParam(ImageWidth, ImageHeight));
    { Adjust the working height if there is a visible TToolButton whose caption
      height is automatically added by the common control. }
//    if ShowCaptions and ToolButtonVisible then Dec(NewHeight, FHeightMargin);
    { Prevent toolbar from setting default button size }
    if NewWidth <= 0 then NewWidth := 1;
    if NewHeight <= 0 then NewHeight := 1;
    Perform(TB_SETBUTTONSIZE, 0, MakeLParam(NewWidth, NewHeight));
    FButtonWidth := NewWidth;
    FButtonHeight := NewHeight;
  finally
    EndUpdate;
  end;
  { Retrieve current button sizes }
  for I := 0 to InternalButtonCount - 1 do Perform(TB_DELETEBUTTON, 0, 0);
  UpdateButtons;
  UpdateImages;
  GetButtonSize(FButtonWidth, FButtonHeight);
end;

procedure TToolBar.RepositionButton(Index: Integer);
var
  TBButton: TTBButton;
  Button: TControl;
  R: TRect;
  AdjustY: Integer;
begin
  if (csLoading in ComponentState) or
    (Perform(TB_GETBUTTON, Index, Longint(@TBButton)) = 0) then
    Exit;
  if Perform(TB_GETITEMRECT, Index, Longint(@R)) <> 0 then
  begin
    Button := TControl(TBButton.dwData);
    if Button is TToolButton then TToolButton(Button).BeginUpdate;
    try
      if not (Button is TToolButton) then
        with Button do
        begin
          if Button is TWinControl then HandleNeeded;
          { Check for a control that doesn't size and center it }
          BoundsRect := R;
          if Height < R.Bottom - R.Top then
          begin
            AdjustY := (R.Bottom - R.Top - Height) div 2;
            SetBounds(R.Left, R.Top + AdjustY, R.Right - R.Left, Height);
          end;
        end
      else
        Button.BoundsRect := R;
    finally
      if Button is TToolButton then TToolButton(Button).EndUpdate;
    end;
  end;
end;

procedure TToolBar.RepositionButtons(Index: Integer);
var
  I: Integer;
begin
  if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
  BeginUpdate;
  try
    for I := InternalButtonCount - 1 downto Index do RepositionButton(I);
  finally
    EndUpdate;
  end;
end;

procedure TToolBar.GetButtonSize(var AWidth, AHeight: Integer);
var
  LastIndex: Integer;
  R: TRect;
  TBButton: TTBButton;
begin
  if HandleAllocated then
  begin
    if GetComCtlVersion >= ComCtlVersionIE3 then
    begin
      LastIndex := Perform(TB_GETBUTTONSIZE, 0, 0);
      AHeight := LastIndex shr 16;
      AWidth := LastIndex and $FFFF;
    end
    else
    begin
      LastIndex := InternalButtonCount - 1;
      if LastIndex < 0 then Exit;
      while (LastIndex >= 0) and
        (Perform(TB_GETBUTTON, LastIndex, Integer(@TBButton)) <> 0) and
        (TBButton.fsStyle and TBSTYLE_SEP <> 0) do
        Dec(LastIndex);
      if LastIndex < 0 then
      begin
        if Perform(TB_GETITEMRECT, 0, Longint(@R)) <> 0 then
          AHeight := R.Bottom - R.Top;
        Exit;
      end;
      if Perform(TB_GETITEMRECT, LastIndex, Longint(@R)) <> 0 then
      begin
        AHeight := R.Bottom - R.Top;
        AWidth := R.Right - R.Left;
      end;
    end;
  end;
end;

procedure TToolBar.SetButtonHeight(Value: Integer);
begin
  if Value <> FButtonHeight then
  begin
    FButtonHeight := Value;
    RecreateButtons;
  end;
end;

procedure TToolBar.SetButtonWidth(Value: Integer);
begin
  if Value <> FButtonWidth then
  begin
    FButtonWidth := Value;
    RecreateButtons;
  end;
end;

procedure TToolBar.InsertButton(Control: TControl);
var
  FromIndex, ToIndex: Integer;
begin
  if Control is TToolButton then TToolButton(Control).FToolBar := Self;
  if not (csLoading in Control.ComponentState) then
  begin
    FromIndex := FButtons.IndexOf(Control);
    if FromIndex >= 0 then
      ToIndex := ReorderButton(Fromindex, Control.Left, Control.Top)
    else
    begin
      ToIndex := ButtonIndex(FromIndex, Control.Left, Control.Top);
      FButtons.Insert(ToIndex, Control);
      UpdateItem(TB_INSERTBUTTON, ToIndex, ToIndex);
    end;
  end
  else
  begin
    ToIndex := FButtons.Add(Control);
    UpdateButton(ToIndex);
  end;
  if Wrapable then
    RepositionButtons(0)
  else
    RepositionButtons(ToIndex);
  RecreateButtons;
end;

procedure TToolBar.RemoveButton(Control: TControl);
var
  I, Pos: Integer;
begin
  I := FButtons.IndexOf(Control);
  if I >= 0 then
  begin
    if Control is TToolButton then TToolButton(Control).FToolBar := nil;
    Pos := FButtons.Remove(Control);
    if FCustomizing and not FRestoring then Exit;
    Perform(TB_DELETEBUTTON, Pos, 0);
    ResizeButtons;
    if Wrapable then
      RepositionButtons(0)
    else
      RepositionButtons(Pos);
    RecreateButtons;
  end;
end;

function TToolBar.UpdateItem(Message, FromIndex, ToIndex: Integer): Boolean;
var
  Control: TControl;
  Button: TTBButton;
  CaptionText: string;
  Buffer: array[0..4095] of Char;
begin
  Control := TControl(FButtons[FromIndex]);
  if Control is TToolButton then
    with TToolButton(Control) do
    begin
      FillChar(Button, SizeOf(Button), 0);
      if Style in [tbsSeparator, tbsDivider] then
      begin
        Button.iBitmap := Width;
        Button.idCommand := FromIndex;
      end
      else
      begin
        if ImageIndex < 0 then
          Button.iBitmap := -2 else
          Button.iBitmap := ImageIndex;
        Button.idCommand := FromIndex;
      end;
      with Button do
      begin
        fsStyle := ButtonStyles[Style];
        if AutoSize and (GetComCtlVersion >= ComCtlVersionIE4) then
          fsStyle := fsStyle or TBSTYLE_AUTOSIZE;
      end;
      Button.fsState := GetButtonState;
      if FGrouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
      Button.dwData := Longint(Control);
      if ShowCaptions then
      begin
        if Caption <> '' then
          CaptionText := Caption
        else
          { Common control requries at least a space is used when showing button
            captions.  If any one button's caption is empty (-1) then none of
            the buttons' captions will not be displayed. }
          //CaptionText := ' ';
          CaptionText := '';
        StrPCopy(Buffer, CaptionText);
        { TB_ADDSTRING requires two null terminators }
        Buffer[Length(CaptionText) + 1] := #0;
        Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
      end
      else
        Button.iString := -1;
    end
  else
  begin
    FillChar(Button, SizeOf(Button), 0);
    Button.fsStyle := ButtonStyles[tbsSeparator];
    Button.iBitmap := Control.Width;
    Button.idCommand := -1;
    if not Control.Visible and not (csDesigning in Control.ComponentState) then
      Button.fsState := Button.fsState or ButtonStates[tbsHidden];
    Button.dwData := Longint(Control);
    Button.iString := -1;
  end;
  Result := Self.Perform(Message, ToIndex, Integer(@Button)) <> 0;
end;

function TToolBar.UpdateItem2(Message, FromIndex, ToIndex: Integer): Boolean;
var
  Control: TControl;
  Button: TTBButtonInfo;
  CaptionText: string;
  Buffer: array[0..4095] of Char;
begin
  Control := TControl(FButtons[FromIndex]);
  FillChar(Button, SizeOf(Button), 0);
  Button.cbSize := SizeOf(Button);
  if Control is TToolButton then
    with TToolButton(Control) do
    begin
      Button.dwMask := TBIF_STATE or TBIF_STYLE or TBIF_LPARAM or TBIF_COMMAND
        or TBIF_SIZE;
      if Style in [tbsSeparator, tbsDivider] then
      begin
        Button.idCommand := FromIndex;
      end
      else
      begin
        Button.dwMask := Button.dwMask or TBIF_IMAGE;
        if ImageIndex < 0 then
          Button.iImage := -2 else
          Button.iImage := ImageIndex;
        Button.idCommand := FromIndex;
      end;
      with Button do
      begin
        cx := Width;
        fsStyle := ButtonStyles[Style];
        if AutoSize then fsStyle := fsStyle or TBSTYLE_AUTOSIZE;
        if Grouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
      end;
      Button.fsState := GetButtonState;
      Button.lParam := Longint(Control);
      if ShowCaptions then
      begin
        if Caption <> '' then
          CaptionText := Caption
        else
          { Common control requries at least a space is used when showing button
            captions.  If any one button's caption is empty (-1) then none of
            the buttons' captions will not be displayed. }
          CaptionText := ' ';
        StrPCopy(Buffer, CaptionText);
        { TB_ADDSTRING requires two null terminators }
        Buffer[Length(CaptionText) + 1] := #0;
        //Button.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer));
        Button.pszText := Buffer;
        Button.cchText := Length(CaptionText);
        Button.dwMask := Button.dwMask or TBIF_TEXT;
      end
      else
      begin
        Button.pszText := nil;
        Button.cchText := 0;
      end;
 {      if Style in [tbsSeparator, tbsDivider] then
      begin
        with Button do
        begin
          if Visible then
          begin
            dwMask := TBIF_STYLE or TBIF_STATE or TBIF_LPARAM;
            fsState := TBSTATE_ENABLED or TBSTATE_WRAP;
            fsStyle := TBSTYLE_BUTTON;
          end;
        end;
      end;}
    end
  else
  begin
    Button.dwMask := TBIF_TEXT or TBIF_STATE or TBIF_STYLE or TBIF_LPARAM or
      TBIF_COMMAND or TBIF_SIZE;
    Button.fsStyle := ButtonStyles[tbsSeparator];
    Button.cx := Control.Width;
    Button.idCommand := -1;
    Button.lParam := Longint(Control);
    Button.pszText := nil;
    Button.cchText := 0;
  end;
  Result := Self.Perform(Message, ToIndex, Integer(@Button)) <> 0;
end;

function TToolBar.RefreshButton(Index: Integer): Boolean;
var
  Style: Longint;
begin
  if not (csLoading in ComponentState) and (FUpdateCount = 0) then
  begin
    BeginUpdate;
    try
      Style := GetWindowLong(Handle, GWL_STYLE);
      SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
      try
        Result := (Index < InternalButtonCount) and
          UpdateItem(TB_DELETEBUTTON, Index, Index) and
          UpdateItem(TB_INSERTBUTTON, Index, Index);
      finally
        SetWindowLong(Handle, GWL_STYLE, Style);
      end;
    finally
      EndUpdate;
    end;
  end
  else
    Result := False;
end;

procedure TToolBar.UpdateButton(Index: Integer);
var
  Style: Longint;
begin
  if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
  BeginUpdate;
  try
    HandleNeeded;
    Style := GetWindowLong(Handle, GWL_STYLE);
    SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
    try
      if Index < InternalButtonCount then
        UpdateItem2(TB_SETBUTTONINFO, Index, Index)
      else
        UpdateItem(TB_INSERTBUTTON, Index, Index);
    finally
      SetWindowLong(Handle, GWL_STYLE, Style);
    end;
  finally
    EndUpdate;
  end;
end;

procedure TToolBar.UpdateButtons;
const
  BlankButton: TTBButton = (iBitmap: 0; idCommand: 0; fsState: 0;
    fsStyle: TBSTYLE_BUTTON; dwData: 0; iString: 0);
var
  I: Integer;
  Count: Integer;
  Style: Longint;
begin
  BeginUpdate;
  try
    HandleNeeded;
    Style := GetWindowLong(Handle, GWL_STYLE);
    SetWindowLong(Handle, GWL_STYLE, Style and not WS_VISIBLE);
    try
      Count := InternalButtonCount;
      for I := 0 to FButtons.Count - 1 do
      begin
        if I < Count then
          UpdateItem2(TB_SETBUTTONINFO, I, I)
        else
          UpdateItem(TB_INSERTBUTTON, I, I);
      end;
    finally
      SetWindowLong(Handle, GWL_STYLE, Style);
    end;
  finally
    EndUpdate;
  end;
  RepositionButtons(0);
end;

procedure TToolBar.UpdateButtonState(Index: Integer);
var
  TBButton: TTBButton;
begin
  if (Perform(TB_GETBUTTON, Index, Integer(@TBButton)) <> 0) then
    with TToolButton(TBButton.dwData) do
    begin
      SetButtonState(TBButton.fsState);
      Self.Perform(TB_SETSTATE, Index, MakeLong(GetButtonState, 0));
    end;
end;

procedure TToolBar.UpdateButtonStates;
var
  I: Integer;
begin
  for I := 0 to FButtons.Count - 1 do
    if TControl(FButtons[I]) is TToolButton then
      UpdateButtonState(I);
end;

procedure TToolBar.SetShowCaptions(Value: Boolean);
begin
  if FShowCaptions <> Value then
  begin
    FShowCaptions := Value;
    if not (csLoading in ComponentState) then
      RecreateWnd;
    AdjustSize;
  end;
end;

function TToolBar.GetButton(Index: Integer): TToolButton;
begin
  Result := FButtons[Index];
end;

function TToolBar.GetButtonCount: Integer;
begin
  Result := FButtons.Count;
end;

function TToolBar.GetRowCount: Integer;
begin
  Result := Perform(TB_GETROWS, 0, 0);
end;

procedure TToolBar.SetList(Value: Boolean);
begin
  if FList <> Value then
  begin
    FList := Value;
    RecreateWnd;
  end;
end;

procedure TToolBar.SetFlat(Value: Boolean);
begin
  if FFlat <> Value then
  begin
    FFlat := Value;
    RecreateWnd;
  end;
end;

procedure TToolBar.SetTransparent(Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    RecreateWnd;
  end;
end;

procedure TToolBar.SetWrapable(Value: Boolean);
begin
  if FWrapable <> Value then
  begin
    FWrapable := Value;
    if AutoSize then AdjustSize;
  end;
end;

procedure TToolBar.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = FImages then Images := nil;
    if AComponent = FHotImages then HotImages := nil;
        if AComponent = FDisabledImages then DisabledImages := nil;
        if AComponent = FMenu then Menu := nil;
  end;
end;

procedure TToolBar.LoadImages(AImages: TCustomImageList);
var
  AddBitmap: TTBAddBitmap;
  ReplaceBitmap: TTBReplaceBitmap;
  NewHandle: HBITMAP;

  function GetImageBitmap(ImageList: TCustomImageList): HBITMAP;
  var
    I: Integer;
    Bitmap: TBitmap;
    R: TRect;
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := ImageList.Width * ImageList.Count;
      Bitmap.Height := ImageList.Height;
      R := Rect(0,0,Width,Height);
      with Bitmap.Canvas do
      begin
        Brush.Color := clBtnFace;
        FillRect(R);
      end;
      for I := 0 to ImageList.Count - 1 do
        ImageList_Draw(ImageList.Handle, I, Bitmap.Canvas.Handle,
          I * ImageList.Width, 0, ILD_TRANSPARENT);
      Result := Bitmap.ReleaseHandle;
    finally
      Bitmap.Free;
    end;
  end;

begin
  if AImages <> nil then
    NewHandle := GetImageBitmap(AImages)
  else
    with TBitmap.Create do
    try
      Assign(FNullBitmap);
      NewHandle := ReleaseHandle;
    finally
      Free;
    end;
  if FOldHandle = 0 then
  begin
    AddBitmap.hInst := 0;
    AddBitmap.nID := NewHandle;
    Perform(TB_ADDBITMAP, ButtonCount, Longint(@AddBitmap));
  end
  else
  begin
    with ReplaceBitmap do
    begin
      hInstOld := 0;
      nIDOld := FOldHandle;
      hInstNew := 0;
      nIDNew := NewHandle;
      nButtons := ButtonCount;
    end;
    Perform(TB_REPLACEBITMAP, 0, Longint(@ReplaceBitmap));
    if FOldHandle <> 0 then DeleteObject(FOldHandle);
  end;
  FOldHandle := NewHandle;
end;

procedure TToolBar.UpdateImages;
begin
  if FNewStyle then
  begin
    if FImages <> nil then SetImageList(FImages.Handle);
    if FDisabledImages <> nil then SetDisabledImageList(FDisabledImages.Handle);
    if FHotImages <> nil then SetHotImageList(FHotImages.Handle);
  end
  else
    if HandleAllocated then LoadImages(FImages);
end;

procedure TToolBar.ImageListChange(Sender: TObject);
begin
  if HandleAllocated and (Sender = Images) then RecreateButtons;
end;

procedure TToolBar.SetImageList(Value: HImageList);
begin
  if HandleAllocated then Perform(TB_SETIMAGELIST, 0, Value);
  Invalidate;
end;

procedure TToolBar.SetImages(Value: TCustomImageList);
begin
  if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  FImages := Value;
  if FImages <> nil then
  begin
    FImages.RegisterChanges(FImageChangeLink);
    FImages.FreeNotification(Self);
  end
  else
    SetImageList(0);
  RecreateButtons;
end;

procedure TToolBar.DisabledImageListChange(Sender: TObject);
begin
  if HandleAllocated and (Sender = DisabledImages) then RecreateButtons;
end;

procedure TToolBar.SetDisabledImageList(Value: HImageList);
begin
  if HandleAllocated then Perform(TB_SETDISABLEDIMAGELIST, 0, Value);
  Invalidate;
end;

procedure TToolBar.SetDisabledImages(Value: TCustomImageList);
begin
  if FDisabledImages <> nil then FDisabledImages.UnRegisterChanges(FDisabledImageChangeLink);
  FDisabledImages := Value;
  if FDisabledImages <> nil then
  begin
    FDisabledImages.RegisterChanges(FDisabledImageChangeLink);
    FDisabledImages.FreeNotification(Self);
  end
  else
    SetDisabledImageList(0);
  RecreateButtons;
end;

procedure TToolBar.HotImageListChange(Sender: TObject);
begin
  if HandleAllocated and (Sender = HotImages) then RecreateButtons;
end;

procedure TToolBar.SetHotImageList(Value: HImageList);
begin
  if HandleAllocated then Perform(TB_SETHOTIMAGELIST, 0, Value);
  Invalidate;
end;

procedure TToolBar.SetHotImages(Value: TCustomImageList);
begin
  if FHotImages <> nil then FHotImages.UnRegisterChanges(FHotImageChangeLink);
  FHotImages := Value;
  if FHotImages <> nil then
  begin
    FHotImages.RegisterChanges(FHotImageChangeLink);
    FHotImages.FreeNotification(Self);
  end
  else
    SetHotImageList(0);
  RecreateButtons;
end;

procedure TToolBar.SetIndent(Value: Integer);
begin
  if FIndent <> Value then
  begin
    FIndent := Value;
    RecreateWnd;
  end;
end;

procedure TToolBar.SetMenu(const Value: TMainMenu);
var
  I: Integer;
begin
  if FMenu = Value then exit;
  if csAcceptsControls in ControlStyle then
  begin
    ControlStyle := [csCaptureMouse, csClickEvents,
      csDoubleClicks, csMenuEvents, csSetCaption];
    RecreateWnd;
  end;
  ShowCaptions := True;
  if Assigned(FMenu) then
    for I := ButtonCount - 1 downto 0 do
      Buttons[I].Free;
       
  if Assigned(FMenu) then
    FMenu.RemoveFreeNotification(Self);
  FMenu := Value;
  if not Assigned(FMenu) then exit;
  FMenu.FreeNotification(Self);

  for I := ButtonCount to FMenu.Items.Count - 1 do
  begin
    with TToolButton.Create(Self) do
    try
      AutoSize := True;
      Grouped := True;
      Parent := Self;
      Buttons[I].MenuItem := FMenu.Items[I];
    except
      Free;
      raise;
    end;
  end;
  { Copy attributes from each menu item }
  for I := 0 to FMenu.Items.Count - 1 do
    Buttons[i].MenuItem := FMenu.Items[I];
end;

procedure TToolBar.RecreateButtons;
begin
  if ([csLoading, csDestroying] * ComponentState = []) or HandleAllocated then
  begin
    CreateButtons(FButtonWidth, FButtonHeight);
    ResizeButtons;
  end;
end;

procedure TToolBar.WMCaptureChanged(var Message: TMessage);
begin
  inherited;
  if FInMenuLoop and FCaptureChangeCancels then CancelMenu;
end;

procedure TToolBar.WMKeyDown(var Message: TWMKeyDown);
var
  Item: Integer;
  Button: TToolButton;
  P: TPoint;
begin
  if FInMenuLoop then
  begin
    Item := Perform(TB_GETHOTITEM, 0, 0);
    case Message.CharCode of
      VK_RETURN, VK_DOWN:
        begin
          if (Item > -1) and (Item < FButtons.Count) then
          begin
            Button := TToolButton(FButtons[Item]);
            P := Button.ClientToScreen(Point(1, 1));
            ClickButton(Button);
          end;
          { Prevent default processing }
          if Message.CharCode = VK_DOWN then Exit;
        end;
      VK_ESCAPE: CancelMenu;
    end;
  end;
  inherited;
end;

procedure TToolBar.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
  I: Integer;
  Control: TControl;
begin
  if Assigned(Menu) then exit;
  for I := 0 to FButtons.Count - 1 do Proc(TComponent(FButtons[I]));
  for I := 0 to ControlCount - 1 do
  begin
    Control := Controls[I];
    if (Control.Owner = Root) and (FButtons.IndexOf(Control) = -1) then Proc(Control);
  end;
end;

procedure TToolBar.Loaded;
var
  I: Integer;
begin
  RecreateButtons;
  { Make sure we dock controls after streaming }
  for I := 0 to ControlCount - 1 do
    Controls[I].HostDockSite := Self;
  inherited Loaded;
  ResizeButtons;
  RepositionButtons(0);
end;

procedure TToolBar.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TToolBar.EndUpdate;
begin
  Dec(FUpdateCount);
end;

procedure TToolBar.ResizeButtons;
begin
  if not (csLoading in ComponentState) and HandleAllocated then
  begin
    Perform(TB_AUTOSIZE, 0, 0);
    if AutoSize then AdjustSize;
  end;
end;

function TToolBar.InternalButtonCount: Integer;
begin
  Result := Perform(TB_BUTTONCOUNT, 0, 0);
end;

function TToolBar.ButtonIndex(OldIndex, ALeft, ATop: Integer): Integer;
var
  Dist, Tmp, Head, Tail: Integer;
  Control: TControl;
begin
  if (OldIndex >= 0) and (FButtons.Count <= 1) then
  begin
    Result := OldIndex;
    Exit;
  end;
  { Find row closest to ATop }
  Result := 0;
  if FButtons.Count = 0 then Exit;
  Tmp := 0;
  Head := 0;
  Tail := 0;
  Dist := MaxInt;
  while (Dist > 0) and (Result < FButtons.Count) do
  begin
    if Result <> OldIndex then
    begin
      Control := TControl(FButtons[Result]);
      if (Control is TToolButton) and TToolButton(Control).Wrap or
        (Result = FButtons.Count - 1) then
      begin
        if Abs(ATop - Control.Top) < Dist then
        begin
          Dist := Abs(ATop - Control.Top);
          Head := Tmp;
          Tail := Result;
        end;
        Tmp := Result + 1;
      end;
    end
    else
      Tail := Result;
    Inc(Result);
  end;
  { Find button on Row closest to ALeft }
  for Result := Head to Tail do
    if (Result <> OldIndex) and (ALeft <= TControl(FButtons[Result]).Left) then
      Break;
  { Return old position if new position is last on the row and old position
    was already the last on the row. }
  if (Result = OldIndex + 1) and (OldIndex in [Head..Tail]) then
    Result := OldIndex;
end;

function TToolBar.ReorderButton(OldIndex, ALeft, ATop: Integer): Integer;
var
  Control: TControl;
begin
  Result := ButtonIndex(OldIndex, ALeft, ATop);
  if Result <> OldIndex then
  begin
    { If we are inserting to the right of our deletion then account for shift }
    if OldIndex < Result then Dec(Result);
    Control := FButtons[OldIndex];
    FButtons.Delete(OldIndex);
    FButtons.Insert(Result, Control);
    BeginUpdate;
    try
      Perform(TB_DELETEBUTTON, OldIndex, 0);
      UpdateItem(TB_INSERTBUTTON, Result, Result);
    finally
      EndUpdate;
    end;
  end;
end;

procedure TToolBar.AdjustControl(Control: TControl);
var
  I, Pos: Integer;
  R: TRect;
  Reordered, NeedsUpdate: Boolean;
begin
  Pos := FButtons.IndexOf(Control);
  if Pos = -1 then Exit;
  Reordered := ReorderButton(Pos, Control.Left, Control.Top) <> Pos;
  NeedsUpdate := False;
  if Reordered then
  begin
    I := FButtons.IndexOf(Control);
    if I < Pos then Pos := I;
  end
  else if Perform(TB_GETITEMRECT, Pos, Longint(@R)) <> 0 then
  begin
    NeedsUpdate := Control.Width <> R.Right - R.Left;
    Reordered := NeedsUpdate;
  end;
  if (csDesigning in ComponentState) and (Control.Height <> ButtonHeight) then
    ButtonHeight := Control.Height
  else
    if Reordered then
    begin
      if NeedsUpdate then
        RefreshButton(Pos);
      ResizeButtons;
      RepositionButtons(0);
    end
    else
      RepositionButton(Pos);
end;

procedure TToolBar.AlignControls(AControl: TControl; var Rect: TRect);
begin
  if FUpdateCount > 0 then Exit;
  if AControl = nil then
    RepositionButtons(0)
  else if not (AControl is TToolButton) then
    AdjustControl(AControl);
end;

procedure TToolBar.ChangeScale(M, D: Integer);
begin
  { Scaling isn't a standard behavior for toolbars.  We prevent scaling from
    occurring here. }
end;

procedure TToolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  if not Transparent then
    inherited else
    DefaultHandler(Message);
end;

procedure TToolBar.WMGetDlgCode(var Message: TMessage);
begin
  if FInMenuLoop then
    Message.Result := DLGC_WANTARROWS;
end;

{ Need to read/write caption ourselves - default wndproc seems to discard it. }

procedure TToolBar.WMGetText(var Message: TWMGetText);
begin
  with Message do
    Result := StrLen(StrLCopy(PChar(Text), PChar(FCaption), TextMax - 1));
end;

procedure TToolBar.WMGetTextLength(var Message: TWMGetTextLength);
begin
  Message.Result := Length(FCaption);
end;

procedure TToolBar.WMSetText(var Message: TWMSetText);
begin
  with Message do
    SetString(FCaption, Text, StrLen(Text));
end;

procedure TToolBar.WMNotifyFormat(var Message: TMessage);
begin
  with Message do
    Result := DefWindowProc(Handle, Msg, WParam, LParam);
end;

procedure TToolBar.WMSize(var Message: TWMSize);
var
  W, H: Integer;
begin
  inherited;
  if not AutoSize then
  begin
    W := Width;
    H := Height;
    WrapButtons(W, H);
  end;
end;

procedure TToolBar.WMSysChar(var Message: TWMSysChar);
var
  Form: TCustomForm;
begin
  { Default wndproc doesn't re-route WM_SYSCHAR messages to parent. }
  Form := GetParentForm(Self);
  if Form <> nil then
  begin
    Form.Dispatch(Message);
    Exit;
  end
  else
    inherited;
end;

procedure TToolBar.WMWindowPosChanged(var Message: TWMWindowPosChanged);
var
  R: TRect;
  NcX, NcY: Integer;
  Rgn1, Rgn2: HRgn;
begin
  { Erase only what's been uncovered when toolbar is flat - avoid flicker }
  if Flat and HandleAllocated and (Parent <> nil) then
  begin
    GetWindowRect(Handle, R);
    NcX := R.Right - R.Left - ClientWidth;
    NcY := R.Bottom - R.Top - ClientHeight;
    Rgn1 := CreateRectRgn(0, 0, Width - NcX, Height - NcY);
    with Message.WindowPos^ do
      Rgn2 := CreateRectRgn(0, 0, cx - NcY, cy - NcY);
    CombineRgn(Rgn1, Rgn2, Rgn1, RGN_XOR);
    GetRgnBox(Rgn1, R);
    { Allow a 2 pixel buffer }
    Dec(R.Left, 2);
    DeleteObject(Rgn1);
    DeleteObject(Rgn2);
    inherited;
    RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_ERASE);
  end
  else
    inherited;
end;

procedure TToolBar.WMWindowPosChanging(var Message: TWMWindowPosChanging);
const
  BackgroundValid = SWP_NOSIZE or SWP_NOMOVE;
var
  R: TRect;
begin
  { Invalidate old background when toolbar is flat and is about to be moved }
  if Transparent and (Message.WindowPos^.flags and BackgroundValid <> BackgroundValid) and
    (Parent <> nil) and Parent.HandleAllocated then
  begin
    R := BoundsRect;
    InvalidateRect(Parent.Handle, @R, True);
  end;
  inherited;
end;

function TToolBar.WrapButtons(var NewWidth, NewHeight: Integer): Boolean;
var
  Index, NcX, NcY: Integer;
  Vertical: Boolean;
  PrevSize, CurrSize: TPoint;
  R: TRect;
  WrapStates: TBits;

  procedure CalcSize(var CX, CY: Integer);
  var
    IsWrapped: Boolean;
    I, Tmp, X, Y, HeightChange: Integer;
    Control: TControl;
  begin
    CX := 0;
    CY := 0;
    X := Indent;
    Y := 0;
    for I := 0 to FButtons.Count - 1 do
    begin
      Control := TControl(FButtons[I]);
      if (csDesigning in ComponentState) or Control.Visible then
      begin
        if (Control is TToolButton) and (I < FButtons.Count - 1) then
          if WrapStates <> nil then
            IsWrapped := WrapStates[I] else
            IsWrapped := TToolButton(Control).Wrap
        else
          IsWrapped := False;
        if Control is TToolButton and
          (TToolButton(Control).Style in [tbsSeparator, tbsDivider]) then
        begin
          { Store the change in height, from the current row to the next row
            after wrapping, in HeightChange. THe IE4 version of comctl32
            considers this height to be the width the last separator on the
            current row - prior versions of comctl32 consider this height to be
            2/3 the width the last separator. }
          HeightChange := Control.Width;
          if (GetComCtlVersion < ComCtlVersionIE4) or not Flat and
            (GetComCtlVersion >= ComCtlVersionIE401) then
            HeightChange := HeightChange * 2 div 3;
          if IsWrapped and (I < FButtons.Count - 1) then
          begin
            Tmp := Y + ButtonHeight + HeightChange;
            if Tmp > CY then
              CY := Tmp;
          end
          else
          begin
            Tmp := X + Control.Width;
            if Tmp > CX then
              CX := Tmp;
          end;
          if IsWrapped then
            Inc(Y, HeightChange);
        end
        else
        begin
          Tmp := X + Control.Width;
          if Tmp > CX then
            CX := Tmp;
          Tmp := Y + ButtonHeight;
          if Tmp > CY then
            CY := Tmp;
        end;
        if IsWrapped then
        begin
          X := Indent;
          Inc(Y, ButtonHeight);
        end
        else
          Inc(X, Control.Width);
      end;
    end;
    { Adjust for 2 pixel top margin when not flat style buttons }
    if (CY > 0) and not Flat then Inc(CY, 2);
  end;

  function WrapHorz(CX: Integer): Integer;
  var
    I, J, X: Integer;
    Control: TControl;
    Found: Boolean;
  begin
    Result := 1;
    X := Indent;
    I := 0;
    while I < FButtons.Count do
    begin
      Control := TControl(FButtons[I]);
      if Control is TToolButton then
        WrapStates[I] := False;
      if (csDesigning in ComponentState) or Control.Visible then
      begin
        if (X + Control.Width > CX) and (not (Control is TToolButton) or
          not (TToolButton(Control).Style in [tbsDivider, tbsSeparator])) then
        begin
          Found := False;
          for J := I downto 0 do
            if TControl(FButtons[J]) is TToolButton then
              with TToolButton(FButtons[J]) do
                if ((csDesigning in ComponentState) or Visible) and
                  (Style in [tbsSeparator, tbsDivider]) then
                begin
                  if not WrapStates[J] then
                  begin
                    Found := True;
                    I := J;
                    X := Indent;
                    WrapStates[J] := True;
                    Inc(Result);
                  end;
                  Break;
                end;
          if not Found then
          begin
            for J := I - 1 downto 0 do
              if TControl(FButtons[J]) is TToolButton then
                with TToolButton(FButtons[J]) do
                  if (csDesigning in ComponentState) or Visible then
                  begin
                    if not WrapStates[J] then
                    begin
                      Found := True;
                      I := J;
                      X := Indent;
                      WrapStates[J] := True;
                      Inc(Result);
                    end;
                    Break;
                  end;
            if not Found then
              Inc(X, Control.Width);
          end;
        end
        else
          Inc(X, Control.Width);
      end;
      Inc(I);
    end;
  end;

  function WrapSizeVert(var CX, CY: Integer): Integer;
  var
    HorzSize, VertSize, Size, PrevSize: TPoint;
  begin
    PrevSize := Point(-1,-1);
    Size := Point(0,0);
    Result := 0;
    WrapHorz(0);
    CalcSize(VertSize.X, VertSize.Y);
    WrapHorz(MaxInt);
    CalcSize(HorzSize.X, HorzSize.Y);
    while VertSize.X < HorzSize.X do
    begin
      PrevSize := Size;
      Size.X := (VertSize.X + HorzSize.X) div 2;
      Result := WrapHorz(Size.X);
      CalcSize(Size.X, Size.Y);
      if CY < Size.Y then
      begin
        if (VertSize.X = Size.X) and (VertSize.Y = Size.Y) then
        begin
          Result := WrapHorz(HorzSize.X);
          Break;
        end;
        VertSize := Size;
      end
      else if CY > Size.Y then
      begin
        HorzSize := Size;
        if (PrevSize.X = Size.X) and (PrevSize.Y = Size.Y) then Break;
      end
      else
        Break;
    end;
  end;

  function WrapSizeHorz(var CX, CY: Integer): Integer;
  var
    HorzRows, VertRows, Min, Mid, Max: Integer;
    HorzSize: TPoint;
  begin
    Result := 0;
    Min := 0;
    Max := CX;
    HorzRows := WrapHorz(Max);
    VertRows := WrapHorz(0);
    if HorzRows <> VertRows then
      while Min < Max do
      begin
        Mid := (Min + Max) div 2;
        VertRows := WrapHorz(Mid);
        if VertRows = HorzRows then
          Max := Mid
        else
        begin
          if Min = Mid then
          begin
            WrapHorz(Max);
            Break;
          end;
          Min := Mid;
        end;
      end;
    CalcSize(HorzSize.X, HorzSize.Y);
    WrapHorz(HorzSize.X);
  end;

begin
  Result := True;
  if HandleAllocated then
  begin
    Index := InternalButtonCount - 1;
    if (Index >= 0) or not (csDesigning in ComponentState) then
    begin
      WrapStates := nil;
      PrevSize.X := ClientWidth;
      PrevSize.Y := ClientHeight;
      { Calculate non-client border size }
      NcX := Width - PrevSize.X;
      NcY := Height - PrevSize.Y;
      { Remember previous size for comparison }
      R.BottomRight := PrevSize;
      CalcSize(PrevSize.X, PrevSize.Y);
      { Get current window size minus the non-client borders }
      CurrSize := Point(NewWidth - NcX, NewHeight - NcY);

      { Decide best way to calculate layout }
      if Align <> alNone then
        Vertical := Align in [alLeft, alRight]
      else
        Vertical := Abs(CurrSize.X - R.Right) < Abs(CurrSize.Y - R.Bottom);
      if Wrapable then
      begin
        WrapStates := TBits.Create;
        try
          WrapStates.Size := FButtons.Count;
          if Vertical then
            WrapSizeVert(CurrSize.X, CurrSize.Y)
          else
            WrapSizeHorz(CurrSize.X, CurrSize.Y);
          { CurrSize now has optimium dimensions }
          CalcSize(CurrSize.X, CurrSize.Y);
          if (Vertical or (Align = alNone)) and (CurrSize.X <> PrevSize.X) or
            (CurrSize.Y <> PrevSize.Y) then
          begin
            { Enforce changes to Wrap property }
            for Index := 0 to WrapStates.Size - 1 do
              if TControl(FButtons[Index]) is TToolButton then
                TToolButton(FButtons[Index]).Wrap := WrapStates[Index];
            RepositionButtons(0);
          end
          else
            { Overwrite any changes to buttons' Wrap property }
            UpdateButtonStates;
        finally
          WrapStates.Free;
        end;
      end
      else
        { CurrSize now has optimium dimensions }
        CalcSize(CurrSize.X, CurrSize.Y);
      if AutoSize and (Align <> alClient) then
      begin
        if Vertical or (Align = alNone) then
          NewWidth := CurrSize.X + NcX;
        if not Vertical or (Align = alNone) then
          NewHeight := CurrSize.Y + NcY;
      end;
    end;
  end;
end;

function TToolBar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  Result := WrapButtons(NewWidth, NewHeight);
end;

procedure TToolBar.CMControlChange(var Message: TCMControlChange);
begin
  inherited;
  with Message do
    if Inserting then
      InsertButton(Control)
    else
      RemoveButton(Control);
end;

procedure TToolBar.CNChar(var Message: TWMChar);
begin
  { We got here through the installed ToolMenuKeyHook }
  if FInMenuLoop and not (csDesigning in ComponentState) then
    with Message do
      if Perform(CM_DIALOGCHAR, CharCode, KeyData) <> 0 then
        Result := 1;
end;

procedure TToolBar.CMDialogChar(var Message: TCMDialogChar);
var
  Button: TToolButton;
begin
  if Enabled and Showing and ShowCaptions then
  begin
    Button := FindButtonFromAccel(Message.CharCode);
    if Button <> nil then
    begin
      { Display a drop-down menu after hitting the accelerator key if IE3
        is installed. Otherwise, fire the OnClick event for IE4. We do this
        because the IE4 version of the drop-down metaphor is more complete,
        allowing the user to click a button OR drop-down its menu. }
      if ((Button.Style <> tbsDropDown) or (GetComCtlVersion < ComCtlVersionIE4)) and
        ((Button.DropdownMenu <> nil) or (Button.MenuItem <> nil)) then
        TrackMenu(Button)
      else
        Button.Click;
      Message.Result := 1;
      Exit;
    end;
  end;
  inherited;
end;

procedure TToolBar.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Broadcast(Message);
end;

procedure TToolBar.CMColorChanged(var Message: TMessage);
begin
  inherited;
  RecreateWnd;
end;

procedure TToolBar.CMParentColorChanged(var Message: TMessage);
begin
  inherited;
  { If toolbar is transparent then repaint when parent changes color }
  if Transparent then Invalidate;
end;

procedure TToolBar.CNSysKeyDown(var Message: TWMSysKeyDown);
begin
  inherited;
  if (Message.CharCode = VK_MENU) then
    CancelMenu;
end;

procedure TToolBar.CMSysFontChanged(var Message: TMessage);
begin
  inherited;
  RecreateWnd;
end;

procedure TToolBar.CNDropDownClosed(var Message: TMessage);
begin
  ClearTempMenu;
  FMenuDropped := False;
  if (GetComCtlVersion = ComCtlVersionIE5) and (FMenuButton <> nil)
    then FMenuButton.Invalidate;
  FCaptureChangeCancels := True;
end;

procedure TToolBar.CNNotify(var Message: TWMNotify);
var
  Button: TToolButton;
  DefaultDraw: Boolean;
  R: TRect;
  Flags: TTBCustomDrawFlags;
  LogFont: TLogFont;
begin
  with Message do
    case NMHdr^.code of
      TBN_DROPDOWN:
        with PNMToolBar(NMHdr)^ do
          { We can safely assume that a TBN_DROPDOWN message was generated by a
            TToolButton and not any TControl. }
          if Perform(TB_GETBUTTON, iItem, Longint(@tbButton)) <> 0 then
          begin
            Button := TToolButton(tbButton.dwData);
            if Button <> nil then
              Button.CheckMenuDropDown;
          end;
      NM_CUSTOMDRAW:
        with PNMTBCustomDraw(NMHdr)^ do
        try
          FCanvas.Lock;
          Result := CDRF_DODEFAULT;
          if (nmcd.dwDrawStage and CDDS_ITEM) = 0 then
          begin
            R := ClientRect;
            case nmcd.dwDrawStage of
              CDDS_PREPAINT:
              begin
                if IsCustomDrawn(dtControl, cdPrePaint) then
                begin
                  try
                    FCanvas.Handle := nmcd.hdc;
                    FCanvas.Font := Font;
                    FCanvas.Brush := Brush;
                    DefaultDraw := CustomDraw(R, cdPrePaint);
                    if not DefaultDraw then
                    begin
                      Result := CDRF_SKIPDEFAULT;
                      Exit;
                    end;
                    clrText := ColorToRGB(FCanvas.Font.Color);
                    clrBtnFace := ColorToRGB(FCanvas.Brush.Color);
                  finally
                    FCanvas.Handle := 0;
                  end;
                end;
                if IsCustomDrawn(dtItem, cdPrePaint) or IsCustomDrawn(dtItem, cdPreErase) then
                  Result := Result or CDRF_NOTIFYITEMDRAW;
                if IsCustomDrawn(dtItem, cdPostPaint) then
                  Result := Result or CDRF_NOTIFYPOSTPAINT;
                if IsCustomDrawn(dtItem, cdPostErase) then
                  Result := Result or CDRF_NOTIFYPOSTERASE;
              end;
              CDDS_POSTPAINT:
                if IsCustomDrawn(dtControl, cdPostPaint) then
                  CustomDraw(R, cdPostPaint);
              CDDS_PREERASE:
                if IsCustomDrawn(dtControl, cdPreErase) then
                  CustomDraw(R, cdPreErase);
              CDDS_POSTERASE:
                if IsCustomDrawn(dtControl, cdPostErase) then
                  CustomDraw(R, cdPostErase);
            end;
          end else
          begin
            Button := Buttons[nmcd.dwItemSpec];
            if Button = nil then Exit;
            case nmcd.dwDrawStage of
              CDDS_ITEMPREPAINT:
                begin
                  //release the font we may have loaned during item drawing.
                  if (nmcd.dwDrawStage and CDDS_ITEMPOSTPAINT <> 0)
                  and (FOurFont + FStockFont <> 0) then
                  begin
                    SelectObject(nmcd.hdc, FStockFont);
                    DeleteObject(FOurFont);
                    FOurFont := 0;
                    FStockFont := 0;
                  end;

                  try
                    FCanvas.Handle := nmcd.hdc;
                    FCanvas.Font := Self.Font;
                    FCanvas.Brush := Self.Brush;
                    FCanvas.Font.OnChange := CanvasChanged;
                    FCanvas.Brush.OnChange := CanvasChanged;
                    FCanvasChanged := False;
                    Flags := [];
                    DefaultDraw := CustomDrawButton(Button,
                      TCustomDrawState(Word(nmcd.uItemState)), cdPrePaint, Flags);
                    if tbNoEdges in Flags then
                      Result := Result or TBCDRF_NOEDGES;
                    if tbHiliteHotTrack in Flags then
                      Result := Result or TBCDRF_HILITEHOTTRACK;
                    if tbNoOffset in Flags then
                      Result := Result or TBCDRF_NOOFFSET;
                    if tbNoMark in Flags then
                      Result := Result or TBCDRF_NOMARK;
                    if tbNoEtchedEffect in Flags then
                      Result := Result or TBCDRF_NOETCHEDEFFECT;
                    clrText := ColorToRGB(FCanvas.Font.Color);
                    clrBtnFace := ColorToRGB(FCanvas.Brush.Color);
                    if not DefaultDraw then
                    begin
                      Result := Result or CDRF_SKIPDEFAULT;
                      Exit;
                    end else if FCanvasChanged then
                    begin
                      FCanvasChanged := False;
                      FCanvas.Font.OnChange := nil;
                      FCanvas.Brush.OnChange := nil;
                      if GetObject(FCanvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then
                      begin
                        FCanvas.Handle := 0;  // disconnect from hdc
                        // don't delete the stock font
                        FOurFont := CreateFontIndirect(LogFont);
                        FStockFont := SelectObject(nmcd.hdc, FOurFont);
                        Result := Result or CDRF_NEWFONT;
                      end;
                      if IsCustomDrawn(dtItem, cdPostPaint) then
                        Result := Result or CDRF_NOTIFYPOSTPAINT;
                    end;
                  finally
                    FCanvas.Handle := 0;
                  end;
                end;
              CDDS_ITEMPOSTPAINT:
                if Button <> nil then
                  CustomDrawButton(Button, TCustomDrawState(Word(nmcd.uItemState)),
                    cdPostPaint, Flags);
              CDDS_ITEMPREERASE:
                if Button <> nil then
                  CustomDrawButton(Button, TCustomDrawState(Word(nmcd.uItemState)),
                    cdPreErase, Flags);
              CDDS_ITEMPOSTERASE:
                if Button <> nil then
                  CustomDrawButton(Button, TCustomDrawState(Word(nmcd.uItemState)),
                    cdPostErase, Flags);
            end;
          end;
        finally
          FCanvas.Unlock;
        end;
      TBN_QUERYINSERT:
        with PNMToolbar(NMHdr)^ do
        begin
          Result := Integer(DoQueryInsert(iItem));
          if (FButtons.IndexOf(Pointer(tbButton.dwData)) < 0)
          and (TControl(tbButton.dwData) is TToolButton) then
          begin
          {  FButtons.Insert(iItem, Pointer(tbButton.dwData));
            TToolButton(tbButton.dwData).FToolbar := Self;
            if Assigned(FOnCustomizeAdded) then
              FOnCustomizeAdded(Self, TToolButton(tbButton.dwData));}
          end else
            if (tbButton.dwData = 0) and (tbButton.fsStyle = ButtonStyles[tbsSeparator]) then
            begin
              Button := TToolButton.Create(Owner);
              Button.Style := tbsSeparator;
              FButtons.Insert(iItem, Button);
              Inc(FSeparators);
            end;
        end;
      TBN_QUERYDELETE:
        Result := Integer(DoQueryDelete(PNMToolbar(NMHdr)^.iItem));
      TBN_GETBUTTONINFO:
        with PNMToolBar(NMHdr)^ do
        begin
          if FCustomizing then
            Result := Integer(DoGetButton(PNMToolbar(NMHdr)));
        end;
      TBN_DELETINGBUTTON:
        if FCustomizing and not FRestoring and Assigned(FOnCustomizeDelete) then
        begin
          Button := TToolButton(FButtons[PNMToolbar(NMHdr)^.iItem]);
          FOnCustomizeDelete(Self, Button);
        end;
      TBN_BEGINADJUST:
        begin
          FCustomizing := True;
          FSeparators := 0;
          if Assigned(FOnCustomizing) then FOnCustomizing(Self);
          if not FRestoring then
            SaveButtons(True);
        end;
      TBN_ENDADJUST:
        begin
          if not FRestoring then
          begin
            RecreateButtonsFromToolbar;
            FCustomizing := False;
          end
          else if Assigned(FOnCustomizeReset) then
            FOnCustomizeReset(Self);
          FRestoring := False;
        end;
      TBN_TOOLBARCHANGE:
        begin
          if not FCustomizing then //Buttons were dragged holding SHIFT key down.
            RecreateButtonsFromToolbar;
          if Assigned(FOnCustomized) then FOnCustomized(Self);
        end;
      TBN_RESET:
        begin
          FRestoring := True;
          SaveButtons(False);
          RecreateButtonsFromToolbar;
          FRestoring := False;
        end;
    end;
end;

procedure TToolBar.RecreateButtonsFromToolbar;
var
  I: Integer;
  ButtonInfo: TTBBUTTON;
  Button: TToolButton;
  TBButtonCount: Integer;
begin
  TBButtonCount := SendMessage(Handle, TB_BUTTONCOUNT, 0, 0);
  FButtons.Clear;
  for I := 0 to TBButtonCount - 1 do
  begin
    SendMessage(Handle, TB_GETBUTTON, I, Longint(@ButtonInfo));
    if ButtonInfo.dwData = 0 then
    begin
      Button := TToolButton.Create(Owner);
      Button.Style := tbsSeparator;
      ButtonInfo.dwData := Integer(Button);
      Button.FToolbar := Self;
      SendMessage(Handle, TB_DELETEBUTTON, I, 0);
      SendMessage(Handle, TB_INSERTBUTTON, I, Longint(@ButtonInfo));
    end;
    FButtons.Add(Pointer(ButtonInfo.dwData));
  end;
  RecreateButtons;
end;

type
  TControlAccess = class(TControl);

procedure TToolBar.WndProc(var Message: TMessage);
var
  Control: TControl;
  CapControl: TControl;
  Msg: TMsg;

  function IsToolButtonMouseMsg(var Message: TWMMouse): Boolean;
  begin
    if GetCapture = Handle then
    begin
      CapControl := GetCaptureControl;
      if (CapControl <> nil) and (CapControl.Parent <> Self) then
        CapControl := nil;
    end
    else
      CapControl := nil;
    Control := ControlAtPos(SmallPointToPoint(Message.Pos), False);
    Result := (Control <> nil) and (Control is TToolButton) and
      not Control.Dragging;
  end;

  procedure SendDropdownMsg(Button: TToolButton);
  var
    Msg: TNMToolBar;
  begin
    FillChar(Msg, SizeOf(Msg), 0);
    with Msg, hdr do
    begin
      hwndFrom := Handle;
      idFrom := Handle;
      code := TBN_DROPDOWN;
      iItem := Button.Index;
    end;
    SendMessage(Handle, WM_NOTIFY, Handle, Longint(@Msg));
  end;

begin
  if not (csDesigning in ComponentState) then
  begin
    case Message.Msg of
      WM_MOUSEMOVE:
        begin
          { Call default wndproc to get buttons to repaint when Flat = True. }
          if IsToolButtonMouseMsg(TWMMouse(Message)) then
          begin
            { Prevent painting of flat buttons when they are dock clients }
            if TControlAccess(Control).DragMode <> dmAutomatic then
              DefaultHandler(Message);
          end
          else
            DefaultHandler(Message);
        end;
      WM_LBUTTONUP:
        { Update button states after a click. }
        if IsToolButtonMouseMsg(TWMMouse(Message)) then
        begin
          DefaultHandler(Message);
          if CapControl = Control then
          begin
            with TToolButton(Control) do
              if Down and Grouped and AllowAllUp and (Style = tbsCheck) then
                Down := False;
            UpdateButtonStates;
          end
          else if (CapControl is TToolButton) or (TToolButton(Control).Style = tbsDropDown) then
            Exit;
        end;
      WM_LBUTTONDOWN, WM_LBUTTONDBLCLK:
        if IsToolButtonMouseMsg(TWMMouse(Message)) then
        begin
          { Check if mouse is clicked on a drop-down button's arrow (for IE4
            the arrow is within 13 pixels from the right, for IE3 there is no
            distinction - the entire button is used).  If an arrow click is
            detected then don't process this mouse event - a TBN_DROPDOWN
            notification will be created for us by the default wndproc. }
          with TToolButton(Control) do
          begin
            { Allow IsControlMouseMsg to deliver message to button }
            if FInMenuLoop and Self.MouseCapture then MouseCapture := True;
            if (Style <> tbsDropDown) or
              (GetComCtlVersion >= ComCtlVersionIE4) and
              (TWMMouse(Message).XPos < Left + ButtonWidth) then
              inherited WndProc(Message);
          end;
          if not Control.Dragging then DefaultHandler(Message);
          if (TToolButton(Control).Style <> tbsDropDown) and
            ((TToolButton(Control).DropdownMenu <> nil) or
            (TToolButton(Control).MenuItem <> nil)) then
          begin
            try
              SendDropDownMsg(TToolButton(Control));
            finally
              { Here we remove WM_LBUTTONDOWN message sent and instead dispatch
                it as a WM_LBUTTONUP to get a Click fired. }
              Msg.Message := 0;
              if PeekMessage(Msg, Handle, WM_LBUTTONDOWN, WM_LBUTTONDOWN,
                PM_REMOVE) and (Msg.Message = WM_QUIT) then
                PostQuitMessage(Msg.WParam)
              else
              begin
                Message.Msg := WM_LBUTTONUP;
                Dispatch(Message);
              end;
            end;
          end;
          Exit;
        end;
    end
  end;
  inherited WndProc(Message);
end;

procedure TToolBar.FlipChildren(AllLevels: Boolean);
begin { do not flip controls }
end;

function TToolBar.FindButtonFromAccel(Accel: Word): TToolButton;
var
  I: Integer;
begin
  for I := 0 to FButtons.Count - 1 do
    if TControl(FButtons[I]) is TToolButton then
    begin
      Result := TToolButton(FButtons[I]);
      if Result.Visible and Result.Enabled and IsAccel(Accel, Result.Caption) then
        Exit;
    end;
  Result := nil;
end;

{ CustomDraw support }

function TToolBar.IsCustomDrawn(Target: TCustomDrawTarget;
  Stage: TCustomDrawStage): Boolean;
begin
  if Stage = cdPrePaint then
  begin
    if Target = dtItem then
      Result := Assigned(FOnCustomDrawButton) or Assigned(FOnAdvancedCustomDrawButton)
    else if Target = dtControl then
      Result := Assigned(FOnCustomDraw) or Assigned(FOnAdvancedCustomDraw) or
        Assigned(FOnCustomDrawButton) or Assigned(FOnAdvancedCustomDrawButton)
    else
      Result := False;
  end
  else
  begin
    if Target = dtItem then
      Result := Assigned(FOnAdvancedCustomDrawButton)
    else if Target = dtControl then
      Result := Assigned(FOnAdvancedCustomDraw) or Assigned(FOnAdvancedCustomDrawButton)
    else
      Result := False;
  end;
end;

function TToolBar.CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean;
begin
  Result := True;
  if (Stage = cdPrePaint) and Assigned(FOnCustomDraw) then FOnCustomDraw(Self, ARect, Result);
  if Assigned(FOnAdvancedCustomDraw) then FOnAdvancedCustomDraw(Self, ARect, Stage, Result);
end;

function TToolBar.CustomDrawButton(Button: TToolButton; State: TCustomDrawState;
  Stage: TCustomDrawStage; var Flags: TTBCustomDrawFlags): Boolean;
begin
  Result := True;
  if (Stage = cdPrePaint) and Assigned(FOnCustomDrawButton) then FOnCustomDrawButton(Self, Button, State, Result);
  if Assigned(FOnAdvancedCustomDrawButton) then FOnAdvancedCustomDrawButton(Self, button, State, Stage, Flags, Result);
end;

procedure TToolBar.CanvasChanged(Sender: TObject);
begin
  FCanvasChanged := True;
end;

{ Toolbar menu support }

var
  ToolMenuHook: HHOOK;
  InitDone: Boolean = False;
  MenuToolBar, MenuToolBar2: TToolBar;
  MenuButtonIndex: Integer;
  LastMenuItem: TMenuItem;
  LastMousePos: TPoint;
  StillModal: Boolean;

function ToolMenuGetMsgHook(Code: Integer; WParam: Longint; var Msg: TMsg): Longint; stdcall;
const
  RightArrowKey: array[Boolean] of Word = (VK_LEFT, VK_RIGHT);
  LeftArrowKey: array[Boolean] of Word = (VK_RIGHT, VK_LEFT);
var
  P: TPoint;
  Target: TControl;
  Item: Integer;
  FindKind: TFindItemKind;
  ParentMenu: TMenu;

  function FindButton(Forward: Boolean): TToolButton;
  var
    ToolBar: TToolBar;
    I, J, Count: Integer;
  begin
    ToolBar := MenuToolBar;
    if ToolBar <> nil then
    begin
      J := MenuButtonIndex;
      I := J;
      Count := ToolBar.ButtonCount;
      if Forward then
        repeat
          if I = Count - 1 then
            I := 0
          else
            Inc(I);
          Result := ToolBar.Buttons[I];
          if Result.Visible and Result.Enabled and Result.Grouped then Exit;
        until I = J
      else
        repeat
          if I = 0 then
            I := Count - 1
          else
            Dec(I);
          Result := ToolBar.Buttons[I];
          if Result.Visible and Result.Enabled and Result.Grouped then Exit;
        until I = J;
    end;
    Result := nil;
  end;

begin
  if LastMenuItem <> nil then
  begin
    ParentMenu := LastMenuItem.GetParentMenu;
    if ParentMenu <> nil then
    begin
      if ParentMenu.IsRightToLeft then
        if Msg.WParam = VK_LEFT then
          Msg.WParam := VK_RIGHT
        else if Msg.WParam = VK_RIGHT then
          Msg.WParam := VK_LEFT;
    end;
  end;
  Result := CallNextHookEx(ToolMenuHook, Code, WParam, Longint(@Msg));
  if Result <> 0 then Exit;
  if (Code = MSGF_MENU) then
  begin
    Target := nil;
    if not InitDone then
    begin
      InitDone := True;
      PostMessage(Msg.Hwnd, WM_KEYDOWN, VK_DOWN, 0);
    end;
    case Msg.Message of
      WM_MENUSELECT:
        begin
          if (HiWord(Msg.WParam) = $FFFF) and (Msg.LParam = 0) then
          begin
            if not StillModal then
              MenuToolBar.CancelMenu;
            Exit;
          end
          else
            StillModal := False;
          FindKind := fkCommand;
          if HiWord(Msg.WParam) and MF_POPUP <> 0 then FindKind := fkHandle;
            if FindKind = fkHandle then
              Item := GetSubMenu(Msg.LParam, LoWord(Msg.WParam))
            else
              Item := LoWord(Msg.WParam);
            LastMenuItem := MenuToolBar.FTempMenu.FindItem(Item, FindKind);
        end;
      WM_SYSKEYDOWN:
        if Msg.WParam = VK_MENU then
        begin
          MenuToolBar.CancelMenu;
          Exit;
        end;
      WM_KEYDOWN:
        if Msg.WParam = VK_RETURN then
          MenuToolBar.FMenuResult := True
        else if Msg.WParam = VK_ESCAPE then
          StillModal := True
        else if LastMenuItem <> nil then
        begin
          if (Msg.WParam = VK_RIGHT) and (LastMenuItem.Count = 0) then
            Target := FindButton(True)
          else if (Msg.WParam = VK_LEFT) and (LastMenuItem.GetParentComponent is TPopupMenu) then
            Target := FindButton(False)
          else
            Target := nil;
          if Target <> nil then
            P := Target.ClientToScreen(Point(0,0));
        end;
      WM_MOUSEMOVE:
        begin
          P := Msg.pt;
          if (P.X <> LastMousePos.X) or (P.Y <> LastMousePos.Y) then
          begin
            Target := FindDragTarget(P, False);
            LastMousePos := P;
          end;
        end;
    end;
    if (Target <> nil) and (Target is TToolButton) then
    begin
      with TToolButton(Target) do
        if (Index <> MenuButtonIndex) and Grouped and (Parent <> nil) and
          Parent.HandleAllocated then
        begin
          StillModal := True;
          MenuToolBar.FCaptureChangeCancels := False;
          MenuToolBar.ClickButton(TToolButton(Target));
          MenuToolBar.ClickButton(TToolButton(Target));
        end;
    end;
  end;
end;

procedure InitToolMenuHooks;
begin
  StillModal := False;
  GetCursorPos(LastMousePos);
  if ToolMenuHook = 0 then
    ToolMenuHook := SetWindowsHookEx(WH_MSGFILTER, @ToolMenuGetMsgHook, 0,
      GetCurrentThreadID);
end;

procedure ReleaseToolMenuHooks;
begin
  if ToolMenuHook <> 0 then UnhookWindowsHookEx(ToolMenuHook);
  ToolMenuHook := 0;
  LastMenuItem := nil;
  MenuToolBar := nil;
  MenuButtonIndex := -1;
  InitDone := False;
end;

var
  ToolMenuKeyHook: HHOOK;

procedure ReleaseToolMenuKeyHooks; forward;

function ToolMenuKeyMsgHook(Code: Integer; WParam: Longint; var Msg: TMsg): Longint; stdcall;
begin
  if (Code = HC_ACTION) then
  begin
    if Msg.Message = CM_DEACTIVATE then
      MenuToolBar2.CancelMenu
    else if Msg.message = WM_COMMAND then
      ReleaseToolMenuKeyHooks
    else if (ToolMenuHook = 0) and ((Msg.Message = WM_CHAR) or
      (Msg.Message = WM_KEYDOWN) or (Msg.Message = WM_KEYUP) or
      (Msg.Message = WM_SYSKEYDOWN) or (Msg.Message = WM_SYSKEYUP)) then
      Msg.hwnd := MenuToolBar2.Handle;
  end;
  Result := CallNextHookEx(ToolMenuKeyHook, Code, WParam, Longint(@Msg))
end;

procedure InitToolMenuKeyHooks;
begin
  if ToolMenuKeyHook = 0 then
    ToolMenuKeyHook := SetWindowsHookEx(WH_GETMESSAGE, @ToolMenuKeyMsgHook, 0,
      GetCurrentThreadID);
end;

procedure ReleaseToolMenuKeyHooks;
begin
  if ToolMenuKeyHook <> 0 then UnhookWindowsHookEx(ToolMenuKeyHook);
  ToolMenuKeyHook := 0;
  MenuToolBar2 := nil;
end;

procedure TToolBar.ClearTempMenu;
var
  I: Integer;
  Item: TMenuItem;
begin
  if (FButtonMenu <> nil) and (FMenuButton <> nil) and
    (FMenuButton.MenuItem <> nil) and (FTempMenu <> nil) then
  begin
    for I := FTempMenu.Items.Count - 1 downto 0 do
    begin
      Item := FTempMenu.Items[I];
      FTempMenu.Items.Delete(I);
      FButtonMenu.Insert(0, Item);
    end;
    FTempMenu.Free;
    FTempMenu := nil;
    FMenuButton := nil;
    FButtonMenu := nil;
  end;
end;

function TToolBar.CheckMenuDropdown(Button: TToolButton): Boolean;
var
  Hook: Boolean;
  Menu: TMenu;
  Item: TMenuItem;
  I: Integer;
  ParentMenu: TMenu;
  APoint: TPoint;
begin
  Result := False;
  if Button = nil then Exit;
  FCaptureChangeCancels := False;
  try
    if Button.DropdownMenu <> nil then
      FTempMenu := Button.DropdownMenu
    else if Button.MenuItem <> nil then
    begin
      Button.MenuItem.Click;
      ClearTempMenu;
      FTempMenu := TPopupMenu.Create(Self);
      ParentMenu := Button.MenuItem.GetParentMenu;
      if ParentMenu <> nil then
        FTempMenu.BiDiMode := ParentMenu.BiDiMode;
      FTempMenu.HelpContext := Button.MenuItem.HelpContext;
      FTempMenu.TrackButton := tbLeftButton;
      Menu := Button.MenuItem.GetParentMenu;
      if Menu <> nil then
        FTempMenu.Images := Menu.Images;
      FButtonMenu := Button.MenuItem;
      for I := FButtonMenu.Count - 1 downto 0 do
      begin
        Item := FButtonMenu.Items[I];
        FButtonMenu.Delete(I);
        FTempMenu.Items.Insert(0, Item);
      end;
    end
    else
      Exit;
    SendCancelMode(nil);
    FTempMenu.PopupComponent := Self;
    Hook := Button.Grouped or (Button.MenuItem <> nil);
    if Hook then
    begin
      MenuButtonIndex := Button.Index;
      MenuToolBar := Self;
      InitToolMenuHooks;
    end;
    Perform(TB_SETHOTITEM, -1, 0);
    try
      APoint := Button.ClientToScreen(Point(0, Button.ClientHeight));
      if FTempMenu.IsRightToLeft then Inc(APoint.X, Button.Width);
      FMenuDropped := True;
      if (GetSystemMetrics(SM_CYMENU) * FTempMenu.Items.Count) + APoint.Y >
         Screen.MonitorFromPoint(APoint).Height then
        Dec(APoint.Y, Button.Height);
      if GetComCtlVersion = ComCtlVersionIE5 then
        Button.Invalidate;
      FTempMenu.Popup(APoint.X, APoint.Y);
    finally
      if Hook then ReleaseToolMenuHooks;
    end;
    FMenuButton := Button;
    if StillModal then
      Perform(TB_SETHOTITEM, Button.Index, 0);
    Result := True;
  finally
    PostMessage(Handle, CN_DROPDOWNCLOSED, 0, 0);
  end;
end;

procedure TToolBar.WMSysCommand(var Message: TWMSysCommand);

  function IsMenuBar: Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := 0 to FButtons.Count - 1 do
      if (TControl(FButtons[I]) is TToolButton)
      and Assigned(TToolButton(FButtons[I]).MenuItem) then
      begin
        Result := True;
        Break;
      end;
  end;

var
  Button: TToolButton;
begin
  { Enter menu loop if only the Alt key is pressed -- ignore Alt-Space and let
    the default processing show the system menu. }
  if not FInMenuLoop and Enabled and Showing and ShowCaptions and IsMenuBar then
    with Message do
      if (CmdType and $FFF0 = SC_KEYMENU) and (Key <> VK_SPACE) and
        (Key <> Word('-')) and (GetCapture = 0) then
      begin
        if Key = 0 then
          Button := nil else
          Button := FindButtonFromAccel(Key);
        if (Key = 0) or (Button <> nil) then
        begin
          TrackMenu(Button);
          Result := 1;
          Exit;
        end;
      end;
end;

procedure TToolBar.ClickButton(Button: TToolButton);
var
  P: TPoint;
begin
  FCaptureChangeCancels := False;
  P := Button.ClientToScreen(Point(0, 0));
  PostMessage(Handle, WM_LBUTTONDOWN, MK_LBUTTON,
    Longint(PointToSmallPoint(ScreenToClient(P))));
end;

procedure TToolBar.InitMenu(Button: TToolButton);
begin
  Perform(TB_SETANCHORHIGHLIGHT, 1, 0);
  MenuToolBar2 := Self;
  MouseCapture := True;
  InitToolMenuKeyHooks;
  if Button <> nil then
  begin
    Perform(TB_SETHOTITEM, Button.Index, 0);
    ClickButton(Button);
  end
  else
    Perform(TB_SETHOTITEM, 0, 0);
  if Button = nil then
    FCaptureChangeCancels := True;
end;

procedure TToolBar.CancelMenu;
begin
  if FInMenuLoop then
  begin
    ReleaseToolMenuKeyHooks;
    MouseCapture := False;
    Perform(TB_SETANCHORHIGHLIGHT, 0, 0);
  end;
  FInMenuLoop := False;
  FCaptureChangeCancels := False;
  Perform(TB_SETHOTITEM, -1, 0);
end;

function TToolBar.TrackMenu(Button: TToolButton): Boolean;
begin
  { Alread in menu loop - click button to drop-down menu }
  if FInMenuLoop then
  begin
    if Button <> nil then
    begin
      ClickButton(Button);
      Result := True;
    end
    else
      Result := False;
    Exit;
  end;

  InitMenu(Button);
  try
    FInMenuLoop := True;
    repeat
      Application.HandleMessage;
      if Application.Terminated then
        FInMenuLoop := False;
    until not FInMenuLoop;

  finally
    CancelMenu;
  end;
  Result := FMenuResult;
end;

procedure TToolBar.CMFontChanged(var Message);
begin
  if HandleAllocated and FShowCaptions then
  begin
    Perform(WM_SETFONT, Font.Handle, 0);
    if not (csLoading in ComponentState) then
      RecreateWnd;
  end;
  NotifyControls(CM_PARENTFONTCHANGED);
end;

procedure TToolBar.SetCustomizable(const Value: Boolean);
begin
  if Value <> FCustomizable then
  begin
    FCustomizable := Value;
    RecreateWnd;
  end;
end;

function TToolBar.DoGetButton(NMToolbar: PNMToolbar): Boolean;
const
  MaxLen = 128;
var
  NewButton: TControl;
  Title: string;
  Buffer: array[0..MaxLen] of Char;
begin
  if (NMToolbar^.iItem >= FButtons.Count) then
  begin
    Result := Assigned(FOnCustomizeNewButton);
    if Result then
    begin
      NewButton := nil;
      FOnCustomizeNewButton(Self,
        NMToolbar^.iItem - FButtons.Count + FSeparators, TToolButton(NewButton));
      Result := NewButton <> nil;
      if Result then TToolButton(NewButton).FToolbar := Self;
    end;
  end
  else begin
    NewButton := FButtons[NMToolbar^.iItem];
    Result := NewButton is TToolButton;
  end;

  if Result then
    with NMToolbar^, NewButton as TToolButton do
    begin
      if Style in [tbsSeparator, tbsDivider] then
        Title := SSeparator
      else
        Title := Caption;
      StrLCopy(pszText, PChar(Title), MaxLen);
      cchText := StrLen(pszText);
      StrLCopy(Buffer, PChar(Title), MaxLen);
      Buffer[Length(Title) + 1] := #0;
      if ShowCaptions then
        tbButton.iString := Self.Perform(TB_ADDSTRING, 0, Longint(@Buffer))
      else
        tbButton.iString := -1;
      tbButton.idCommand := Index;
      tbButton.iBitmap := ImageIndex;
      tbButton.fsStyle := ButtonStyles[Style];
      tbButton.fsState := GetButtonState;
      tbButton.dwData := Integer(NewButton);
   end;

end;

function TToolBar.DoQueryDelete(Index: Integer): Boolean;
begin
  Result := True;
  if Assigned(FOnCustomizeCanDelete) then
    FOnCustomizeCanDelete(Self, Index, Result);
end;

function TToolBar.DoQueryInsert(Index: Integer): Boolean;
begin
  Result := True;
  if Assigned(FOnCustomizeCanInsert) then
    FOnCustomizeCanInsert(Self, Index, Result);
end;

procedure TToolBar.SaveButtons(Save: Boolean);
var
  SP: TTBSaveParams;
begin
  SP.hkr := HKEY_CURRENT_USER;
  SP.pszSubKey := PChar(FCustomizeKeyName);
  SP.pszValueName := PChar(FCustomizeValueName);
  SendMessage(Handle, TB_SAVERESTORE, Integer(Save), Longint(@SP));
end;



{ TXPMenue }

constructor TXPMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFont := TFont.Create;
  GetSystemMenuFont(FFont);
  FForm := TForm(Owner);

  FUseSystemColors := true;


  FColor := clBtnFace;
  FIconBackColor := clBtnFace;
  FSelectColor := clHighlight;
  FSelectBorderColor := clHighlight;
  FMenuBarColor := clBtnFace;
  FDisabledColor := clInactiveCaption;
  FSeparatorColor := clBtnFace;
  FCheckedColor := clHighlight;
  FSelectFontColor := FFont.Color;

  FIconWidth := 24;
  FDrawSelect := true;

  if FActive then
  begin
    InitMenueItems(true);
  end;

end;

destructor TXPMenu.Destroy;
begin
  InitMenueItems(false);
  FFont.Free;

  inherited;
end;



procedure TXPMenu.ActivateMenuItem(MenuItem: TMenuItem);

  procedure Activate(MenuItem: TMenuItem);
  begin
    if addr(MenuItem.OnDrawItem) <> addr(TXPMenu.DrawItem) then
    begin
      if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnDrawItem := DrawItem;
      if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnMeasureItem := MeasureItem;
    end
  end;

var
  i, j: integer;

begin
  Activate(MenuItem);
  for i := 0 to MenuItem.Parent.Count -1 do
  begin
    Activate(MenuItem.Parent.Items[i]);
    for j := 0 to MenuItem.Parent.Items[i].Count - 1 do
      ActivateMenuItem(MenuItem.Parent.Items[i].Items[j]);
  end;
end;

procedure TXPMenu.InitMenueItems(Enable: boolean);

  procedure Activate(MenuItem: TMenuItem);
  begin
    if Enable then
    begin
      if (not assigned(MenuItem.OnDrawItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnDrawItem := DrawItem;
      if (not assigned(MenuItem.OnMeasureItem)) or (FOverrideOwnerDraw) then
        MenuItem.OnMeasureItem := MeasureItem;
    end
    else
    begin
      if addr(MenuItem.OnDrawItem) = addr(TXPMenu.DrawItem) then
        MenuItem.OnDrawItem := nil;
      if addr(MenuItem.OnMeasureItem) = addr(TXPMenu.MeasureItem) then
        MenuItem.OnMeasureItem := nil;
    end;
  end;

  procedure ItrateMenu(MenuItem: TMenuItem);
  var
    i: integer;
  begin
    Activate(MenuItem);
    for i := 0 to MenuItem.Count - 1 do
      ItrateMenu(MenuItem.Items[i]);
  end;


var
  i, x: integer;
begin
  for i := 0 to FForm.ComponentCount - 1 do
  begin
    if FForm.Components[i] is TMainMenu then
    begin
      for x := 0 to TMainMenu(FForm.Components[i]).Items.Count - 1 do
      begin
        TMainMenu(FForm.Components[i]).OwnerDraw := Enable;//Thanks Yann.
        Activate(TMainMenu(FForm.Components[i]).Items[x]);
        ItrateMenu(TMainMenu(FForm.Components[i]).Items[x]);
      end;
     {
      if Enable then
      begin
        if (not assigned(TMainMenu(FForm.Components[i]).OnChange))
          and (FRefreshOnChange) then
          TMainMenu(FForm.Components[i]).OnChange := MenuChange;
      end
      else
        if addr(TMainMenu(FForm.Components[i]).OnChange) =
          addr(TXPMenu.MenuChange) then
          TMainMenu(FForm.Components[i]).OnChange := nil;
     }
    end;
    if FForm.Components[i] is TPopupMenu then
    begin
      for x := 0 to TPopupMenu(FForm.Components[i]).Items.Count - 1 do
      begin
        TPopupMenu(FForm.Components[i]).OwnerDraw := Enable;
        Activate(TMainMenu(FForm.Components[i]).Items[x]);
        ItrateMenu(TMainMenu(FForm.Components[i]).Items[x]);
      end;
      {
      if Enable then
      begin
        if (not assigned(TPopupMenu(FForm.Components[i]).OnChange))
          and (FRefreshOnChange) then
          TPopupMenu(FForm.Components[i]).OnChange := MenuChange;
      end
      else
        if addr(TPopupMenu(FForm.Components[i]).OnChange) =
         addr(TXPMenu.MenuChange) then
          TPopupMenu(FForm.Components[i]).OnChange := nil;
      }
    end;

    if FForm.Components[i] is TToolBar then
      if not (csDesigning in ComponentState) then
      begin
        if not TToolBar(FForm.Components[i]).Flat then
          TToolBar(FForm.Components[i]).Flat := true;

        if Enable then
        begin
          for x := 0 to TToolBar(FForm.Components[i]).ButtonCount - 1 do
            if (not assigned(TToolBar(FForm.Components[i]).OnCustomDrawButton))
              or (FOverrideOwnerDraw) then
            begin
              TToolBar(FForm.Components[i]).OnCustomDrawButton :=
                ToolBarDrawButton;

            end;
        end
        else
        begin
          if addr(TToolBar(FForm.Components[i]).OnCustomDrawButton) =
            addr(TXPMenu.ToolBarDrawButton) then
            TToolBar(FForm.Components[i]).OnCustomDrawButton := nil;

        end;
      end;
  end;
end;

procedure TXPMenu.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
  Selected: Boolean);
begin
  if FActive then
    MenueDrawItem(Sender, ACanvas, ARect, Selected);
end;



function TXPMenu.GetImageExtent(MenuItem: TMenuItem): TPoint;
var
  HasImgLstBitmap: boolean;
  B: TBitmap;
  FTopMenu: boolean;
begin
  FTopMenu := false;
  B := TBitmap.Create;
  B.Width := 0;
  B.Height := 0;
  Result.x := 0;
  Result.Y := 0;
  HasImgLstBitmap := false;

  if FForm.Menu <> nil then
    if MenuItem.GetParentComponent.Name = FForm.Menu.Name then
    begin
      FTopMenu := true;
      if FForm.Menu.Images <> nil then
        if MenuItem.ImageIndex <> -1 then
          HasImgLstBitmap := true;

    end;

  if (MenuItem.Parent.GetParentMenu.Images <> nil)
  {$IFDEF VER5U}
  or (MenuItem.Parent.SubMenuImages <> nil)
  {$ENDIF}
  then
  begin
    if MenuItem.ImageIndex <> -1 then
      HasImgLstBitmap := true
    else
      HasImgLstBitmap := false;
  end;

  if HasImgLstBitmap then
  begin
  {$IFDEF VER5U}
    if MenuItem.Parent.SubMenuImages <> nil then
      MenuItem.Parent.SubMenuImages.GetBitmap(MenuItem.ImageIndex, B)
    else
  {$ENDIF}
      MenuItem.Parent.GetParentMenu.Images.GetBitmap(MenuItem.ImageIndex, B)
  end
  else
    if MenuItem.Bitmap.Width > 0 then
      B.Assign(TBitmap(MenuItem.Bitmap));

  Result.x := B.Width;
  Result.Y := B.Height;

  if not FTopMenu then
    if Result.x < FIconWidth then
      Result.x := FIconWidth;

  B.Free;
end;

procedure TXPMenu.MeasureItem(Sender: TObject; ACanvas: TCanvas;
  var Width, Height: Integer);
var
  s: string;
  W, H: integer;
  P: TPoint;
  IsLine: boolean;
begin
  if FActive then
  begin
    S := TMenuItem(Sender).Caption;
      //------
    if S = '-' then IsLine := true else IsLine := false;
    if IsLine then

      //------
      if IsLine then
        S := '';

    if Trim(ShortCutToText(TMenuItem(Sender).ShortCut)) <> '' then
      S := S + ShortCutToText(TMenuItem(Sender).ShortCut) + 'WWW';



    ACanvas.Font.Assign(FFont);
    W := ACanvas.TextWidth(s);
    if pos('&', s) > 0 then
      W := W - ACanvas.TextWidth('&');

    P := GetImageExtent(TMenuItem(Sender));

    W := W + P.x + 10;

    if Width < W then
      Width := W;

    if IsLine then
      Height := 4
    else
    begin
      H := ACanvas.TextHeight(s) + Round(ACanvas.TextHeight(s) * 0.75);
      if P.y + 4 > H then
        H := P.y + 4;

      if Height < H then
        Height := H;
    end;
  end;

end;

procedure TXPMenu.MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
  Selected: Boolean);
var
  txt: string;
  B: TBitmap;
  IconRect, TextRect, CheckedRect: TRect;
  i, X1, X2: integer;
  TextFormat: integer;
  HasImgLstBitmap: boolean;
  FMenuItem: TMenuItem;
  FMenu: TMenu;
  FTopMenu: boolean;
  ISLine: boolean;
  ImgListHandle: HImageList;        {Commctrl.pas}
  ImgIndex: integer;
  hWndM: HWND;
  hDcM: HDC;
begin
  FTopMenu := false;
  FMenuItem := TMenuItem(Sender);

  SetGlobalColor(ACanvas);

  if FMenuItem.Caption = '-' then IsLine := true else IsLine := false;

  FMenu := FMenuItem.Parent.GetParentMenu;

  if FMenu is TMainMenu then
    for i := 0 to FMenuItem.GetParentMenu.Items.Count - 1 do
      if FMenuItem.GetParentMenu.Items[i] = FMenuItem then
      begin
        FTopMenu := True;
        break;
      end;


  ACanvas.Font.Assign(FFont);
  if FMenu.IsRightToLeft then
    ACanvas.Font.Charset := ARABIC_CHARSET;

  Inc(ARect.Bottom, 1);
  TextRect := ARect;
  txt := ' ' + FMenuItem.Caption;

  B := TBitmap.Create;

  HasImgLstBitmap := false;


  if FMenuItem.Bitmap.Width > 0 then
    B.Assign(TBitmap(FMenuItem.Bitmap));

  if (FMenuItem.Parent.GetParentMenu.Images <> nil)
  {$IFDEF VER5U}
  or (FMenuItem.Parent.SubMenuImages <> nil)
  {$ENDIF}
  then
  begin
    if FMenuItem.ImageIndex <> -1 then
      HasImgLstBitmap := true
    else
      HasImgLstBitmap := false;
  end;



  if FMenu.IsRightToLeft then
  begin
    X1 := ARect.Right - FIconWidth;
    X2 := ARect.Right;
  end
  else
  begin
    X1 := ARect.Left;
    X2 := ARect.Left + FIconWidth;
  end;
  IconRect := Rect(X1, ARect.Top, X2, ARect.Bottom);


  if HasImgLstBitmap then
  begin
    CheckedRect := IconRect;
    Inc(CheckedRect.Left, 1);
    Inc(CheckedRect.Top, 2);
    Dec(CheckedRect.Right, 3);
    Dec(CheckedRect.Bottom, 2);

  end
  else
  begin
    CheckedRect.Left := IconRect.Left +
      (IConRect.Right - IconRect.Left - 10) div 2;
    CheckedRect.Top := IconRect.Top +
      (IConRect.Bottom - IconRect.Top - 10) div 2;
    CheckedRect.Right := CheckedRect.Left + 10;
    CheckedRect.Bottom := CheckedRect.Top + 10;

  end;


  if FMenu.IsRightToLeft then
  begin
    X1 := ARect.Left;
    X2 := ARect.Right - FIconWidth;
    if B.Width > FIconWidth then
      X2 := ARect.Right - B.Width - 4;
  end
  else
  begin
    X1 := ARect.Left + FIconWidth;
    if B.Width > X1 then
      X1 := B.Width + 4;
    X2 := ARect.Right;
  end;

  TextRect := Rect(X1, ARect.Top, X2, ARect.Bottom);

  if FTopMenu then
  begin
    if not HasImgLstBitmap then
    begin
      TextRect := ARect;
    end
    else
    begin
      if FMenu.IsRightToLeft then
        TextRect.Right := TextRect.Right + 5
      else
        TextRect.Left := TextRect.Left - 5;
    end

  end;

  if FTopMenu then
  begin
    ACanvas.brush.color := FFMenuBarColor;
    ACanvas.Pen.Color := FFMenuBarColor;

    ACanvas.FillRect(ARect);
  end
  else
  begin
    if (Is16Bit and FGradient) then
    begin
      inc(ARect.Right,2);  //needed for RightToLeft
      DrawGradient(ACanvas, ARect, FMenu.IsRightToLeft);
      Dec(ARect.Right,2);

    end
    else
    begin
      ACanvas.brush.color := FFColor;
      ACanvas.FillRect(ARect);

      ACanvas.brush.color := FFIconBackColor;
      ACanvas.FillRect(IconRect);
    end;


//------------
  end;


  if FMenuItem.Enabled then
    ACanvas.Font.Color := FFont.Color
  else
    ACanvas.Font.Color := FDisabledColor;

  if Selected and FDrawSelect then
  begin
    ACanvas.brush.Style := bsSolid;
    if FTopMenu then
    begin
      DrawTopMenuItem(FMenuItem, ACanvas, ARect, FMenu.IsRightToLeft);
    end
    else
      //------
      if FMenuItem.Enabled then
      begin

        Inc(ARect.Top, 1);
        Dec(ARect.Bottom, 1);
        if FFlatMenu then
          Dec(ARect.Right, 1);
        ACanvas.brush.color := FFSelectColor;
        ACanvas.FillRect(ARect);
        ACanvas.Pen.color := FFSelectBorderColor;
        ACanvas.Brush.Style := bsClear;
        ACanvas.RoundRect(Arect.Left, Arect.top, Arect.Right,
          Arect.Bottom, 0, 0);
        Dec(ARect.Top, 1);
        Inc(ARect.Bottom, 1);
        if FFlatMenu then
          Inc(ARect.Right, 1);
      end;
      //-----

  end;

  DrawCheckedItem(FMenuItem, Selected, HasImgLstBitmap, ACanvas, CheckedRect);

//-----

  if HasImgLstBitmap then
  begin
  {$IFDEF VER5U}
    if FMenuItem.Parent.SubMenuImages <> nil then
    begin
      //FMenuItem.Parent.SubMenuImages.GetBitmap(FMenuItem.ImageIndex, B);
      ImgListHandle := FMenuItem.Parent.SubMenuImages.Handle;
      ImgIndex := FMenuItem.ImageIndex;

      B.Width := FMenuItem.Parent.SubMenuImages.Width;
      B.Height := FMenuItem.Parent.SubMenuImages.Height;
      B.Canvas.Brush.Color := FFIconBackColor;
      B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
      ImageList_DrawEx(ImgListHandle, ImgIndex,
        B.Canvas.Handle, 0, 0, 0, 0, clNone, clNone, ILD_Transparent);

    end
    else
  {$ENDIF}
    begin
      //FMenuItem.Parent.GetParentMenu.Images.GetBitmap(FMenuItem.ImageIndex, B);
      ImgListHandle := FMenuItem.Parent.GetParentMenu.Images.Handle;
      ImgIndex := FMenuItem.ImageIndex;

      B.Width := FMenuItem.Parent.GetParentMenu.Images.Width;
      B.Height := FMenuItem.Parent.GetParentMenu.Images.Height;
      B.Canvas.Brush.Color := FFIconBackColor;
      B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
      ImageList_DrawEx(ImgListHandle, ImgIndex,
        B.Canvas.Handle, 0, 0, 0, 0, clNone, clNone, ILD_Transparent);

    end;
  end

  else
    if FMenuItem.Bitmap.Width > 0 then
      B.Assign(TBitmap(FMenuItem.Bitmap));


  DrawIcon(FMenuItem, ACanvas, B, IconRect,
    Selected, False, FMenuItem.Enabled, FMenuItem.Checked,
    FTopMenu, FMenu.IsRightToLeft);


//--------
  if not IsLine then
  begin

    if FMenu.IsRightToLeft then
    begin
      TextFormat := DT_RIGHT + DT_RTLREADING;
      Dec(TextRect.Right, 5);
    end
    else
    begin
      TextFormat := 0;
      Inc(TextRect.Left, 5);
    end;

    DrawTheText(txt, ShortCutToText(FMenuItem.ShortCut),
      ACanvas, TextRect,
      Selected, FMenuItem.Enabled, FMenuItem.Default,
      FTopMenu, FMenu.IsRightToLeft, TextFormat);

//-----------

  end


  else
  begin
    if FMenu.IsRightToLeft then
    begin
      X1 := TextRect.Left;
      X2 := TextRect.Right - 7;
    end
    else
    begin
      X1 := TextRect.Left + 7;
      X2 := TextRect.Right;
    end;

    ACanvas.Pen.Color := FFSeparatorColor;
    ACanvas.MoveTo(X1,
      TextRect.Top +
      Round((TextRect.Bottom - TextRect.Top) / 2));
    ACanvas.LineTo(X2,
      TextRect.Top +
      Round((TextRect.Bottom - TextRect.Top) / 2))
  end;

  B.free;

//------

  if not (csDesigning in ComponentState) then
  begin
    if (FFlatMenu) and (not FTopMenu) then
    begin
      hDcM := ACanvas.Handle;
      hWndM := WindowFromDC(hDcM);
      if hWndM <> FForm.Handle then
      begin
        DrawWindowBorder(hWndM, FMenu.IsRightToLeft);
      end;
    end;
  end;

//-----
  ActivateMenuItem(FMenuItem);  // to check for new sub items
end;


procedure TXPMenu.ToolBarDrawButton(Sender: TToolBar;
  Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean);

var
  ACanvas: TCanvas;

  ARect, HoldRect: TRect;
  B: TBitmap;
  HasBitmap: boolean;
  BitmapWidth: integer;
  TextFormat: integer;
  XButton: TToolButton;
  HasBorder: boolean;
  HasBkg: boolean;
  IsTransparent: boolean;
  FBSelectColor: TColor;

  procedure DrawBorder;
  var
    BRect, WRect: TRect;
    procedure DrawRect;
    begin
      ACanvas.Pen.color := FFSelectBorderColor;
      ACanvas.MoveTo(WRect.Left, WRect.Top);
      ACanvas.LineTo(WRect.Right, WRect.Top);
      ACanvas.LineTo(WRect.Right, WRect.Bottom);
      ACanvas.LineTo(WRect.Left, WRect.Bottom);
      ACanvas.LineTo(WRect.Left, WRect.Top);
    end;

  begin
    BRect := HoldRect;
    Dec(BRect.Bottom, 1);
    Inc(BRect.Top, 1);
    Dec(BRect.Right, 1);

    WRect := BRect;
    if Button.Style = tbsDropDown then
    begin
      Dec(WRect.Right, 13);
      DrawRect;

      WRect := BRect;
      Inc(WRect.Left, WRect.Right - WRect.Left - 13);
      DrawRect;
    end
    else
    begin

      DrawRect;
    end;
  end;

begin
  B := nil;

  HasBitmap := (TToolBar(Button.Parent).Images <> nil) and
    (Button.ImageIndex <> -1) and
    (Button.ImageIndex <= TToolBar(Button.Parent).Images.Count - 1);


  IsTransparent := TToolBar(Button.Parent).Transparent;

  ACanvas := Sender.Canvas;
  SetGlobalColor(ACanvas);

  if (Is16Bit) and (not UseSystemColors) then
    FBSelectColor := NewColor(ACanvas, FSelectColor, 68)
  else
    FBSelectColor := FFSelectColor;


  HoldRect := Button.BoundsRect;

  ARect := HoldRect;

  //if FUseSystemColors then
  begin
    if (Button.MenuItem <> nil) then
    begin
      if (TToolBar(Button.Parent).Font.Name <> FFont.Name) or
         (TToolBar(Button.Parent).Font.Size <> FFont.Size) then
      begin
        TToolBar(Button.Parent).Font.Assign(FFont);
        Button.AutoSize := false;
        Button.AutoSize := true;
      end;
    end
  end;

  if Is16Bit then
    ACanvas.brush.color := NewColor(ACanvas, clBtnFace, 16)
  else
    ACanvas.brush.color := clBtnFace;

  if not IsTransparent then
    ACanvas.FillRect(ARect);

  HasBorder := false;
  HasBkg := false;

  if (cdsHot in State) then
  begin
    if (cdsChecked in State) or (Button.Down) or (cdsSelected in State) then
      ACanvas.Brush.Color := FCheckedAreaSelectColor
    else
      ACanvas.brush.color := FBSelectColor;
    HasBorder := true;
    HasBkg := true;
  end;

  if (cdsChecked in State) and not (cdsHot in State) then
  begin
    ACanvas.Brush.Color := FCheckedAreaColor;
    HasBorder := true;
    HasBkg := true;
  end;

  if (cdsIndeterminate in State) and not (cdsHot in State) then
  begin
    ACanvas.Brush.Color := FBSelectColor;
    HasBkg := true;
  end;


  if (Button.MenuItem <> nil) and (State = []) then
  begin
    ACanvas.brush.color := FFMenuBarColor;
    if not IsTransparent then
      HasBkg := true;
  end;


  Inc(ARect.Top, 1);

  if HasBkg then
    ACanvas.FillRect(ARect);

  if HasBorder then
    DrawBorder;


  if (Button.MenuItem <> nil)
    and (cdsSelected in State) then
  begin
    DrawTopMenuItem(Button, ACanvas, ARect, false);
    DefaultDraw := false;
  end;

  ARect := HoldRect;
  DefaultDraw := false;



  if Button.Style = tbsDropDown then
  begin
    ACanvas.Pen.Color := clBlack;
    DrawArrow(ACanvas, (ARect.Right - 14) + ((14 - 5) div 2),
      ARect.Top + ((ARect.Bottom - ARect.Top - 3) div 2) + 1);
  end;

  BitmapWidth := 0;
  if HasBitmap then
  begin

    try
    B := TBitmap.Create;
  //TToolBar(Button.Parent).Images.GetBitmap(Button.ImageIndex, B);

    B.Width := TToolBar(Button.Parent).Images.Width;
    B.Height := TToolBar(Button.Parent).Images.Height;
    B.Canvas.Brush.Color := ACanvas.Brush.Color;
    B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
    ImageList_DrawEx(TToolBar(Button.Parent).Images.Handle, Button.ImageIndex,
      B.Canvas.Handle, 0, 0, 0, 0, clNone, clNone, ILD_Transparent);

    ImgLstHandle:= TToolBar(Button.Parent).Images.Handle;
    ImgLstIndex:= Button.ImageIndex;



    BitmapWidth := b.Width;

    if Button.Style = tbsDropDown then
      Dec(ARect.Right, 12);


    if TToolBar(Button.Parent).List then
    begin

      if Button.BiDiMode = bdRightToLeft then
      begin
        Dec(ARect.Right, 3);
        ARect.Left := ARect.Right - BitmapWidth;

      end
      else
      begin
        Inc(ARect.Left, 3);
        ARect.Right := ARect.Left + BitmapWidth
      end


    end
    else
      ARect.Left := Round(ARect.Left + (ARect.Right - ARect.Left - B.Width)/2);

    inc(ARect.Top, 2);
    ARect.Bottom := ARect.Top + B.Height + 6;

    DrawIcon(Button, ACanvas, B, ARect, (cdsHot in State),
     (cdsSelected in State), Button.Enabled, (cdsChecked in State), false,
     false);
    finally
    B.Free;
    end;
    ARect := HoldRect;
    DefaultDraw := false;
  end;
//-----------
  if TToolBar(Button.Parent).ShowCaptions then
  begin

    if Button.Style = tbsDropDown then
      Dec(ARect.Right, 12);


    if not TToolBar(Button.Parent).List then
    begin
      TextFormat := DT_Center;
      ARect.Top := ARect.Bottom - ACanvas.TextHeight(Button.Caption) - 3;
    end
    else
    begin
      TextFormat := DT_VCENTER;
      if Button.BiDiMode = bdRightToLeft then
      begin
        TextFormat := TextFormat + DT_Right;
        Dec(ARect.Right, BitmapWidth + 7);
      end
      else
      begin
        Inc(ARect.Left, BitmapWidth + 6);
      end

    end;

    if (Button.MenuItem <> nil) then
    begin
      TextFormat := DT_Center;

    end;

    if Button.BiDiMode = bdRightToLeft then
      TextFormat := TextFormat + DT_RTLREADING;

    DrawTheText(Button.Caption, '',
      ACanvas, ARect,
      (cdsSelected in State), Button.Enabled, false,
      (Button.MenuItem <> nil),
      (Button.BidiMode = bdRightToLeft), TextFormat);

    ARect := HoldRect;
    DefaultDraw := false;
  end;


  if Button.Index > 0 then
  begin
    XButton := TToolBar(Button.Parent).Buttons[Button.Index - 1];
    if (XButton.Style = tbsDivider) or (XButton.Style = tbsSeparator) then
    begin
      ARect := XButton.BoundsRect;
      if Is16Bit then
        ACanvas.brush.color := NewColor(ACanvas, clBtnFace, 16)
      else
        ACanvas.brush.color := clBtnFace;

      if not IsTransparent then
        ACanvas.FillRect(ARect);
     // if (XButton.Style = tbsDivider) then  // Can't get it.
      if XButton.Tag > 0 then  
      begin
        Inc(ARect.Top, 2);
        Dec(ARect.Bottom, 1);

        ACanvas.Pen.color := FFDisabledColor;
        ARect.Left := ARect.Left + (ARect.Right - ARect.Left) div 2;
        ACanvas.MoveTo(ARect.Left, ARect.Top);
        ACanvas.LineTo(ARect.Left, ARect.Bottom);

      end;
      ARect := Button.BoundsRect;
      DefaultDraw := false;
    end;

  end;

  if Button.MenuItem <> nil then
    ActivateMenuItem(Button.MenuItem);
end;


procedure TXPMenu.SetGlobalColor(ACanvas: TCanvas);
begin
//-----

  if GetDeviceCaps(ACanvas.Handle, BITSPIXEL) < 16 then
    Is16Bit := false
  else
    Is16Bit := true;


  FFColor := FColor;
  FFIconBackColor := FIconBackColor;

  FFSelectColor := FSelectColor;

  if Is16Bit then
  begin
    FCheckedAreaColor := NewColor(ACanvas, FSelectColor, 75);
    FCheckedAreaSelectColor := NewColor(ACanvas, FSelectColor, 50);

    FMenuBorderColor := GetShadeColor(ACanvas, clBtnFace, 90);
    FMenuShadowColor := GetShadeColor(ACanvas, clBtnFace, 76);
  end
  else
  begin
    FFSelectColor := FSelectColor;
    FCheckedAreaColor := clWhite;
    FCheckedAreaSelectColor := clSilver;
    FMenuBorderColor := clBtnShadow;
    FMenuShadowColor := clBtnShadow;
  end;

  FFSelectBorderColor := FSelectBorderColor;
  FFSelectFontColor := FSelectFontColor;
  FFMenuBarColor := FMenuBarColor;
  FFDisabledColor := FDisabledColor;
  FFCheckedColor := FCheckedColor;
  FFSeparatorColor := FSeparatorColor;



  if FUseSystemColors then
  begin
    GetSystemMenuFont(FFont);
    FFSelectFontColor := FFont.Color;
    if not Is16Bit then
    begin
      FFColor := clWhite;
      FFIconBackColor := clBtnFace;
      FFSelectColor := clWhite;
      FFSelectBorderColor := clHighlight;
      FFMenuBarColor := FFIconBackColor;
      FFDisabledColor := clBtnShadow;
      FFCheckedColor := clHighlight;
      FFSeparatorColor := clBtnShadow;
      FCheckedAreaColor := clWhite;
      FCheckedAreaSelectColor := clWhite;

    end
    else
    begin
      FFColor := NewColor(ACanvas, clBtnFace, 86);
      FFIconBackColor := NewColor(ACanvas, clBtnFace, 16);
      FFSelectColor := NewColor(ACanvas, clHighlight, 68);
      FFSelectBorderColor := clHighlight;
      FFMenuBarColor := clMenu;

      FFDisabledColor := NewColor(ACanvas, clBtnShadow, 40);
      FFSeparatorColor := NewColor(ACanvas, clBtnShadow, 25);
      FFCheckedColor := clHighlight;
      FCheckedAreaColor := NewColor(ACanvas, clHighlight, 75);
      FCheckedAreaSelectColor := NewColor(ACanvas, clHighlight, 50);

    end;
  end;

end;

procedure TXPMenu.DrawTopMenuItem(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect; IsRightToLeft: boolean);
var
  X1, X2: integer;
  DefColor, HoldColor: TColor;
begin
  X1 := ARect.Left;
  X2 := ARect.Right;


  ACanvas.brush.Style := bsSolid;
  ACanvas.brush.color := FFIconBackColor;

  ACanvas.FillRect(ARect);
  ACanvas.Pen.Color := FMenuBorderColor;

  if (not IsRightToLeft) and (Is16Bit) and (Sender is TMenuItem) then
  begin
    ACanvas.MoveTo(X1, ARect.Bottom - 1);
    ACanvas.LineTo(X1, ARect.Top);
    ACanvas.LineTo(X2 - 8, ARect.Top);
    ACanvas.LineTo(X2 - 8, ARect.Bottom);

    DefColor := FFMenuBarColor;


    HoldColor := GetShadeColor(ACanvas, DefColor, 10);
    ACanvas.Brush.Style := bsSolid;
    ACanvas.Brush.Color := HoldColor;
    ACanvas.Pen.Color := HoldColor;

    ACanvas.FillRect(Rect(X2 - 7, ARect.Top, X2, ARect.Bottom));

    HoldColor := GetShadeColor(ACanvas, DefColor, 30);
    ACanvas.Brush.Color := HoldColor;
    ACanvas.Pen.Color := HoldColor;
    ACanvas.FillRect(Rect(X2 - 7, ARect.Top + 3, X2 - 2, ARect.Bottom));

    HoldColor := GetShadeColor(ACanvas, DefColor, 40 + 20);
    ACanvas.Brush.Color := HoldColor;
    ACanvas.Pen.Color := HoldColor;
    ACanvas.FillRect(Rect(X2 - 7, ARect.Top + 5, X2 - 3, ARect.Bottom));

    HoldColor := GetShadeColor(ACanvas, DefColor, 60 + 40);
    ACanvas.Brush.Color := HoldColor;
    ACanvas.Pen.Color := HoldColor;
    ACanvas.FillRect(Rect(X2 - 7, ARect.Top + 6, X2 - 5, ARect.Bottom));

    //---

    ACanvas.Pen.Color := DefColor;
    ACanvas.MoveTo(X2 - 5, ARect.Top + 1);
    ACanvas.LineTo(X2 - 1, ARect.Top + 1);
    ACanvas.LineTo(X2 - 1, ARect.Top + 6);

    ACanvas.MoveTo(X2 - 3, ARect.Top + 2);
    ACanvas.LineTo(X2 - 2, ARect.Top + 2);
    ACanvas.LineTo(X2 - 2, ARect.Top + 3);
    ACanvas.LineTo(X2 - 3, ARect.Top + 3);



    ACanvas.Pen.Color := GetShadeColor(ACanvas, DefColor, 10);
    ACanvas.MoveTo(X2 - 6, ARect.Top + 3);
    ACanvas.LineTo(X2 - 3, ARect.Top + 3);
    ACanvas.LineTo(X2 - 3, ARect.Top + 6);
    ACanvas.LineTo(X2 - 4, ARect.Top + 6);
    ACanvas.LineTo(X2 - 4, ARect.Top + 3);

    ACanvas.Pen.Color := GetShadeColor(ACanvas, DefColor, 30);
    ACanvas.MoveTo(X2 - 5, ARect.Top + 5);
    ACanvas.LineTo(X2 - 4, ARect.Top + 5);
    ACanvas.LineTo(X2 - 4, ARect.Top + 9);

    ACanvas.Pen.Color := GetShadeColor(ACanvas, DefColor, 40);
    ACanvas.MoveTo(X2 - 6, ARect.Top + 5);
    ACanvas.LineTo(X2 - 6, ARect.Top + 7);

  end
  else
  begin
    ACanvas.Pen.Color := FMenuBorderColor;
    ACanvas.Brush.Color := FMenuShadowColor;

    ACanvas.MoveTo(X1, ARect.Bottom - 1);
    ACanvas.LineTo(X1, ARect.Top);
    ACanvas.LineTo(X2 - 3, ARect.Top);
    ACanvas.LineTo(X2 - 3, ARect.Bottom);


    ACanvas.Pen.Color := ACanvas.Brush.Color;
    ACanvas.FillRect(Rect(X2 - 2, ARect.Top + 2, X2, ARect.Bottom));
  end;

end;


procedure TXPMenu.DrawCheckedItem(FMenuItem: TMenuItem; Selected,
 HasImgLstBitmap: boolean; ACanvas: TCanvas; CheckedRect: TRect);
var
  X1, X2: integer;
begin
  if FMenuItem.RadioItem then
  begin
    if FMenuItem.Checked then
    begin

      ACanvas.Pen.color := FFSelectBorderColor;
      if selected then
        ACanvas.Brush.Color := FCheckedAreaSelectColor
      else
        ACanvas.Brush.Color := FCheckedAreaColor;
      ACanvas.Brush.Style := bsSolid;
      if HasImgLstBitmap then
      begin
        ACanvas.RoundRect(CheckedRect.Left, CheckedRect.Top,
          CheckedRect.Right, CheckedRect.Bottom,
          6, 6);
      end
      else
      begin
        ACanvas.Ellipse(CheckedRect.Left, CheckedRect.Top,
          CheckedRect.Right, CheckedRect.Bottom);
      end;
    end;
  end
  else
  begin
    if (FMenuItem.Checked) then
      if (not HasImgLstBitmap) then
      begin
        ACanvas.Pen.color := FFCheckedColor;
        if selected then
          ACanvas.Brush.Color := FCheckedAreaSelectColor
        else
          ACanvas.Brush.Color := FCheckedAreaColor; ;
        ACanvas.Brush.Style := bsSolid;
        ACanvas.Rectangle(CheckedRect.Left, CheckedRect.Top,
          CheckedRect.Right, CheckedRect.Bottom);
        ACanvas.Pen.color := clBlack;
        x1 := CheckedRect.Left + 1;
        x2 := CheckedRect.Top + 5;
        ACanvas.MoveTo(x1, x2);

        x1 := CheckedRect.Left + 4;
        x2 := CheckedRect.Bottom - 2;
        ACanvas.LineTo(x1, x2);
           //--
        x1 := CheckedRect.Left + 2;
        x2 := CheckedRect.Top + 5;
        ACanvas.MoveTo(x1, x2);

        x1 := CheckedRect.Left + 4;
        x2 := CheckedRect.Bottom - 3;
        ACanvas.LineTo(x1, x2);
           //--
        x1 := CheckedRect.Left + 2;
        x2 := CheckedRect.Top + 4;
        ACanvas.MoveTo(x1, x2);

        x1 := CheckedRect.Left + 5;
        x2 := CheckedRect.Bottom - 3;
        ACanvas.LineTo(x1, x2);
           //-----------------

        x1 := CheckedRect.Left + 4;
        x2 := CheckedRect.Bottom - 3;
        ACanvas.MoveTo(x1, x2);

        x1 := CheckedRect.Right + 2;
        x2 := CheckedRect.Top - 1;
        ACanvas.LineTo(x1, x2);
           //--
        x1 := CheckedRect.Left + 4;
        x2 := CheckedRect.Bottom - 2;
        ACanvas.MoveTo(x1, x2);

        x1 := CheckedRect.Right - 2;
        x2 := CheckedRect.Top + 3;
        ACanvas.LineTo(x1, x2);

      end
      else
      begin
        ACanvas.Pen.color := FFSelectBorderColor;
        if selected then
          ACanvas.Brush.Color := FCheckedAreaSelectColor
        else
          ACanvas.Brush.Color := FCheckedAreaColor;
        ACanvas.Brush.Style := bsSolid;
        ACanvas.Rectangle(CheckedRect.Left, CheckedRect.Top,
          CheckedRect.Right, CheckedRect.Bottom);
      end;
  end;

end;

procedure TXPMenu.DrawTheText(txt, ShortCuttext: string; ACanvas: TCanvas; TextRect: TRect;
  Selected, Enabled, Default, TopMenu, IsRightToLeft: boolean; TextFormat: integer);
var
  DefColor: TColor;
begin

  DefColor := FFont.Color;

  ACanvas.Font := FFont;


  if Enabled then
    DefColor := FFont.Color;


  if Selected then
    DefColor := FFSelectFontColor;


  if not Enabled then
  begin
    DefColor := FFDisabledColor;
    if Selected then
      if Is16Bit then
        DefColor := NewColor(ACanvas, FFDisabledColor, 30);
  end;

  if (TopMenu and Selected) then
    DefColor := TopMenuFontColor(ACanvas, FFIconBackColor);

  ACanvas.Font.color := DefColor;    // will not affect Buttons


  TextRect.Top := TextRect.Top +
    ((TextRect.Bottom - TextRect.Top) - ACanvas.TextHeight('W')) div 2;

  SetBkMode(ACanvas.Handle, TRANSPARENT);


  if Default and Enabled then
  begin

    Inc(TextRect.Left, 1);
    ACanvas.Font.color := GetShadeColor(ACanvas,
                              ACanvas.Pixels[TextRect.Left, TextRect.Top], 30);
    DrawtextEx(ACanvas.Handle,
      PChar(txt),
      Length(txt),
      TextRect, TextFormat, nil);
    Dec(TextRect.Left, 1);


    Inc(TextRect.Top, 2);
    Inc(TextRect.Left, 1);
    Inc(TextRect.Right, 1);


    ACanvas.Font.color := GetShadeColor(ACanvas,
                              ACanvas.Pixels[TextRect.Left, TextRect.Top], 30);
    DrawtextEx(ACanvas.Handle,
      PChar(txt),
      Length(txt),
      TextRect, TextFormat, nil);


    Dec(TextRect.Top, 1);
    Dec(TextRect.Left, 1);
    Dec(TextRect.Right, 1);

    ACanvas.Font.color := GetShadeColor(ACanvas,
                              ACanvas.Pixels[TextRect.Left, TextRect.Top], 40);
    DrawtextEx(ACanvas.Handle,
      PChar(txt),
      Length(txt),
      TextRect, TextFormat, nil);


    Inc(TextRect.Left, 1);
    Inc(TextRect.Right, 1);

    ACanvas.Font.color := GetShadeColor(ACanvas,
                              ACanvas.Pixels[TextRect.Left, TextRect.Top], 60);
    DrawtextEx(ACanvas.Handle,
      PChar(txt),
      Length(txt),
      TextRect, TextFormat, nil);

    Dec(TextRect.Left, 1);
    Dec(TextRect.Right, 1);
    Dec(TextRect.Top, 1);

    ACanvas.Font.color := DefColor;
  end;



  DrawtextEx(ACanvas.Handle,
    PChar(txt),
    Length(txt),
    TextRect, TextFormat, nil);


  txt := ShortCutText + ' ';

  if not Is16Bit then
    ACanvas.Font.color := DefColor
  else
    ACanvas.Font.color := GetShadeColor(ACanvas, DefColor, -40);



  if IsRightToLeft then
  begin
    Inc(TextRect.Left, 10);
    TextFormat := DT_LEFT
  end
  else
  begin
    Dec(TextRect.Right, 10);
    TextFormat := DT_RIGHT;
  end;

  DrawtextEx(ACanvas.Handle,
    PChar(txt),
    Length(txt),
    TextRect, TextFormat, nil);

end;

procedure TXPMenu.DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap;
 IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu,
 IsRightToLeft: boolean);
var
  DefColor: TColor;
  X1, X2: integer;
begin
  if B <> nil then
  begin
    X1 := IconRect.Left;
    X2 := IconRect.Top + 2;
    if Sender is TMenuItem then
    begin
      inc(X2, 2);
      if FIconWidth >= B.Width then
        X1 := X1 + ((FIconWidth - B.Width) div 2) - 1
      else
      begin
        if IsRightToLeft then
          X1 := IconRect.Right - b.Width - 2
        else
          X1 := IconRect.Left + 2;
      end;
    end;


    if (Hot) and (not FTopMenu) and (Enabled) and (not Checked) then
      if not Selected then
      begin
        dec(X1, 1);
        dec(X2, 1);
      end;

    if (not Hot) and (Enabled) and (not Checked) then
      if Is16Bit then
        DimBitmap(B, 30);

    if (not Hot) and (not Enabled) then
      GrayBitmap(B, 60);

    if (Hot) and (not Enabled) then
      GrayBitmap(B, 80);



    if (Hot) and (Enabled) and (not Checked) then
    begin
      if (Is16Bit) and (not UseSystemColors) and (Sender is TToolButton) then
        DefColor := NewColor(ACanvas, FSelectColor, 68)
      else
        DefColor := FFSelectColor;

      DefColor := GetShadeColor(ACanvas, DefColor, 50);
      DrawBitmapShadow(B, ACanvas, X1 + 2, X2 + 2, DefColor);
    end;

    B.Transparent := true;
    ACanvas.Draw(X1, X2, B);


  end;

end;

procedure TXPMenu.DrawArrow(ACanvas: TCanvas; X, Y: integer);
begin
  ACanvas.MoveTo(X, Y);
  ACanvas.LineTo(X + 4, Y);

  ACanvas.MoveTo(X + 1, Y + 1);
  ACanvas.LineTo(X + 4, Y);

  ACanvas.MoveTo(X + 2, Y + 2);
  ACanvas.LineTo(X + 3, Y);

end;

function TXPMenu.TopMenuFontColor(ACanvas: TCanvas; Color: TColor): TColor;
var
  r, g, b, avg: integer;
begin

  Color := ColorToRGB(Color);
  r := Color and $000000FF;
  g := (Color and $0000FF00) shr 8;
  b := (Color and $00FF0000) shr 16;

  Avg := (r + b) div 2;

  if (Avg > 150) or (g > 200) then
    Result := FFont.Color
  else
    Result := NewColor(ACanvas, Color, 90);
   // Result := FColor;
end;


procedure TXPMenu.SetActive(const Value: boolean);
begin

  FActive := Value;

  if FActive then
  begin
    InitMenueItems(false);
    InitMenueItems(true);
  end
  else
    InitMenueItems(false);
  // Tolik 03/05/2019
 // Windows.DrawMenuBar(FForm.Handle);
 //
end;

procedure TXPMenu.SetForm(const Value: TForm);
var
  Hold: boolean;
begin
  if Value <> FForm then
  begin
    Hold := Active;
    Active := false;
    FForm := Value;
    if Hold then
      Active := True;
  end;
end;

procedure TXPMenu.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
  Windows.DrawMenuBar(FForm.Handle);

end;

procedure TXPMenu.SetColor(const Value: TColor);
begin
  FColor := Value;
end;

procedure TXPMenu.SetIconBackColor(const Value: TColor);
begin
  FIconBackColor := Value;
end;

procedure TXPMenu.SetMenuBarColor(const Value: TColor);
begin
  FMenuBarColor := Value;
  Windows.DrawMenuBar(FForm.Handle);
end;

procedure TXPMenu.SetCheckedColor(const Value: TColor);
begin
  FCheckedColor := Value;
end;

procedure TXPMenu.SetSeparatorColor(const Value: TColor);
begin
  FSeparatorColor := Value;
end;

procedure TXPMenu.SetSelectBorderColor(const Value: TColor);
begin
  FSelectBorderColor := Value;
end;

procedure TXPMenu.SetSelectColor(const Value: TColor);
begin
  FSelectColor := Value;
end;

procedure TXPMenu.SetDisabledColor(const Value: TColor);
begin
  FDisabledColor := Value;
end;

procedure TXPMenu.SetSelectFontColor(const Value: TColor);
begin
  FSelectFontColor := Value;
end;

procedure TXPMenu.SetIconWidth(const Value: integer);
begin
  FIconWidth := Value;
end;

procedure TXPMenu.SetDrawSelect(const Value: boolean);
begin
  FDrawSelect := Value;
end;



procedure TXPMenu.SetOverrideOwnerDraw(const Value: boolean);
begin
  FOverrideOwnerDraw := Value;
  if FActive then
    Active := True;
end;


procedure TXPMenu.SetUseSystemColors(const Value: boolean);
begin
  FUseSystemColors := Value;
  Windows.DrawMenuBar(FForm.Handle);
end;

{
procedure TXPMenu.SetRefreshOnChange(const Value: boolean);
begin
  FRefreshOnChange := Value;
  if not (csDesigning in ComponentState) and
   (FActive) then
    Active := True;
end;

procedure TXPMenu.MenuChange(Sender: TObject; Source: TMenuItem;
  Rebuild: Boolean);
begin
  if not (csDesigning in ComponentState) then
    if (Source <> nil) then
      if  ComponentState = [] then
       Active := true ;
end;
}

procedure TXPMenu.SetGradient(const Value: boolean);
begin
  FGradient := Value;
end;

procedure TXPMenu.SetFlatMenu(const Value: boolean);
begin
  FFlatMenu := Value;
end;


procedure GetSystemMenuFont(Font: TFont);
var
  FNonCLientMetrics: TNonCLientMetrics;
begin
  FNonCLientMetrics.cbSize := Sizeof(TNonCLientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @FNonCLientMetrics,0) then
  begin
    Font.Handle := CreateFontIndirect(FNonCLientMetrics.lfMenuFont);
    Font.Color := clMenuText;
    if Font.Name = 'MS Sans Serif' then
      Font.Name := 'Tahoma';
  end;
end;


procedure TXPMenu.DrawGradient(ACanvas: TCanvas; ARect: TRect;
 IsRightToLeft: boolean);
var
  i: integer;
  v: integer;
  FRect: TRect;
begin

  fRect := ARect;
  V := 0;
  if IsRightToLeft then
  begin
    fRect.Left := fRect.Right - 1;
    for i := ARect.Right Downto ARect.Left do
    begin
      if (fRect.Left < ARect.Right)
        and (fRect.Left > ARect.Right - FIconWidth + 5) then
        inc(v, 3)
      else
        inc(v, 1);

      if v > 96 then v := 96;
      ACanvas.Brush.Color := NewColor(ACanvas, FFIconBackColor, v);
      ACanvas.FillRect(fRect);

      fRect.Left := fRect.Left - 1;
      fRect.Right := fRect.Left - 1;
    end;
  end
  else
  begin
    fRect.Right := fRect.Left + 1;
    for i := ARect.Left to ARect.Right do
    begin
      if (fRect.Left > ARect.Left)
        and (fRect.Left < ARect.Left + FIconWidth + 5) then
        inc(v, 3)
      else
        inc(v, 1);

      if v > 96 then v := 96;
      ACanvas.Brush.Color := NewColor(ACanvas, FFIconBackColor, v);
      ACanvas.FillRect(fRect);

      fRect.Left := fRect.Left + 1;
      fRect.Right := fRect.Left + 1;
    end;
  end;
end;


procedure TXPMenu.DrawWindowBorder(hWnd: HWND; IsRightToLeft: boolean);
var
  WRect, CRect: TRect;
  dCanvas: TCanvas;
begin

  if hWnd <= 0 then
  begin
   exit;
  end;
  dCanvas := nil;
  try
  dCanvas := TCanvas.Create;
  dCanvas.Handle := GetDc(0);

  GetClientRect(hWnd, CRect);
  GetWindowRect(hWnd, WRect);

  ExcludeClipRect(dCanvas.Handle, CRect.Left, CRect.Top, CRect.Right,
                  CRect.Bottom);

  dCanvas.Brush.Style := bsClear;


  Dec(WRect.Right, 2);
  Dec(WRect.Bottom, 2);

  dCanvas.Pen.Color := FMenuBorderColor;
  dCanvas.Rectangle(WRect.Left, WRect.Top, WRect.Right, WRect.Bottom);




  if IsRightToLeft then
  begin
    dCanvas.Pen.Color := FFColor;
    dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 1, WRect.Right - 2,
                      WRect.Top + 3);

    dCanvas.MoveTo(WRect.Left + 2, WRect.Top + 2);
    dCanvas.LineTo(WRect.Left + 2, WRect.Bottom - 2);


    dCanvas.Pen.Color := FFIconBackColor;
    dCanvas.MoveTo(WRect.Right - 2, WRect.Top + 2);
    dCanvas.LineTo(WRect.Right - 2, WRect.Bottom - 2);

    dCanvas.MoveTo(WRect.Right - 2, WRect.Top + 2);
    dCanvas.LineTo(WRect.Right - 1 - FIconWidth, WRect.Top + 2);
  end
  else
  begin
    if not FGradient then
    begin
      dCanvas.Pen.Color := FFColor;
      dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 1, WRect.Right - 2,
                        WRect.Top + 3);

      dCanvas.Pen.Color := FFIconBackColor;
      dCanvas.MoveTo(WRect.Left + 1, WRect.Top + 2);
      dCanvas.LineTo(WRect.Left + 2 + FIconWidth, WRect.Top + 2);
    end;

    dCanvas.Pen.Color := FFIconBackColor;
    dCanvas.MoveTo(WRect.Left + 1, WRect.Top + 1);
    dCanvas.LineTo(WRect.Left + 1, WRect.Bottom - 2);


  end;

  Inc(WRect.Right, 2);
  Inc(WRect.Bottom, 2);

  dCanvas.Pen.Color := FMenuShadowColor;
  dCanvas.Rectangle(WRect.Left +2, WRect.Bottom, WRect.Right, WRect.Bottom - 2);
  dCanvas.Rectangle(WRect.Right - 2, WRect.Bottom, WRect.Right, WRect.Top + 2);


  dCanvas.Pen.Color := FFIconBackColor;
  dCanvas.Rectangle(WRect.Left, WRect.Bottom - 2, WRect.Left + 2, WRect.Bottom);
  dCanvas.Rectangle(WRect.Right - 2, WRect.Top, WRect.Right, WRect.Top + 2);
  finally
  IntersectClipRect(dCanvas.Handle, WRect.Left, WRect.Top, WRect.Right, WRect.Bottom);
  dCanvas.Free;
  end;


end;



procedure TXPMenu.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opInsert) and
     ((AComponent is TMenuItem) or (AComponent is TToolButton)) then
  begin
   if (csDesigning in ComponentState) then
     Active := true
   else
     //if ComponentState = [] then
        Active := true ;
  end;


end;


function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b: integer;

begin
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;

  r := (r - value);
  if r < 0 then r := 0;
  if r > 255 then r := 255;

  g := (g - value) + 2;
  if g < 0 then g := 0;
  if g > 255 then g := 255;

  b := (b - value);
  if b < 0 then b := 0;
  if b > 255 then b := 255;

  Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b));
end;

function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b: integer;

begin
  if Value > 100 then Value := 100;
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;


  r := r + Round((255 - r) * (value / 100));
  g := g + Round((255 - g) * (value / 100));
  b := b + Round((255 - b) * (value / 100));

  Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b));

end;

function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b, avg: integer;

begin
  if Value > 100 then Value := 100;
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;
  Avg := (r + g + b) div 3;
  Avg := Avg + Value;
  if Avg > 240 then Avg := 240;

  Result := Windows.GetNearestColor (ACanvas.Handle,RGB(Avg, avg, avg));
end;

procedure GrayBitmap(ABitmap: TBitmap; Value: integer);
var
  x, y: integer;
  LastColor1, LastColor2, Color: TColor;
begin
  LastColor1 := 0;
  LastColor2 := 0;

  for y := 0 to ABitmap.Height do
    for x := 0 to ABitmap.Width do
    begin
      Color := ABitmap.Canvas.Pixels[x, y];
      if Color = LastColor1 then
        ABitmap.Canvas.Pixels[x, y] := LastColor2
      else
      begin
        LastColor2 := GrayColor(ABitmap.Canvas , Color, Value);
        ABitmap.Canvas.Pixels[x, y] := LastColor2;
        LastColor1 := Color;
      end;
    end;
end;

procedure DimBitmap(ABitmap: TBitmap; Value: integer);
var
  x, y: integer;
  LastColor1, LastColor2, Color: TColor;
begin
  if Value > 100 then Value := 100;
  LastColor1 := -1;
  LastColor2 := -1;

  for y := 0 to ABitmap.Height - 1 do
    for x := 0 to ABitmap.Width - 1 do
    begin
      Color := ABitmap.Canvas.Pixels[x, y];
      if Color = LastColor1 then
        ABitmap.Canvas.Pixels[x, y] := LastColor2
      else
      begin
        LastColor2 := NewColor(ABitmap.Canvas, Color, Value);
        ABitmap.Canvas.Pixels[x, y] := LastColor2;
        LastColor1 := Color;
      end;
    end;
end;

procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer;
  ShadowColor: TColor);
var
  BX, BY: integer;
  TransparentColor: TColor;
begin
  TransparentColor := B.Canvas.Pixels[0, B.Height - 1];
  for BY := 0 to B.Height - 1 do
    for BX := 0 to B.Width - 1 do
    begin
      if B.Canvas.Pixels[BX, BY] <> TransparentColor then
        ACanvas.Pixels[X + BX, Y + BY] := ShadowColor;

    end;
end;