AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Thema durchsuchen
Ansicht
Themen-Optionen

Zu jedem Font verfügbare Grösse ermitteln!

Ein Thema von R2009 · begonnen am 27. Nov 2009 · letzter Beitrag vom 27. Nov 2009
Antwort Antwort
R2009

Registriert seit: 9. Mär 2009
Ort: Heidelberg
440 Beiträge
 
Delphi 2007 Professional
 
#1

Re: Zu jedem Font verfügbare Grösse ermitteln!

  Alt 27. Nov 2009, 17:37
Hallo taaktaak,
danke dein Hinweis hat mir geholfen, das ist dabei rausgekommen:

Delphi-Quellcode:
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  imin,imax:integer; <<---hab ich auf die schnelle hinzugefügt. Hat im Original gefehlt
implementation

{$R *.dfm}
procedure GetSizes(var List:TStringlist;FontName:String;Min,Max:Integer);<<--- im Orginal
// list:tstrings hab ich durch var list:tstinglist ersetzt. Warum ist wohl klar

var DC : HDC;
    LF : TLogFont;

  function EnumSize(var LogFont:TLogFont;var TextMetric:TTextMetric;
                    FontType:Integer;Data:LParam):Integer; stdcall;
  const TTSizes : Array[0..15] of Integer
                = (8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);
  var i,H : Integer;
        DC : HDC;
  begin
   if FontType=TrueType_FontType then begin // get sizes from const array
     for i:=0 to High(TTSizes) do
       if TTSizes[i]>=iMin then
         if TTSizes[i]<=iMax then
           TStrings(Data).Add(IntToStr(TTSizes[i]));
     Result:=0;
     end
                                 else begin // get sizes from WinAPI
    DC:=GetDC(0);

    try
      with TextMetric do
        H:=MulDiv(tmHeight-tmInternalLeading,72,GetDeviceCaps(DC,LogPixelsY));
        //
        // folgende "Übersetzung" berechnet für Courier, 10 pts das falsche Ergebnis 9 pts
        // ist also NICHT äquivalent zu MulDiv()
        //
        // H:=((tmHeight-tmInternalLeading)*72) div GetDeviceCaps(DC,LogPixelsY);
        //

      if H>=TTSizes[0] then // no smaller size than MinSize of TrueType
        if H>=iMin then
          if H<=iMax then
            if TStrings(Data).IndexOf(IntToStr(H))<0 then
              TStrings(Data).Add(IntToStr(H));
      Result:=1;

    finally
      ReleaseDC(0,DC);
      end;

    end;

  end;

  procedure SortList;
  var i : Integer;
      t : String;
      Done : Boolean;
  begin
    repeat
      Done:=true;
      for i:=0 to List.Count-2 do
        if StrToInt(List[i])>StrToInt(List[i+1]) then begin
          t :=List[i];
          List[i] :=List[i+1];
          List[i+1]:=t;
          Done :=false;
          end;
      until Done
  end;

begin
  DC:=GetDC(0);

  iMin:=Min;
  iMax:=Max;
  if iMax=0 then iMax:=999;

  try
    fillchar(LF,SizeOf(LF),0);
    LF.lfCharSet:=Default_CharSet;
    Move(FontName[1],LF.lfFaceName,length(FontName));

    List.BeginUpdate;
    List.Clear;
    EnumFontFamiliesEx(DC,LF,@EnumSize,LParam(List),0);
    Sortlist;
    List.EndUpdate;

  finally
    ReleaseDC(0,DC);
    end;

end;

procedure TForm1.Button1Click(Sender: TObject);
var l:Tstringlist;
begin
  l:=tstringlist.Create;
  GetSizes(L,'Arial',0,100);
  ListBox1.Items.Assign(l);
  l.free;
end;

end.
Grüsse
Rainer

Ps: An alle die sich hier durch meine Reaktion "angemacht" oder ungerecht behandelt fühlen:
Es tut mir leid wenn ich jemanden ungerecht behandelt haben sollte.
War vielleicht der Frust darüber, dass man komplexeste Sachverhalte, in relativ kurzer Zeit, einfach lösen kann und
bei so einfachen Dingen wie der Fontgrösse fast kapitulieren muss.
Die unsachlichen Bemerkungen in diesem Thread möchte ich nicht kommentieren!
Rainer Unger
Mein Profil:
Studium Allgemeine Elektrotechnik TH Darmstadt
Entwicklung von Tools für die Rundsteuer und Zählertechnik.
uP's Atmel Prozessoren (ATmega16,32,88...) in C und Assembler.
  Mit Zitat antworten Zitat
Antwort Antwort


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 11:46 Uhr.
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024-2025 by Thomas Breitkreuz