StringGrid с картинками и текстом

@Сергей_93 · Регистрация: 26.05.2019

Студворк — интернет-сервис помощи студентам

Всем доброе время.
Сильно тапками не закидывайте, пишу потому что сам не смог разобраться.
Есть StringGrid, с динамическим количеством ячеек и их размерами (в коде, для примера 40). Данные берутся из бд, с параметрами название (например) "надпись" и ее состояние Х (варианты 1/2/3) и состояние Y (1/2).
В конечном итоге надо:
1-в каждой ячейке, в низу (с переносом текста) вывести название,
2-если состояние Y=1 то цвет шрифта серый,
3-если состояние Х=1 выбирается картинка 1, и с масштабированием распологается на всей ячейке (или на заднем фоне, или оставляя снизу место для надписи) 2,3 - соответственно изображения 2,3.

в спойлере код

Кликните здесь для просмотра всего текста

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
procedure TForm2.Button1Click(Sender: TObject);
var
ct, i ,j ,z :integer;
begin
  ct:=40;
SG.ColCount:=(ct div 4);
SG.RowCount:=4;
SG.DefaultColWidth:= (SG.Width - 14) div (ct div 4);
SG.DefaultRowHeight:= (SG.Height - 8) div 4 ;
  z:=1;
  for j := 0 to SG.RowCount -1 do
  for i := 0 to SG.ColCount -1  do
   begin
     // тут строка для примера, данные берутся из бд, переменной Z вообще нет
     SG.Cells[i,j]:='надпись '+IntToStr(z);
     inc(z);
   end;
SG.Refresh; // вызываю OnDrawCell
end;
 
procedure TForm2.SGDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
  State: TGridDrawState);
var
ct, i ,j ,z :integer;
   img : TImage;
   sgsend : TStringGrid;
begin
   sg := Sender as TStringGrid; 
      img := TImage.Create(nil);
      try
         img.Picture.LoadFromFile('0.ico');
         SG.Canvas.StretchDraw(Rect, img.Picture.Graphic);
         SG.Canvas.TextRect(Rect, Rect.Left, Rect.Bottom-16, 'надпись может быть длинной');
      finally
         img.Free;
      end;
end;

Можете указать на мои ошибки, как реализовать то? И кстати, изображение в каком формате лучше брать: ico bmp jpg ?

Добавлено через 8 минут
уточню: не ячейки грида пропорционально изображению, а изображение пропорционально ячейкам грида.

@AzAtom · 26.05.2019, 17:14

Сообщение от Сергей_93

img := TImage.Create(nil);

Не нужно каждый раз это делать. И TImage здесь не нужен. Можно один раз в OnCreate формы создать и загрузить TPicture и дальше просто его выводить.

@Сергей_93 · 26.05.2019, 17:41 **[ТС]**

Сообщение от AzAtom

TPicture и дальше просто его выводить

принял во внимание, а как с масштабированием быть?

@AzAtom · 26.05.2019, 17:49

Сообщение от Сергей_93

а как с масштабированием быть?

А что с ним не так? Повторил код, но с TBitmap, всё масштабируется.

Delphi
1
T8StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[ARow]);

Здесь t8bmapa это массив Bitmap'ов.

Пока вывод текста с переносом и центровкой внизу не получается штатными функциями, показать не могу.

@Сергей_93 · 26.05.2019, 17:57 **[ТС]**

AzAtom, не будет наглостью попросить весь код?

@AzAtom · 26.05.2019, 18:05

Вот, что получилось. Почему-то флаг DT_BOTTOM у меня не срабатывает. Если бы этот флаг нормально срабатывал, то можно было обойтись без всех строк с переменной i.
Код всего модуля:

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids;
 
type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
    t8bmapa: array[1..3] of TBitmap;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  t8bmapa[1] := TBitmap.Create;
  t8bmapa[1].Width  := 16;
  t8bmapa[1].Height := 16;
  t8bmapa[1].Canvas.Ellipse(0, 0, t8bmapa[1].Width -1, t8bmapa[1].Height-1);
 
  t8bmapa[2] := TBitmap.Create;
  t8bmapa[2].Width  := 16;
  t8bmapa[2].Height := 16;
  t8bmapa[2].Canvas.Ellipse(0, 0, t8bmapa[2].Width -1, (t8bmapa[2].Height div 2)-1);
 
  t8bmapa[3] := TBitmap.Create;
  t8bmapa[3].Width  := 16;
  t8bmapa[3].Height := 16;
  t8bmapa[3].Canvas.Ellipse(0, t8bmapa[3].Height div 2, t8bmapa[3].Width -1, t8bmapa[3].Height-1);
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
var
  i: integer;
begin
  for i := 1 to 3 do
    t8bmapa[i].Free;
