[Delphi] font v TEdit

C++, C#, Visual Basic, Delphi, Perl a ostatní

Moderátor: Moderátoři Živě.cz

Odeslat příspěvekod dyžon 21. 11. 2018 13:04

dobrý den,
můžete mi prosím někdo pomoci s tímto kódem:
Kód: Vybrat vše
function VratDelkuTextu(const zprava: String; aFont: TFont): Integer;
var aBmp: TBitmap;
begin
  aBmp:= TBitmap.Create;
  try
    aBmp.Canvas.Font:= aFont;
    Result:= aBmp.Canvas.TextWidth(zprava);
  finally
    aBmp.Free;
  end;
end;
  ....
  max, min: Integer;
  max:= 10;
  min:= 6;
  ....
procedure TForm1.Edit1Change(Sender: TObject);
var velikost: Integer;
begin
  velikost:= Edit1.Font.Size;
  if VratDelkuTextu(edit1.Text, Edit1.Font) > Edit1.Width then
    begin
      if velikost > min then
        begin
          dec(velikost);
          Edit1.Font.Size:= velikost;
        end;
    end else begin
      if velikost < max then
        begin
          inc(velikost);
          Edit1.Font.Size:= velikost;
        end;
    end;
end;

jde mi o to, že píšu text do Editu, kterej má fixní velikost a já potřebuju, aby když je text delší se jeho velikost v Editu změnila na menší (nejmenší je min + 1) a naopak když je krátkej, tak zase zvětší (největší je max - 1) aby ten text byl vidět vždy celej.
napsal jsem si tenhle kód, ale pořád to nějak hapruje ..
nějakej nápad ??
AMD FX-6300; Gigabyte 970A-DS3P; DDR3 8192MBytes; AMD Radeon HD 6700 Series
dyžon
Junior
Uživatelský avatar

Odeslat příspěvekod JanFiala 21. 11. 2018 14:05

Myslel jsi něco takového? jen musíš použít TTF font, třeba Consolas UI

Kód: Vybrat vše
const
  MaxFontSize = 10;
  MinFontSize = 6;

function VratDelkuTextu(AEdit: TEdit): Integer;
var
  myCanvas: TCanvas;
begin
  Result := -1;
  myCanvas := TControlCanvas.Create;
  try
    myCanvas.Handle := GetDC(AEdit.Handle);
    myCanvas.Font.Assign(AEdit.Font);
    Result := myCanvas.TextWidth(AEdit.Text);
  finally
    myCanvas.Free;
  end;
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
  Edit1.Font.Size := MaxFontSize + 1;
  while (VratDelkuTextu(Edit1) > (Edit1.ClientRect.Right-Edit1.ClientRect.Left))
      and (Edit1.Font.Size >= MinFontSize) do
    Edit1.Font.Size := Edit1.Font.Size - 1;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.Font.Size := MaxFontSize;
end;
Co můžeš udělat dnes, odlož na včerejšek
JanFiala
Expert
Uživatelský avatar

Odeslat příspěvekod dyžon 23. 11. 2018 11:38

jj, to je přesně ono,
místo TBitMap vytváříš jen TCanvas, to je super ...
možná poprosím jen o vysvětlení, proč jsi použil WHILE místo IF, ale jinak to funguje perfektně ..
díky moc.
AMD FX-6300; Gigabyte 970A-DS3P; DDR3 8192MBytes; AMD Radeon HD 6700 Series
dyžon
Junior
Uživatelský avatar

Odeslat příspěvekod JanFiala 23. 11. 2018 15:20

Proč jsem použil While? Abych měl jistotu, že když tam třeba vložíš text přes paste - několik znaků najednou, že se to zmenší na správnou velikost - provede se potřebný počet kroků zmenšení
Co můžeš udělat dnes, odlož na včerejšek
JanFiala
Expert
Uživatelský avatar

Odeslat příspěvekod dyžon 26. 11. 2018 08:21

díky ... ;-)
AMD FX-6300; Gigabyte 970A-DS3P; DDR3 8192MBytes; AMD Radeon HD 6700 Series
dyžon
Junior
Uživatelský avatar




Kdo je online

Uživatelé procházející toto fórum: Žádní registrovaní uživatelé a 0 návštevníků