Забытая мелодия

Пролистывая книгу “Визуальное программирование“, я обратил внимание на главу “Аккордеон”, которая до сих пор не была опубликована в этом блоге. Речь в ней идет о создании вертикального меню, которое создается скриптом из данных, хранящихся в БД, имеет причудливую систему окраски и отображение горячих клавиш.

Сегодня я представляю новую версию “аккордеона”, более простую и универсальную. В его основе лежат использованные ранее, но улучшенные алгоритмы программного построения табличных данных. Сами данные берутся из главного меню приложения, что упрощает создание самого меню.

Создание меню

Для того, чтобы обозначить место на форме, где будет меню, необходимо разместить там панель и передать её в качестве аргумента в процедуру VMenu_Create(). Внешний вид меню будет соответствовать выбранному стилю оформления приложения. Именно это требование заставило меня попотеть, так как в My Visual Database не хватает некоторых библиотечных функций для работы с графикой, которые могли бы значительно упростить задачу “раскрашивания” аккордеона, которая решается функцией GetColorTone(). Эта функция создает оттенки цвета по заданному в качестве аргумента. Но работает она только с RGB кодировкой цвета, тогда как тип TColor подразумевает наличие цветов, задаваемых через систему настройки интерфейса Windows. А так как в MVDB нет функции ColorToRGB(), пришлось изобретать велосипед, костыли (нужное подчеркнуть) – функцию ColorToInt().

Технология создания грида подробно описана в статье “Формы из пробирки“, отмечу лишь, что в данном случае создаются три колонки:

• название пункта меню
• уровень вложенности
• индикатор сворачивания / разворачивания

Уровень вложенности – это скрытая служебная колонка, на основе которой работает механизм аккордеона, скрывающий и раскрывающий нужные строки.

Индикатор сворачивания использует UTF-символы, которые можно настроить через константы.

const
  // колонки вертикального меню
  VM_COL_CAPTION = 2; // название
  VM_COL_LEVEL = 1; // скрытая колонка с уровнем
  VM_COL_EXPAND = 0; // колонка с индикатором раскрытия/скрытия вложенных элементов
  //
  VM_COL_EXP_WIDTH = 20; // ширина колонки индикатора
  VM_SPLITTER_HEIGHT = 1; // высота разделителя
  // символы для индикатора
  VM_EXPAND_SIGN = 9654; // символ разворачивания - кодировка UTF-8
  VM_COLLAPSE_SIGN = 9660; // символ сворачивания

procedure VMenu_Create(APanel:TdbPanel);
// создание вертикального меню на основе грида
// на основе дерева было бы проще, но нет возможности избавиться от маленьких квадратиков-индикаторов раскрытия
var
  tmpMenuGrid : TdbStringGridEx;

  procedure AddItemOnTree( AItem:TMenuItem; ARow: integer; ALevel:Integer);
  // рекурсивная процедура добавления дочерних контролов
  var
    j: integer;
    k: integer;
    tmpSubRow: integer;
    tmpItem: TMenuItem;
    tmpColor: TColor;
  begin
    for j:=0 to  AItem.Count - 1 do
    begin
      tmpItem := AItem.items[j];
      if tmpItem.Visible then // добавляем только видимые пункт меню
      begin
        tmpMenuGrid.AddRow;
        tmpSubRow := tmpMenuGrid.LastAddedRow;
        tmpMenuGrid.Row[tmpSubRow].ID := ObjectToInt(tmpItem); // храним пункт меню в поле ID
        if tmpItem.Caption = '-' then
        begin
          tmpMenuGrid.Row[tmpSubRow].RowHeight := VM_SPLITTER_HEIGHT;
          tmpColor := GetColorTone( ColorToInt(tmpMenuGrid.Columns[VM_COL_CAPTION].Color), ALevel-1 );
        end
        else
        begin
          tmpMenuGrid.Cells[VM_COL_CAPTION,tmpSubRow ] :=  '  '+RepStr('   ',ALevel)+tmpItem.Caption;
          tmpColor := GetColorTone( ColorToInt(tmpMenuGrid.Columns[VM_COL_CAPTION].Color), ALevel );
        end;
        tmpMenuGrid.Cells[VM_COL_LEVEL,tmpSubRow ] := IntToStr( ALevel );
        if tmpItem.Count > 0 then
          tmpMenuGrid.Cells[VM_COL_EXPAND,tmpSubRow ] := Chr(VM_COLLAPSE_SIGN);
        // закрашиваем строку

        for k:= 0 to tmpMenuGrid.Columns.Count - 1 do
          tmpMenuGrid.Cell[k,tmpSubRow].Color := tmpColor;
        // если у контрола есть дочерние, то загрузить их тоже
        if tmpItem.Count > 0 then
          AddItemOnTree(tmpItem, tmpSubRow, ALevel+1 );
      end;
    end;
  end;