end;
 
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  i: integer;
begin
  if (ACol = 1) and (ARow in [1..3]) then begin
    StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[ARow]);
    i := StringGrid1.Canvas.TextWidth('надпись может быть длинной');
    i := (i div (Rect.Right - Rect.Left) + 1) * StringGrid1.Canvas.TextHeight('надпись может быть длинной');
    if i <= (Rect.Bottom - Rect.Top) then
      Rect.Top := Rect.Bottom - i;
    DrawText(StringGrid1.Canvas.Handle, 'надпись может быть длинной', -1, Rect, DT_CENTER + DT_TOP + DT_WORDBREAK);
  end;
end;
 
end.

@Сергей_93 · 26.05.2019, 18:36 **[ТС]**

Сообщение от AzAtom

t8bmapa это массив Bitmap'ов.

~~Только не смейтесь....а как массив указать? (t8bmapa[ARow])~~ пардон, интернет не айс, пока загрузил - уже и сообщение есть

Добавлено через 29 минут

Сообщение от AzAtom

t8bmapa[3].Canvas.Ellipse(

если честно, не понял при чем тут элипс, у меня то явно 3 изображения, (лежащие рядом с экзешником).

Delphi
1
t8bmapa[1].LoadFromFile('1.bmp');

так решается, уже плюс! (на ico ругается почему то, не суть пусть будет bmp)
Перенос названия пока не получается.

@AzAtom · 26.05.2019, 18:54

Сообщение от Сергей_93

не понял при чем тут элипс,

Просто рисунок, не стал с диска загружать.

Сообщение от Сергей_93

Перенос названия пока не получается.

Странно. Вот переносится, код тот, что я приводил выше.

@Сергей_93 · 26.05.2019, 19:12 **[ТС]**

Сообщение от AzAtom

i := (i div (Rect.Right - Rect.Left) + 1)

изменил на +2(отступ снизу) - все заработало!

сейчас вернул на 1 - снова работает, что было - хз.
Остались вопросы:
а можно как то соотношение сторон отследить?
картинку в функции StretchDraw можно по высоте ячейки отследить (DefaultRowHeight) или просто полосу снизу добавить (что бы картинка не была за текстом). При изменении соотношений высоты/ширины сильно пропорции искажаются.

@AzAtom · 26.05.2019, 19:24

Вообще, эта штука i := (i div (Rect.Right - Rect.Left) + 1) может неправильно работать, она разбивает на строки только по длине строки в пикселях, а надо бы по словам разбивать и смотреть сколько строк выходит.

Сообщение от Сергей_93

а можно как то соотношение сторон отследить?

Конечно можно. Посчитать новую ширину по высоте ячейке, сравнить получившуюся ширину с шириной ячейки и если ячейка меньше, то пересчитать новую высоту по известной ширине ячейки.

Delphi
1
2
3
4
NewHeight := CellHeight;
NewWidth  := Round(CellHeight * ImageWidth / ImageHeight);
if NewWidth > CellWidth then
  NewHeight  := Round(CellWidth * ImageHeight / ImageWidth);

@Сергей_93 · 26.05.2019, 21:08 **[ТС]**

Сообщение от AzAtom

новую высоту по известной ширине ячейки.

извиняюсь- дым пошел

- пока цикл верну назад, и проверку условия, а там уже видно будет по соотношениям.

Добавлено через 1 час 19 минут

Сообщение от AzAtom

пересчитать новую высоту по известной ширине ячейки.

делаю вот так

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
              Rect.Height := StringGrid1.DefaultRowHeight;
              Rect.Width  := Round(StringGrid1.DefaultRowHeight);
              if Rect.Width > StringGrid1.DefaultColWidth then
                 Rect.Height  := Round(StringGrid1.DefaultColWidth * 356 / 356);
 
              if (z mod 2) = 0 then  StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[2])
              else if (z mod 3) = 0 then   StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[3])
              else    StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[1]);
 
              Rect.Height := StringGrid1.DefaultRowHeight; // заново указываю размеры для текста
              Rect.Width  := Round(StringGrid1.DefaultRowHeight);
              s:= 'надпись длиной до '+inttostr(z)+' символов';
              и тд

но соотношение вроде контролируется, но получается со смещением по горизонтали. Может при указании размера не надо использовать масштабирование (StretchDraw)?
картинка 356х356.

@AzAtom · 26.05.2019, 21:24

Если картинка всегда квадратная, то нет смысла считать. Просто сделать Rect одинаковой ширины и высоты, не превышающей ширину и высоту ячейки.

@Сергей_93 · 27.05.2019, 21:26 **[ТС]**

Сообщение от AzAtom

Если картинка всегда квадратная, то нет смысла считать

В моем случае есть, ведь соотношение ширины и высоты ячейки может меняться. Но это уже мелочи. На данный момент, все что вызывало вопрос решено. На случай если кто столкнется с таким же - вот готовый кусок кода.

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
procedure TForm2.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
var
  j,k,i,z: integer;
  s: string;
