Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Как узнать размер текста в произвольном контроле [D7]


Страницы:   1 2

MsGuns ©   (2008-09-20 19:53:00) 

Это может быть, например, ячейка сетки и шрифт может быть разным в разных ячейках (код в соотв.обработчике).

Узнать надо не внутри OnDrawxxx, а "извне", скажем по кнопке.

Спасибо за ответы

  (2008-12-08 23:15:00) [1]

Удалено модератором

{RASkov}   (2008-09-22 16:23:00) [2]

Ну если что, чем смогу - помогу

MsGuns   (2008-09-22 16:06:00) [3]

Блин, Саша, если б у меня только эта проблема была :(

{RASkov}   (2008-09-22 15:46:00) [4]

> [22] MsGuns ©   (22.09.08 15:39)
> с сеткой тоже вроде нормально, только вот тормозит

Неужели ничего нельзя придумать?)

MsGuns   (2008-09-22 15:39:00) [5]

С простыми контролами все работает превосходно, с сеткой тоже вроде нормально, только вот тормозит :(
Большое спасибо всем !

Бурундук   (2008-09-22 13:21:00) [6]

Можно попробовать соединить мой метод с методом guav'a

procedure TForm1.Button1Click(Sender: TObject);
var sz: TSize;
  mf: TMetafile;
  i, j: Integer;
  oldHeight, testHeight: Integer;
  r: TRect;
begin
 oldHeight := SGrid.Height;

 testHeight := 0;
 for i := 0 to SGrid.RowCount-1 do
   testHeight := testHeight + SGrid.RowHeights[j] + 1;

 // Грид должен нарисоваться в метафайл полностью, без скроллинга.
 // Тогда для всех ячеек будет вызван OnDrawCell
 // а в нём - вычислен размер текста

 SGrid.Height := testHeight;
 try
   mf := DrawToMf(SGrid);
   mf.Free;

   for i := 0 to SGrid.ColCount-1 do
     SGrid.ColWidths[i] := TextSizeInfo(SGrid).GetMaxTextWidth(i) + 2;
 finally
   SGrid.Height := oldHeight;
 end;
end;

{RASkov}   (2008-09-21 20:14:00) [7]

> [18] guav ©   (21.09.08 19:47)
> если каждая ячейка своим шрифтом

Хм... точно) Я что-то не подумал об этом...
Я пример[16] попробывал с одним шрифтом, поэтому и....
Хех... эти метафайлы, а ведь интересная реализация... т.е. PaintTo в метафайл запишет всю информацию и шрифт включительно... Нужно будет "поюзать" примерчик с метафайлами :)

{RASkov}   (2008-09-21 20:09:00) [8]

Вот еще пример(на основе [15]):
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls, ExtCtrls;

const SET_WIDTH = WM_USER + 401;

type
 TForm1 = class(TForm)
   Panel1: TPanel;
   Edit1: TEdit;
   Button1: TButton;
   procedure Edit1Change(Sender: TObject);
   procedure Button1Click(Sender: TObject);
 private { Private declarations }
   procedure SetWidth(var Mes: TMessage); message SET_WIDTH;
 public  { Public declarations }
 end;

var Form1: TForm1;

implementation
{$R *.dfm}

{ TForm1 }
type TMyCtrl = class(TControl);
procedure TForm1.SetWidth(var Mes: TMessage);
var {Rc: TRect;} WX: Integer;
begin
if Mes.LParam<0 then Mes.LParam:=0;
with TControlCanvas.Create do try
 Control:=TControl(Mes.WParam);
 Font.Assign(TMyCtrl(Control).Font);
 //DrawText(Handle, PChar(Edit1.Text+CHR(Key)), -1, Rc, DT_CALCRECT);
 //if Rc.Right-Rc.Left<Mes.LParam then Edit1.Width:=Mes.LParam
  //else Edit1.Width:=Rc.Right-Rc.Left+GetSystemMetrics(SM_CXEDGE)*2+2;
 WX:=TextExtent(TMyCtrl(Control).Text).cx;
 if WX<Mes.LParam then Control.ClientWidth:=Mes.LParam
  else Control.ClientWidth:=WX+GetSystemMetrics(SM_CXEDGE)*2+2;
finally
 Free;
end;
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
 PostMessage(Handle, SET_WIDTH, Integer(Sender), -1);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Panel1.Caption:=Edit1.Text;
 PostMessage(Handle, SET_WIDTH, Integer(Panel1), 50);
 PostMessage(Handle, SET_WIDTH, Integer(Sender), 100);
end;

end.

guav   (2008-09-21 19:47:00) [9]

> [17] {RASkov} ©   (21.09.08 19:43)