begin
  // создать грид для меню
  tmpMenuGrid := TdbStringGridEx.Create( APanel.Owner );
  with tmpMenuGrid do
  begin
    Parent := APanel;
    Align := alClient;
    Options := goSelectFullRow + goDisableKeys; // выделение строки, отключение клавиатуры - стрелками "вправо", "влево" можно испортить картинку
    AppearanceOptions := aoAlphaBlendedSelection + aoBoldTextSelection; // цветовое смешение и выделение жирным - удачное сочетание при использовании цветовых тем
    BorderStyle := bsNone; // убрать рамку вокруг таблицы
    // обработчики
    AssignEvents(tmpMenuGrid);
    dbOnClick := 'VMenu_OnClick';
    dbOnDoubleClick := 'VMenu_OnDoubleClick';
    OnKeyUp := 'VMenu_OnKeyUp';
    // размеры шрифтов и высота строк
    Font.Name := DTF_FONT_NAME;
    Font.Size := App_ScaleFontSize;
    RowSize := App_Scale(DTF_GRID_ROW_SIZE);
    // К сожалению, таблицы не совсем поддерживают стили, если их создавать программно
    // поэтому приходится копировать настройки цветов....
    EnableVisualStyles := True;
    //
    if DTF_PatternGrid <> nil then
    begin
      Color := DTF_PatternGrid.Color;
      Font.Color := DTF_PatternGrid.Font.Color;
      InactiveSelectionColor := DTF_PatternGrid.InactiveSelectionColor;
      HighlightedTextColor := DTF_PatternGrid.HighlightedTextColor;
      // GridLinesColor := $00CEDDD1;
      // SelectionColor := clBlack;
    end;
    ClearRows;
    Columns.Clear;
    try // по неизвестной до сих пор причине необходимо экранировать добавление колонок
      Columns.Add(TNxTextColumn);
    except
    end;
    try
      Columns.Add(TNxTextColumn);
    except
    end;
    try
      Columns.Add(TNxTextColumn);
    except
    end;
    // настраиваем колонки
    Columns[VM_COL_CAPTION].Color := Color;
    Columns[VM_COL_LEVEL].Color := Color;
    Columns[VM_COL_EXPAND].Color := Color;
    AddItemOnTree( frmMain.Menu.Items, 0, 0 ); // заполняем таблицу данными
    VMenu_CollapseTree(tmpMenuGrid); // сворачиваем
    //  Columns[VM_COL_LEVEL].width := 0;
    Columns[VM_COL_LEVEL].Visible := False;
    Columns[VM_COL_EXPAND].width := VM_COL_EXP_WIDTH;
    Columns[VM_COL_CAPTION].width := ClientWidth -  Columns[VM_COL_EXPAND].width ;
  end;
end;
Code language: Delphi (delphi)

Управление

Меню управляется мышкой и клавиатурой: работает вертикальная навигация, при двойном клике или нажатии клавиши “Enter” пункт меню выполняется или разворачиваются подпункты. Для этого используются три обработчика: VMenu_OnKeyUp(), VMenu_OnClick() и VMenu_OnDoubleClick(). В последнем используется ссылка на пункт меню для его выполнения.

procedure VMenu_OnKeyUp (Sender: TObject; var Key: Word; Shift, Alt, Ctrl: boolean);
// нажатие клавиш
var
  tmpGrid:TdbStringGridEx;
  i: integer;
