speedbar.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

  Result := FButton.Action;
end;

procedure TSpeedItem.SetAction(Value: TBasicAction);
begin
  FButton.Action := Value;
end;
{$ENDIF}

procedure TSpeedItem.ButtonClick;
begin
  FButton.ButtonClick;
end;

function TSpeedItem.CheckBtnMenuDropDown: Boolean;
begin
  Result := FButton.CheckBtnMenuDropDown;
end;

procedure TSpeedItem.Click;
begin
  FButton.Click;
end;

function TSpeedItem.GetTag: Longint;
begin
  Result := inherited Tag;
end;

procedure TSpeedItem.SetTag(Value: Longint);
begin
  inherited Tag := Value;
  FButton.Tag := Value;
end;

function TSpeedItem.GetDropDownMenu: TPopupMenu;
begin
  Result := FButton.DropDownMenu;
end;

procedure TSpeedItem.SetDropDownMenu(Value: TPopupMenu);
begin
  FButton.DropDownMenu := Value;
end;

function TSpeedItem.GetMarkDropDown: Boolean;
begin
  Result := FButton.MarkDropDown;
end;

procedure TSpeedItem.SetMarkDropDown(Value: Boolean);
begin
  FButton.MarkDropDown := Value;
end;

function TSpeedItem.GetWordWrap: Boolean;
begin
  Result := FButton.WordWrap;
end;

procedure TSpeedItem.SetWordWrap(Value: Boolean);
begin
  FButton.WordWrap := Value;
end;

function TSpeedItem.GetLeft: Integer;
begin
  Result := FButton.Left;
end;

function TSpeedItem.GetTop: Integer;
begin
  Result := FButton.Top;
end;

procedure TSpeedItem.SetLeft(Value: Integer);
begin
  FButton.Left := Value;
end;

procedure TSpeedItem.SetTop(Value: Integer);
begin
  FButton.Top := Value;
end;

{ TSpeedBar }

const
  InternalVer = 1;

constructor TSpeedBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSections := TList.Create;
  FButtonSize := DefaultButtonSize;
  FButtonStyle := bsNew;
  FWallpaper := TPicture.Create;
  FWallpaper.OnChange := WallpaperChanged;
  FIniLink := TIniLink.Create;
  FIniLink.OnSave := IniSave;
  FIniLink.OnLoad := IniLoad;
  FOffset.X := MinButtonsOffset;
  FOffset.Y := FOffset.X;
  Height := 2 * FOffset.Y + DefaultButtonSize.Y;
  FRowCount := 1;
  FEditWin := 0;
  FOptions := [sbAllowDrag, sbGrayedBtns];
  ControlStyle := ControlStyle - [csSetCaption
    {$IFDEF WIN32}, csReplicatable {$ENDIF}];
  ParentShowHint := False;
  ShowHint := True;
  SetFontDefault;
  inherited Align := alTop;
  FAlign := alTop;
  UpdateGridSize;
{$IFDEF WIN32}
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
{$ENDIF}
  if not Registered then begin
    RegisterClasses([TSpeedItem, TSpeedbarSection, TSpeedbarButton]);
    Registered := True;
  end;
end;

destructor TSpeedBar.Destroy;
begin
  FOnVisibleChanged := nil;
  FOnApplyAlign := nil;
  FOnPosChanged := nil;
  FIniLink.Free;
  FWallpaper.OnChange := nil;
  FWallpaper.Free;
  FWallpaper := nil;
  if FEditWin <> 0 then begin
    SendMessage(FEditWin, CM_SPEEDBARCHANGED, SBR_DESTROYED, Longint(Self));
    FEditWin := 0;
  end;
  ClearSections;
  FSections.Free;
{$IFDEF WIN32}
  FImageChangeLink.Free;
{$ENDIF}
  inherited Destroy;
end;

procedure TSpeedBar.Loaded;
begin
  inherited Loaded;
  if (FReserved = 0) and FFix then begin { fix previous version error }
    inherited Align := alTop;
    FAlign := alTop;
  end;
  UpdateGridSize;
  ForEachItem(SetItemButtonSize, 0);
end;

procedure TSpeedBar.ReadData(Reader: TReader);
begin
  FReserved := Reader.ReadInteger;
end;

