Избавление от белых полей вокруг текста

← →
Teetotaller (2004-05-20 10:18) [0]

Добрый день.
Пытаюсь написать компоненту вроде TLabel которая не только бы автоматически изменяла свой размер при изменении текста, но и подбирала бы размер шрифта при изменении размера так, чтобы текст поместился в новый прямоугольник. Это что-то вроде элемента Text в графических редакторах - можно задать размер шрифта, а можно мышью задать размеры текста.

Теперь о проблеме. Дело в том, что при рисовании выше и ниже рисуемой строки остается пустое пространство (даже если буквы большие). Чтобы понять о чем я говорю, положите на форму Label и задайте ей большой размер шрифта. Выделите ее. Посмотрите: граница компонента проходит довольно далеко от собственно текста. Мне нужно как-то убирать это пустое пространство. Windows-функции DrawText, GetTextExtentPoint32 и т.д учитывают эти поля сверху и снизу, однако в том же графическом редакторе Paint Shop Pro, текст всегда вплотную к границам компоненты.
Посоветуйте - как тут быть ?

Заранее спасибо.

← →
wicked © (2004-05-20 11:50) [1]

может я и не прав, но может подойти GetTextMetrics...

← →
Teetotaller (2004-05-20 12:44) [2]

GetTextMetrics использую.
Вычитаю InternalLeading и ExternalLeading (обычно равный нулю). Все равно поля остаются (хотя и уменьшаются).
Чтобы пояснить вопрос я сделал 2 картинки

Как есть (из Дельфи)
http://terranian.mail333.com/DelphiText.gif

Как надо (из PaintShopPro)
http://terranian.mail333.com/PSPText.gif

← →
MBo © (2004-05-20 13:18) [3]

procedure TForm1.Button1Click(Sender: TObject);
var
R: TRect;
hr: HRGN;
begin
Canvas.Brush.Style := bsClear;
Canvas.Font.Name := "Arial";//TTF
Canvas.Font.Size := 200;
Canvas.Font.Style:=[fsItalic];
BeginPath(Canvas.Handle);
Canvas.TextOut(0, 0, "Fg");
EndPath(Canvas.Handle);
hr := PathToRegion(Canvas.Handle);
GetRgnBox(hr, R);
DeleteObject(hr);
Canvas.TextOut(0, 0, "Fg");
Canvas.Pen.Color:=clBlue;
Canvas.Rectangle(R);
end;

← →
Teetotaller (2004-05-20 13:36) [4]

MBo, Wow ! Спасибо большое. Код понятен.
Буду думать. Буду очень много думать как это применить.
На данный момент перевожу логическое пространство в сотые доли миллиметра и бинарным поиском подбираю размер шрифта чтобы уместить текст в коробочке. Надеюсь, такое вычисление размеров не будет слишком медленным.

← →
MBo © (2004-05-20 14:23) [5]

Возможность получить точные размеры по ширине есть - GetCharABCwidths и др. функции, а по высоте - нет, TextMetrics, Extent оставляют промежутки. Данный подход, конечно, медленный. А надо ли так точно подгонять?

← →
Teetotaller (2004-05-20 20:24) [6]

Если изменяется размер компоненты ( спомощью приаттаченых grab handles), шрифт должен измениться так, чтобы текст плотно уместился в новых границах.
Тут еще одна проблема - если при создании шрифта average char width указывать в пикселях, никакой точной подгонки не получается.
А если в долях миллиметра - не хватает памяти для получающегося региона (при больших размерах компоненты).
Динамическое переключение с пикселей на миллиметры делать не хочется (ибо все то будет использоваться для печати точного чертежа потом и подход нужен униформный).
Есть идея забрать Path в массив вершин, найти минимальный и максимальный Y и взять разницу - то будет высота.

← →
Teetotaller (2004-05-20 20:43) [7]

Так заметно побыстрее работает

procedure TForm1.GetTextRect(DC:HDC; S: String; var R: TRect); Var PArr:Array[0..65535] of TPoint; TArr:Array[0..65535] of byte; PointsCount:Integer; I:Integer; begin SetRect(R,0,0,MaxInt,MaxInt); BeginPath(DC); DrawText(DC,PChar(S),Length(S),R,0); EndPath(DC); FlattenPath(DC); PointsCount:=GetPath(DC,PArr,TArr,65536); R.Left:=Parr[0].X; R.Top:=Parr[0].Y; R.Right:=PArr[0].X; R.Bottom:=PArr[0].Y; For I:=1 to PointsCount-1 do begin If PArr[I].X<R.Left then R.Left:=PArr[I].X else If PArr[i].X>R.Right then R.Right:=PArr[i].X; If PArr[i].Y<R.Top then R.Top:=PArr[i].Y else If PArr[i].Y>R.Bottom then R.Bottom:=PArr[i].Y; end; end;

Только учти, что в траекторию записывается только вывод TTF-шрифтами.

Избавление от белых полей вокруг текста Найти похожие ветки