begin
  tmpGrid := TdbStringGridEx(Sender);
  if (Key = 38) then // стрелка вверх
  begin
    for i := tmpGrid.SelectedRow - 1 downto 0 do
    begin
      if tmpGrid.RowVisible[i] and (tmpGrid.Cells[VM_COL_CAPTION,i]<>'') then
      begin
        tmpGrid.SelectedRow := i;
        break;
      end;
    end;
  end;
  if (Key = 40) then // стрелка вниз
  begin
    for i := tmpGrid.SelectedRow + 1 to tmpGrid.RowCount - 1 do
    begin
      if tmpGrid.RowVisible[i]  and (tmpGrid.Cells[VM_COL_CAPTION,i]<>'') then
      begin
        tmpGrid.SelectedRow := i;
        break;
      end;
    end;
  end;
  if Key = 13 then // Enter
    VMenu_OnDoubleClick( Sender );
end;

procedure VMenu_OnClick( Sender:TObject );
// клик мышкой - навигация
var
  tmpGrid:TdbStringGridEx;
begin
  tmpGrid := TdbStringGridEx(Sender);
  if tmpGrid.SelectedRow >= 0 then
  begin
    VMenu_ExpandNode( tmpGrid, tmpGrid.SelectedRow);
  end;
end;

procedure VMenu_OnDoubleClick (Sender: TObject);
// двойной клик мышкой - выполнить
var
  tmpGrid:TdbStringGridEx;
  tmpItem:TMenuItem;
begin
  tmpGrid := TdbStringGridEx(Sender);
  if tmpGrid.SelectedRow >= 0 then
  begin
    VMenu_OnClick( Sender );
    tmpItem := TMenuItem( tmpGrid.Row[tmpGrid.SelectedRow].ID );
    if tmpItem <> nil then
      tmpItem.Click;
  end;
end;Code language: Delphi (delphi)

Разворачивание и сворачивание

Ещё две процедуры служат для визуализации эффектов сворачивания и разворачивания меню. Они используют свойство RowVisible для управления видимостью строк таблицы, а также сведения, хранящиеся в колонке VM_COL_LEVEL.

procedure VMenu_CollapseTree(AMenuGrid:TdbStringGridEx;);
// свернуть меню
var
  j: integer;
begin
  // оставляем только верхний уровень
  for j:=0 to AMenuGrid.RowCount - 1 do
  begin
    AMenuGrid.RowVisible[j] := AMenuGrid.Cells[VM_COL_LEVEL,j] = '0';
    if AMenuGrid.Cells[VM_COL_EXPAND,j] <> '' then
      AMenuGrid.Cells[VM_COL_EXPAND,j] := Chr(VM_EXPAND_SIGN);
  end;
end;

procedure VMenu_ExpandNode( AMenuGrid:TdbStringGridEx; ARow:integer);
// раскрыть узел дерева меню
var
  tmpLevel: integer;

  procedure ExpandLevel(ASubRow: integer; ALevel: integer);
  // рекурсивная процедура разворачивания уровня
  var
    i: integer;
  begin
    AMenuGrid.RowVisible[ASubRow] := true;
    if AMenuGrid.Cells[VM_COL_EXPAND,ASubRow] = Chr(VM_EXPAND_SIGN) then
      AMenuGrid.Cells[VM_COL_EXPAND,ASubRow] := Chr(VM_COLLAPSE_SIGN);

    i := ASubRow + 1;
    while (i < AMenuGrid.RowCount) do
    begin
      if StrToInt(AMenuGrid.Cells[VM_COL_LEVEL,i]) = ALevel+1 then
      begin
        AMenuGrid.RowVisible[i] := true;
      end
      else
      begin
        if StrToInt(AMenuGrid.Cells[VM_COL_LEVEL,i]) <= ALevel then
        begin
          break;
        end;
      end;
      i := i+1;
    end;
    //
    if ALevel > 0 then
    begin
      // найти родительский узел
      i := ASubRow - 1;
      while StrToInt(AMenuGrid.Cells[VM_COL_LEVEL,i]) >= ALevel do
        i := i - 1;
      // раскрыть его
      ExpandLevel(i, ALevel - 1);
    end;
  end;

begin
  AMenuGrid.BeginUpdate; // остановить автопрорисовку
  tmpLevel := StrToInt( AMenuGrid.Cells[VM_COL_LEVEL,ARow] );
  VMenu_CollapseTree(AMenuGrid); // свернуть все
  ExpandLevel(ARow, tmpLevel);   // разворачиваем нужный элемент
  // коррекция ширины колонок - из-за возможности появления вертикальной полосы прокрутки
  AMenuGrid.Columns[VM_COL_CAPTION].width := AMenuGrid.ClientWidth -  AMenuGrid.Columns[VM_COL_EXPAND].width; //
  AMenuGrid.EndUpdate;// включить автопрорисовку