Это просто пример что делать если каждая ячейка своим шрифтом

{RASkov}   (2008-09-21 19:43:00) [10]

> [16] guav ©   (21.09.08 18:56)

Мне кажется, что это немножко усложненный пример получения ширины текста...
Ведь "ядро" данного метода это всего лишь вот эта строка: ex := c.TextExtent(s);
ИМХО конечно...

guav   (2008-09-21 18:56:00) [11]

> [3] guav ©   (20.09.08 21:40)

function DrawToMf(control: TWinControl): TMetafile;
var canvas: TMetafileCanvas;
begin
 control.DoubleBuffered := False;
 Result := TMetafile.Create();
 try
   canvas := TMetafileCanvas.Create(Result, 0);
   try
     control.PaintTo(canvas, 0, 0);
   finally
     canvas.Free();
   end;
 except
   Result.Free();
   raise;
 end;
end;

function EnhMetaFileProc(
 hDC: HDC;
 lpHTable: PHANDLETABLE;
 lpEMFR: PENHMETARECORD;
 nObj: Integer;
 lpData: TStrings): Integer; stdcall;
var
 c: TCanvas;
 s: WideString;
 p: PEMRText;
 lpETOW: PEMRExtTextOut absolute lpEMFR;
 ex: TSize;
begin
 PlayEnhMetaFileRecord(hDC, lpHTable^, lpEMFR^, nObj);
 if (lpEMFR^.iType = EMR_EXTTEXTOUTW) then
 try
   c := TCanvas.Create();
   c.Handle := hDC;
   if (PEMRExtTextOut(lpEMFR)^.emrtext.nChars > 0) then
   begin
     p := @(PEMRExtTextOut(lpEMFR)^.emrtext);
     SetString(
       s,
       PWideChar(PChar(lpEMFR) + p^.offString),
       p^.nChars);
     ex := c.TextExtent(s);
     lpData.Add(Format('Текст %s выведен шрифтом размера %d x %d',
      [AnsiString(s), ex.cx, ex.cy]));
   end;
 except;
   Result := 0;
   Exit;
 end;
 Result := 1;
end;

procedure EnumControlFonts(control: TWinControl);
var
 mf: TMetafile;
 b: TBitmap;
 r: TRect;
 sl: TStringList;
begin
 mf := DrawToMf(control);
 try
   b := TBitmap.Create();
   try
     b.Width := 1000;
     b.Height := 1000;
     SetRect(r, 0, 0, 1000, 1000);
     sl := TStringList.Create();
     try
       EnumEnhMetaFile(b.Canvas.Handle, mf.Handle, @EnhMetaFileProc, sl, r);
       ShowMessage(sl.Text);
     finally
       sl.Free();
     end;
   finally
     b.Free();
   end;
 finally
   mf.Free();
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 EnumControlFonts(StringGrid1);
end;

{RASkov}   (2008-09-21 17:34:00) [12]

> [14] MsGuns ©   (21.09.08 17:05)
> Саш, если не затруднит, изобрази код, который подгоняет
> ширину эдита точно под текст при каждой его правке с клавиатуры

Может как-то так:
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var Rc: TRect;
begin
 with TControlCanvas.Create do try
  Control:=Edit1;
  Font.Assign(Edit1.Font);
  DrawText(Handle, PChar(Edit1.Text+CHR(Key)), -1, Rc, DT_CALCRECT);
  if Rc.Right-Rc.Left<30 then Edit1.Width:=30 else Edit1.Width:=Rc.Right-Rc.Left+4;
 finally
  Free;
 end;
end;

MsGuns   (2008-09-21 17:05:00) [13]

Саш, если не затруднит, изобрази код, который подгоняет ширину эдита точно под текст при каждой его правке с клавиатуры, пожалуйста ;)

У меня здесь делфа глючит (есть, но она глючит - комп домашний и давно нуждается в переустановке винды, да все ручки не доходят) - не могу попробовать

MsGuns   (2008-09-21 17:01:00) [14]

>Cnv:= TControlCanvas.Create;

Обана ! Это интересно - надо попробовать ;)

>GetTextExtentPoint32 ?

Таки да ;)

Спасибо, завтра поэкспериментирую. Способ, конечно, не учитывает "выпендресы" с перерисовкой "ручками", но мне это пока и не надо.

Но вот, блин, интересно, винда же при перерисовке "помнит" все нюансы рисования каждого фрагмента экрана. Как она, собабака, это делает ?
;))

{RASkov}   (2008-09-21 16:51:00) [15]

> procedure TForm1.Button3Click(Sender: TObject);