procedure TSpeedBar.WriteData(Writer: TWriter);
begin
  Writer.WriteInteger(InternalVer);
end;

procedure TSpeedBar.ReadAllowDrag(Reader: TReader);
begin
  if Reader.ReadBoolean then Options := Options + [sbAllowDrag]
  else Options := Options - [sbAllowDrag];
end;

procedure TSpeedBar.ReadDesignStyle(Reader: TReader);
begin
  FDesignStyle := Reader.ReadBoolean;
end;

procedure TSpeedBar.WriteDesignStyle(Writer: TWriter);
begin
  Writer.WriteBoolean(NewStyleControls);
end;

procedure TSpeedBar.ReadSections(Reader: TReader);
var
{$IFDEF WIN32}
  TmpList: TStrings;
  I: Integer;
{$ELSE}
  S: string;
{$ENDIF}
begin
{$IFDEF WIN32}
  TmpList := TStringList.Create;
  try
    Reader.ReadListBegin;
    while not Reader.EndOfList do
      TmpList.AddObject(Reader.ReadString, nil);
    Reader.ReadListEnd;
    if (Reader.Ancestor = nil) or (TmpList.Count > 0) then begin
      for I := 0 to TmpList.Count - 1 do begin
        if SearchSection(TmpList[I]) < 0 then AddSection(TmpList[I]);
      end;
    end;
  finally
    TmpList.Free;
  end;
{$ELSE}
  Reader.ReadListBegin;
  FSections.Clear;
  while not Reader.EndOfList do begin
    S := Reader.ReadString;
    if SearchSection(S) < 0 then AddSection(S);
  end;
  Reader.ReadListEnd;
{$ENDIF}
end;

procedure TSpeedBar.WriteSections(Writer: TWriter);
var
  I: Integer;
begin
  Writer.WriteListBegin;
  for I := 0 to FSections.Count - 1 do
    Writer.WriteString(Sections[I].Caption);
  Writer.WriteListEnd;
end;

procedure TSpeedBar.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('Sections', ReadSections, WriteSections, False);
  Filer.DefineProperty('NewStyle', ReadDesignStyle, WriteDesignStyle, False);
  Filer.DefineProperty('InternalVer', ReadData, WriteData,
    {$IFDEF WIN32} Filer.Ancestor = nil {$ELSE} True {$ENDIF});
  { AllowDrag reading for backward compatibility only }
  Filer.DefineProperty('AllowDrag', ReadAllowDrag, nil, False);
end;

function TSpeedBar.GetSection(Index: Integer): TSpeedbarSection;
begin
  Result := TSpeedbarSection(FSections[Index]);
end;

function TSpeedBar.GetSectionCount: Integer;
begin
  Result := FSections.Count;
end;

procedure TSpeedBar.ForEachItem(Proc: TForEachItem; Data: Longint);
var
  I, Idx: Integer;
  Sect: TSpeedbarSection;
begin
  for I := 0 to FSections.Count - 1 do
    if FSections[I] <> nil then begin
      Sect := TSpeedbarSection(FSections[I]);
      for Idx := 0 to Sect.Count - 1 do begin
        if (Sect[Idx] <> nil) and Assigned(Proc) then
          Proc(TSpeedItem(Sect[Idx]), Data);
      end;
    end;
end;

function TSpeedBar.MinButtonsOffset: Integer;
begin
  Result := BorderWidth + 2 * Ord(not (sbFlatBtns in Options));
  if BevelOuter <> bvNone then Inc(Result, BevelWidth);
  if BevelInner <> bvNone then Inc(Result, BevelWidth);
end;

procedure TSpeedBar.SetItemVisible(Item: TSpeedItem; Data: Longint);
var
  ItemVisible: Boolean;
begin
  ItemVisible := Item.Visible and Self.Visible;
  Item.FButton.Visible := ItemVisible;
  if (Item.FButton.Parent <> Self) and ItemVisible then
    Item.FButton.Parent := Self;
end;

procedure TSpeedBar.SetItemEnabled(Item: TSpeedItem; Data: Longint);
begin
  Item.FButton.Enabled := Item.Enabled and Self.Enabled;
end;

procedure TSpeedBar.SetItemButtonSize(Item: TSpeedItem; Data: Longint);
begin
  ApplyItemSize(Item, Data);
  Item.Visible := Item.Visible; { update visible and parent after loading }