begin
 z:=1;
  for i := 0 to StringGrid1.RowCount -1 do
    for j := 0 to StringGrid1.ColCount -1  do
       begin
          if (ACol = j) and (ARow = i) then
            begin
            if StringGrid1.DefaultColWidth <= StringGrid1.DefaultRowHeight then
              begin
              Rect.Height  := Round(StringGrid1.DefaultColWidth);
              Rect.Width :=  Rect.Height ;
              end
            else  if StringGrid1.DefaultColWidth > StringGrid1.DefaultRowHeight then
            begin  // изображение смещается влево ... но это не критично
              Rect.Width  := Round(StringGrid1.DefaultRowHeight -10);
              Rect.Height := Rect.Width ;
              end ;
 
              if (z mod 2) = 0 then  begin
              StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[2]) ;
              StringGrid1.Canvas.Font.Color:=clRed;
              end
              else if (z mod 3) = 0 then  begin
              StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[3]);
              StringGrid1.Canvas.Font.Color:=clBlue;
              end
              else StringGrid1.Canvas.Font.Color:=clBlack;
//                 StringGrid1.Canvas.StretchDraw(Rect, t8bmapa[1]);
 
              Rect.Height := Round(StringGrid1.DefaultRowHeight);
              Rect.Width  := Round(StringGrid1.DefaultColWidth);
 
              s:= 'надпись под '+inttostr(z)+' номером';
              k := StringGrid1.Canvas.TextWidth(s);
              k := (k div (Rect.Right - Rect.Left) + 1) * StringGrid1.Canvas.TextHeight(s)+1;
              if k <= (Rect.Bottom - Rect.Top) then  Rect.Top := Rect.Bottom - k;
              DrawText(StringGrid1.Canvas.Handle, s , -1, Rect, DT_CENTER + DT_TOP + DT_WORDBREAK);
 
            end;
          inc(z);
       end;
end;

Еще раз благодарю AzAtom ,

без Вашей помощи не справился бы.

Добавлено через 14 минут
Администратор, Михаил, отметьте пожалуйста тему как решенную, у меня пока нет прав даже сообщения писать

@D1973 · 28.05.2019, 05:15

Сообщение от Сергей_93

у меня пока нет прав даже сообщения писать

А не надо писать сообщения для того, чтобы отметить лучший ответ. Для этого в каждом топике кнопки есть!

Новые блоги и статьи Все статьи Все блоги /
SDL3 для Web (WebAssembly): Обработчик клика мыши в браузере ПК и касания экрана в браузере на мобильном устройстве 8Observer8 02.02.2026 Содержание блога Для начала пошагово создадим рабочий пример для подготовки к экспериментам в браузере ПК и в браузере мобильного устройства. Потом напишем обработчик клика мыши и обработчик. . .	Философия технологии iceja 01.02.2026 На мой взгляд у человека в технических проектах остается роль генерального директора. Все остальное нейронки делают уже лучше человека. Они не могут нести предпринимательские риски, не могут. . .	SDL3 для Web (WebAssembly): Вывод текста со шрифтом TTF с помощью SDL3_ttf 8Observer8 01.02.2026 Содержание блога В этой пошаговой инструкции создадим с нуля веб-приложение, которое выводит текст в окне браузера. Запустим на Android на локальном сервере. Загрузим Release на бесплатный. . .	SDL3 для Web (WebAssembly): Сборка C/C++ проекта из консоли 8Observer8 30.01.2026 Содержание блога Если вы откроете примеры для начинающих на официальном репозитории SDL3 в папке: examples, то вы увидите, что все примеры используют следующие четыре обязательные функции, а. . .
SDL3 для Web (WebAssembly): Установка Emscripten SDK (emsdk) и CMake для сборки C и C++ приложений в Wasm 8Observer8 30.01.2026 Содержание блога Для того чтобы скачать Emscripten SDK (emsdk) необходимо сначало скачать и уставить Git: Install for Windows. Следуйте стандартной процедуре установки Git через установщик. . . .	SDL3 для Android: Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 29.01.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами. Версия v3 была полностью переписана на Си, в. . .	Инструменты COM: Сохранение данный из VARIANT в файл и загрузка из файла в VARIANT bedvit 28.01.2026 Сохранение базовых типов COM и массивов (одномерных или двухмерных) любой вложенности (деревья) в файл, с возможностью выбора алгоритмов сжатия и шифрования. Часть библиотеки BedvitCOM Использованы. . .	SDL3 для Android: Загрузка PNG с альфа-каналом с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 28.01.2026 Содержание блога SDL3 имеет собственные средства для загрузки и отображения PNG-файлов с альфа-каналом и базовой работы с ними. В этой инструкции используется функция SDL_LoadPNG(), которая. . .

@Сергей_93 0 / 0 / 0 Регистрация: 26.05.2019 Сообщений: 15
	26.05.2019, 17:57 [ТС]
	AzAtom, не будет наглостью попросить весь код? 0

@AzAtom Модератор 4138 / 2351 / 809 Регистрация: 15.11.2015 Сообщений: 9,396
	26.05.2019, 21:24
	Если картинка всегда квадратная, то нет смысла считать. Просто сделать Rect одинаковой ширины и высоты, не превышающей ширину и высоту ячейки. 1

StringGrid с картинками и текстом

Решение