Там где эксперимент был с эдитами. В эдитах был одинаковый текст с одинаковым шрифтом, но в одном Style:=[] а в другом Style:=[fsItalic, fsBold];

{RASkov}   (2008-09-21 16:48:00) [16]

> [10] MsGuns ©   (21.09.08 15:09)

Не совсем понятно... Но может какнить так:
// Просто эксперименты :)
procedure TForm1.Button1Click(Sender: TObject);
var C, R, N: Integer; S: String;
begin
 for C:=1 to StringGrid1.ColCount-1 do
  for R:=1 to StringGrid1.RowCount-1 do begin
   S:='Bla-Bla';
   for N:=0 to 30 do if Random(5)=2 then S:=S+#32 else S:=S+CHR(Random(30)+48);
   StringGrid1.Cells[C, R]:=S;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var C, R, W: Integer; Cnv: TControlCanvas; Rc: TRect;
begin
 Cnv:=TControlCanvas.Create;
 Cnv.Control:=StringGrid1;
 Cnv.Font.Assign(StringGrid1.Font);
 try
 for C:=1 to StringGrid1.ColCount-1 do begin
  W:=0;
  for R:=1 to StringGrid1.RowCount-1 do begin
   DrawText(Cnv.Handle, PChar(StringGrid1.Cells[C, R]), -1, Rc, DT_CALCRECT);
   if W<Rc.Right-Rc.Left+4 then W:=Rc.Right-Rc.Left+4;
  end;
  StringGrid1.ColWidths[C]:=W;
 end;
 finally
  Cnv.Free;
 end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var W: Integer; Cnv: TControlCanvas; Rc: TRect;
begin
 Cnv:=TControlCanvas.Create;
 Cnv.Control:=Edit1;
 Cnv.Font.Assign(Edit1.Font);
 DrawText(Cnv.Handle, PChar(Edit1.Text), -1, Rc, DT_CALCRECT);
 ShowMessage(IntToStr(Rc.Right-Rc.Left));
 Cnv.Free;
 Cnv:=TControlCanvas.Create;
 Cnv.Control:=Edit2;
 Cnv.Font.Assign(Edit2.Font);
 DrawText(Cnv.Handle, PChar(Edit2.Text), -1, Rc, DT_CALCRECT);
 ShowMessage(IntToStr(Rc.Right-Rc.Left));
 Cnv.Free;
end;
...попробывать? Конечно, если используется OnDrawCell(или что-то в этом роде), то тут уже нормально никак не получится, наверное только как предложил Юра, но с учетом [7] Германн...

> помню только что последние 2 символа ее названия '32')

GetTextExtentPoint32 ?

MsGuns   (2008-09-21 15:09:00) [17]

>Дмитрий_С   (21.09.08 12:24) [8]
>ты покажи кодом как ты делал

Код на работе. Но там нечего показывать, т.к. я полностью собезъянничал с VCL (TCanvas.TextWidth), а HDC "взял" с помощью ф-ции GetWindowDC(Edit1.Handle). Повторяю, оно все как бы работает, только дает в результате
какую-то фигню.

>Бурундук   (21.09.08 12:46) [9]

Вы, вероятно, не совсем поняли что я хочу.
У меня не возникает никаких проблем в обработчиках перерисовки, но мне надо несколько иное. Поясню на примере
Есть датасет и грид, его отображающий. После открытия датасета я хочу вычислить ширину колонок грида так, чтобы они вмещали полностью тексты всех полей каждой колонки. Т.е. грид еще и не думал рисоваться или отрисовал первые надцать строк, а я уже хочу знать ширины всех его колонок.

Пример с гридом - частный случай, но ИМХО, достаточно избыточно рисует проблему.

Бурундук   (2008-09-21 12:46:00) [18]

А если размеры определять именно в OnDrawxxx, где они доступны,
и сохранять их? Для грида идея такая:
В обработчике OnDrawCell заменить DrawText на метод специального
объекта, который, помимо собственно рисования текста, будет
сохранять данные о его размере.

Принцип работы примерно такой:

unit main;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, Grids, StdCtrls;

type
 TForm1 = class(TForm)
   SGrid: TStringGrid;
   Button1: TButton;
   procedure SGridDrawCell(Sender: TObject; ACol, ARow: Integer;
     Rect: TRect; State: TGridDrawState);
   procedure FormCreate(Sender: TObject);
   procedure Button1Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

 TTextSizeInfo = class(TComponent)
 private
   FCellTextSizes: array of array of TSize;
   function GetSizes(ACol, ARow: Integer): TSize;
   procedure SetSizes(ACol, ARow: Integer; const Value: TSize);
 public
   function Grid: TStringGrid;

   property TextSizes[ACol, ARow: Integer]: TSize read GetSizes write SetSizes;
   function DrawText(ACol, ARow: Integer; AText: PChar; ATextLen: Integer; var ARect: TRect; AFormat: Cardinal): Integer;
 end;