end;Code language: JavaScript (javascript)

Дополнительные процедуры и функции

Для формирования отступов в меню добавлена функция RepStr(), которая возвращает повторяющуюся нужно число раз строку.

function RepStr(AData:string; ACount:integer):string;
// возвращает повторяющуюся последовательность строки
var
  i: integer;
begin
  Result := '';
  for i := 1 to ACount do
    Result := Result + AData;
end;Code language: Delphi (delphi)

Аналог System.UITypes.TColors.ColorToRGB получился на уровне костыля, так как для своей работы он использует видимую форму, на которой размещается панелька размером 1х1 пиксель. В данном случае использована форма заставки.

Можно отказаться от использования ColorToInt() при условии, что цвет фона меню будет задан как число. Кстати, при использовании стилей происходит подмена цвета числовым значением, поэтому меню будет отображаться корректно.

function ColorToInt( AColor: TColor ):integer;
// получение 4-х байтового цвета, аналог System.UITypes.TColors.ColorToRGB из Delphi
// функция находится в библиотеке Units, но зависит от проекта, а именно от формы, которая должна быть видимой на момент вызовать функции.
var
  tmpPan:TdbPanel;
  tmpForm: TForm;
begin
  // форма должна быть видимой в момент вызова функции
  tmpForm:=GetFormByName('frmSplash'); 
  // добавим на форму малюченькую панель размером 1х1 пиксель
  Findc(tmpForm,'panColorToInt',tmpPan,False);
  if tmpPan = nil then
  begin
    tmpPan := TdbPanel.Create(tmpForm);
    tmpPan.BevelWidth := 0;
    tmpPan.Width := 1;
    tmpPan.Height := 1;
    tmpPan.Parent := tmpForm;
  end;
  // записываем цвет как это принято в Windows: включая индексы вроде clWindow, clBtnFace
  tmpPan.Canvas.Pixels[0,0] := AColor;
  // читаем цвет как 4-байтовое целое.
  Result := tmpPan.Canvas.Pixels[0,0];
end;Code language: Delphi (delphi)

IntToRGB() – преобразование целого в компоненты цвета. Эта маленькая процедура вам ещё может пригодиться в других проектах.

procedure IntToRGB( AColor:Integer; var R:Byte; var G:Byte; var B:byte );
// преобразование целого в компоненты цвета без учета прозрачности
begin
  R := AColor AND $FF;
  G := (AColor AND $FF00) shr 8;
  B := (AColor AND $FF0000) shr 16;
end;Code language: Delphi (delphi)

Функцию получения полутонов GetColorTone() я постарался сделать универсальной: у неё есть два необязательных параметра, которые влияют на контрастность полутонов и уровень выбора алгоритма высветления или затемнения. Алгоритм простой, поэтому в нем нет цветокомпенсации и проверки на превышение MaxTone: он линейно рассчитывает оттенок, который темнее (для изначально светлого) или светлее (для изначально тёмного) исходного цвета.

function GetColorTone( AColor:Integer; ATone:integer; AMaxTone:integer = 7; AMediana:integer = 127 ):TColor;
// получение цветовых полутонов
// AColor - начальный цвет
// ATone - требуемый тон, начиная с 0
// AMaxTone - сколько всего полутонов
// AMediana - уровеннь определения направления: осветление/затемнение
var
  R:Byte; G:Byte; B:byte;
begin
  IntToRGB(AColor,R,G,B);
  if ((R+G+B) / 3) < AMediana then
  begin // осветляем
    R := R + trunc( (255-R)/AMaxTone*ATone );
    G := G + trunc( (255-G)/AMaxTone*ATone );
    B := B + trunc( (255-B)/AMaxTone*ATone );
  end
  else
  begin // затемняем
    R := R - trunc( R/AMaxTone*ATone );
    G := G - trunc( G/AMaxTone*ATone );
    B := B - trunc( B/AMaxTone*ATone );
  end;
  Result := RGB(R,G,B);
end;Code language: PHP (php)

Итоги

Аккордеон получился, но играет он грустную мелодию – я в очередной раз уткнулся в “ограничение мира” My Visual Database, что даже на некоторое время повергло меня в уныние.

И все чаще я поглядываю на новые для меня неизведанные тропинки…