end;

procedure TSpeedBar.SwapItemBounds(Item: TSpeedItem; Data: Longint);
begin
  Item.FButton.SetBounds(Item.Top, Item.Left, FButtonSize.X, FButtonSize.Y);
end;

procedure TSpeedBar.SetFontDefault;
{$IFDEF WIN32}
var
  NCMetrics: TNonClientMetrics;
{$ENDIF}
begin
  ParentFont := False;
  with Font do begin
{$IFDEF WIN32}
    NCMetrics.cbSize := SizeOf(TNonClientMetrics);
    if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCMetrics, 0) then
    begin
      Handle := CreateFontIndirect(NCMetrics.lfMenuFont);
  {$IFNDEF VER90}
      Charset := DEFAULT_CHARSET;
  {$ENDIF}
    end
    else begin
{$ENDIF}
      Name := 'MS Sans Serif';
      Size := 8;
      Style := [];
      Color := clBtnText;
{$IFDEF WIN32}
    end;
{$ENDIF}
  end;
end;

procedure TSpeedBar.CMVisibleChanged(var Message: TMessage);
begin
  inherited;
  if not (csLoading in ComponentState) then ForEachItem(SetItemVisible, 0);
  if Assigned(FOnVisibleChanged) then FOnVisibleChanged(Self);
end;

procedure TSpeedBar.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  if not ((csLoading in ComponentState) or (csDesigning in ComponentState)) then
    ForEachItem(SetItemEnabled, 0);
end;

procedure TSpeedBar.WallpaperChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TSpeedBar.SetWallpaper(Value: TPicture);
begin
  FWallpaper.Assign(Value);
end;

procedure TSpeedBar.ClearSections;
begin
  while FSections.Count > 0 do RemoveSection(FSections.Count - 1);
  FSections.Clear;
end;

function TSpeedBar.Items(Section, Index: Integer): TSpeedItem;
var
  List: TSpeedbarSection;
begin
  Result := nil;
  if (Section >= 0) and (Section < FSections.Count) then begin
    List := Sections[Section];
    if List <> nil then
      if (Index >= 0) and (Index < List.Count) then
        Result := List[Index];
  end;
end;

function TSpeedBar.ItemsCount(Section: Integer): Integer;
begin
  Result := 0;
  if (Section >= 0) and (Section < FSections.Count) then begin
    if FSections[Section] <> nil then
      Result := Sections[Section].Count;
  end;
end;

procedure TSpeedBar.RemoveSection(Section: Integer);
var
  Sect: TSpeedbarSection;
  Item: TSpeedItem;
begin
  Sect := Sections[Section];
  if Sect <> nil then begin
    while Sect.Count > 0 do begin
      Item := Sect[0];
      Item.Free;
    end;
    Sect.FParent := nil;
    Sect.Free;
    FSections[Section] := nil;
  end;
  FSections.Delete(Section);
end;

procedure TSpeedBar.DeleteSection(Section: Integer);
var
  Sect: TSpeedbarSection;
  I: Integer;
begin
  Sect := Sections[Section];
  if Sect <> nil then begin
    for I := 0 to Sect.Count - 1 do RemoveItem(TSpeedItem(Sect[I]));
    Sect.FParent := nil;
    FSections[Section] := nil;
  end;
  FSections.Delete(Section);
end;

procedure TSpeedBar.RemoveItem(Item: TSpeedItem);
var
  I, Index: Integer;
begin
  if FindItem(Item, I, Index) then begin
    Item.FButton.Parent := nil;
    Item.FParent := nil;
    Item.FSection := -1;
    Sections[I].FList.Delete(Index);
  end;
end;

function TSpeedBar.SearchSection(const ACaption: string): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to FSections.Count - 1 do
    if Sections[I].Caption = ACaption then begin
      Result := I;
      Exit;
    end;
end;

function TSpeedBar.AppendSection(Value: TSpeedbarSection): Integer;
var
  UniqueName: string;
  I: Integer;
begin
  I := 0;
  UniqueName := Value.Caption;
  while SearchSection(UniqueName) >= 0 do begin
    Inc(I);
    UniqueName := Value.Caption + Format(' (%d)', [I]);
  end;