var
 Form1: TForm1;

function TextSizeInfo(Grid: TStringGrid): TTextSizeInfo;

implementation

uses Types;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
 SGrid.Cells[0, 0] := '123';
end;

procedure TForm1.SGridDrawCell(Sender: TObject; ACol, ARow: Integer;
 Rect: TRect; State: TGridDrawState);
var Grd: TStringGrid;
   Fmt: Cardinal;
   S: string;
begin
 Fmt := DT_LEFT or DT_BOTTOM;
 Grd := (Sender as TStringGrid);
 with Grd.Canvas do
 begin
   S := Grd.Cells[ACol, ARow];
   FillRect(Rect);
   TextSizeInfo(Sender as TStringGrid).DrawText(ACol, ARow, PChar(S), Length(S), Rect, Fmt);
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var sz: TSize;
begin
 // Получение размеров текста в ячейке
 sz := TextSizeInfo(SGrid).GetSizes(0, 0);
 Caption := IntToStr(sz.cx);
end;

{--------------------------- TTextSizeInfo ------------------------------------}

function TextSizeInfo(Grid: TStringGrid): TTextSizeInfo;
var i: Integer;
begin
 for i := 0 to Grid.ComponentCount-1 do
   if Grid.Components[i] is TTextSizeInfo then
   begin
     Result := Grid.Components[i] as TTextSizeInfo;
     Exit;
   end;
 Result := TTextSizeInfo.Create(Grid);
end;

function TTextSizeInfo.DrawText(ACol, ARow: Integer; AText: PChar;
 ATextLen: Integer; var ARect: TRect; AFormat: Cardinal): Integer;
var sz: TSize;
begin
 Windows.DrawText(Grid.Canvas.Handle, AText, ATextLen, R, AFormat or DT_CALCRECT);

 sz.cx := ARect.Right - ARect.Left;
 sz.cx := ARect.Bottom - ARect.Top;
 TextSizes[ACol, ARow] := sz;

 Windows.DrawText(Grid.Canvas.Handle, AText, ATextLen, ARect, AFormat);
end;

function TTextSizeInfo.GetSizes(ACol, ARow: Integer): TSize;
begin
 Result.cx := 0;
 Result.cy := 0;

 if ( FCellTextSizes = nil                      )or
    ( Length(FCellTextSizes) < Grid.ColCount    )or
    ( Length(FCellTextSizes[0]) < Grid.RowCount )
  then
    SetLength(FCellTextSizes, Grid.ColCount, Grid.RowCount);

 if (ACol >= 0)and(ACol < Grid.ColCount)and
    (ARow >= 0)and(ARow < Grid.RowCount) then
   Result := FCellTextSizes[ACol, ARow];
end;

procedure TTextSizeInfo.SetSizes(ACol, ARow: Integer; const Value: TSize);
begin
 if ( FCellTextSizes = nil                      )or
    ( Length(FCellTextSizes) < Grid.ColCount    )or
    ( Length(FCellTextSizes[0]) < Grid.RowCount )
  then
    SetLength(FCellTextSizes, Grid.ColCount, Grid.RowCount);

 if (ACol >= 0)and(ACol < Grid.ColCount)and
    (ARow >= 0)and(ARow < Grid.RowCount) then
   FCellTextSizes[ACol, ARow] := Value;
end;

function TTextSizeInfo.Grid: TStringGrid;
begin
 Result := Owner as TStringGrid;
end;

end.

Дмитрий_С   (2008-09-21 12:24:00) [19]


> MsGuns ©   (21.09.08 02:08) [6]

ты покажи кодом как ты делал

Германн   (2008-09-21 02:20:00) [20]


> MsGuns ©   (21.09.08 02:08) [6]
>
> >Германн ©   (21.09.08 01:32) [5]
> >А если я там в "клиентской части" захочу нарисовать картинку?
>
>
> Дело в том, что пользователь при всем старании не сможет
> рисовать картинки - он может лишь вводить текст, изменяя
> его ширину и/или высоту (при многострочности) - вот их-то
> мне и надо бы как-то определять.
> Конечно, при программном изменении физических параметров
> текстов (фонта, стиля и т.д.) определить что там реально
> нарисовано можно, вероятно только так, как описал Юра

Имхо. После того как пользователь ввёл текст в произвольное место контролла, у тебя для пост-анализа есть только картинка.

Страницы:   1 2

Наверх

Титульная страница Поиск, карта сайта Написать письмо