دریافت نام فونت FON.

[Mohammad_Mnt]

چطوری می تونم نام یک فونت که توی ویندوز نصب نشده رو از روی فایل فونت به دست بیارم. ( فونت Bitmap است ، نه TrueType ).

[arash_ebrahimi_nk]

نمیشه یه طوری این نوع فونت ها بدون نصب در داخل برنامه خودمون بازش کنیم و بتونیم اسمش رو بفهمم.
البته میدونم که اگه به این سادگی ها بود - حتما آقا محمد تا به حال راهش رو پیدا کرده بود.
چه کنیم دیگه - خواستیم یه چیزی گفته باشیم.

[Mohammad_Mnt]

خوب وقتی بازش کردیم چطوری نام فونت رو به دست بیاریم ؟ :)
من حدود 4-5 ساعت سرچ کردم ولی چیزی پیدا نکردم :(

[vcldeveloper]

ببین این بدردت می خوره:
http://www.codeproject.com/gdi/xfont.asp
شاید این هم بدردت بخوره - مطمئن نیستم ساختارشون یکی باشه!
http://www.wotsit.org/download.asp?f=font

[arash_ebrahimi_nk]

از اینایی که مینویسم خودم وقت زیادی نداشتم که سر دربیارم.

I suppose that all my articles work in Delphi 3.x or higher because i don't have early versions to test.



Create a function that returns a boolean value and receive input a FontName and put this code inside.





//..... Don't Forget a parameter (FontName: String)...

var



  pitch:    Byte

  MyCanvas: TCanvas;

  TextMet:  TTextMetric;



begin

Result:=False;

MyCanvas:= TCanvas.Create;

Try

   MyCanvas.Handle:= CreateCompatibleDC (0);

   MyCanvas.Font.Name:=FontName;

   GetTextMetrics (MyCanvas.Handle, TextMet);

   Pitch := TextMet.tmPitchAndFamyly and $07;

   Result:= ((Pitch and TMPF_TRUETYPE)<>0);



finally

   MyCanvas.Free;

end;



end;

Use the Windows API function GetStockObject() to retrieve the

device default font handle, and assign it to Printer.Font.Handle.



Example:



uses Printers;



procedure TForm1.Button1Click(Sender: TObject);

var

  tm : TTextMetric;

  i : integer;

begin

  if PrintDialog1.Execute then begin

    Printer.BeginDoc;

    Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);

    GetTextMetrics(Printer.Canvas.Handle, tm);

    for i := 1 to 10 do begin

      Printer.Canvas.TextOut(100,

                             i * tm.tmHeight +

                             tm.tmExternalLeading,

                             'Test');

    end;

    Printer.EndDoc;

  end;

end;

The Following example adds the list of fonts and sizes for the

current printer to a TMemo component.



Example:



uses Printers;



function EnumFontFamilyProc(var lf : TLogFont;

                            var tm : TNewTextMetric;

                            FontType : integer;

                            var Memo : TMemo) : integer

{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}

begin

  Memo.Lines.Add(StrPas(@lf.lfFaceName) +

                        #32 + IntToStr(lf.lfHeight));

  result := 1;

end;



function EnumFontFamiliesProc(var lf : TLogFont;

                              var tm : TNewTextMetric;

                              FontType : integer;

                              var Memo : TMemo) : integer

{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}

begin

  if FontType = TRUETYPE_FONTTYPE then begin

    Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + 'All Sizes');

  end else

    EnumFontFamilies(Printer.Handle,

                     @lf.lfFaceName,

                     @EnumFontFamilyProc,

                     LongInt(@Memo));

  result := 1;

end;



procedure TForm1.Button1Click(Sender: TObject);

var

  tm : TTextMetric;

  i : integer;

begin

  if PrintDialog1.Execute then begin

    EnumFontFamilies(Printer.Handle,

                     nil,

                     @EnumFontFamiliesProc,

                     LongInt(@Memo1));

  end;

end;

Include a font in your EXE:

Using your favorite text editor, create a *.rc file that describes the font:



MY_FONT ANYOL1 "Bauhs93.ttf"



The first two parameters can be whatever you want. They get used in your program

later.

Then, use the BRCC32.EXE command line compiler that ships with Delphi to create

a *.res file. If your file in step 1 was MyFont.rc, the command from the DOS

prompt would be:



BRCC32 MyFont



The program will append the .rc to the input, and create a file with the same

name except it appends .res: MyFont.res

In your program, add a compiler directive to include your newly created file:



{$R MyFont.res}



This can go right after the default {$R *.DFM} in the implementation section.

Add a procedure to create a file from the resource, then make the Font

available for use. Example:



procedure TForm1.FormCreate(Sender: TObject);

var

  Res : TResourceStream;

begin

  Res := TResourceStream.Create(hInstance, 'MY_FONT', Pchar('ANYOL1'));

  Res.SavetoFile('Bauhs93.ttf');

  Res.Free;

  AddFontResource(PChar('Bauhs93.ttf'));

  SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

end;



You can now assign the font to whatever you wish:



procedure TForm1.Button1Click(Sender: TObject);

begin

  Button1.Font.Name := 'Bauhaus 93';

end;



Caveats:



The above example provides for no error checking whatsoever. :-)

Notice that the File name is NOT the same as the Font name. It's assumed that

you know the font name associated with the file name. You can determine this

by double clicking on the file name in the explorer window.



I would recommend placing your font file in the C:\WINDOWS\FONTS folder.

It's easier to find them later.



Your newly installed font can be removed programatically, assuming the font

is not in use anywhere:



procedure TForm1.FormDestroy(Sender: TObject);

begin

  RemoveFontResource(PChar("Bauhs93.ttf"))

  SendMessage(HWND_BROADCAST,WM_FONTCHANGE,0,0);

end;



Check the Win32 help for further details on the AddFontResource and RemoveFontResource

[Mohammad_Mnt]

@کشاورز: فقط با TrueType کار می کنه :(
@ابراهیمی: فکر کنم این ها برای فونت نصب شده هستند :(

[vcldeveloper]

@کشاورز: فقط با TrueType کار می کنه :(

من Demo برنامه XFont رو که امتحان کردم، روی فایلهای FON. هم جواب میداد.

[Mohammad_Mnt]

من نتونستم compile کنم ( VS2005 ) ولی توی سورس که دیدم یه جا یه همچین چیزی بود:

if (!truetype && ver==1) then exit;

فکر کردم فقط با TrueType جواب می ده :)
پس می رم دوباره نگاش کنم. ممنون

[vcldeveloper]

من نتونستم compile کنم

در همون صفحه لینکی به یک نسخه Demo کامپایل شده وجود داره.

[Mohammad_Mnt]

آقای کشاورز، من دمو رو اجرا کردم. 2 تا مشکل :
1) فقط برای فونت های نصب شده این کار رو انجام می ده
2) برای فونت های FON. توی باکس آخر که مربوط به اسم فونت از روی فایل است هیچی نمی نویسه. مثلا" من System و Ms San Serif امتحان کردم و جواب نداد ( عکس ضمیمه )

[arash_ebrahimi_nk]

آقا محمد.
مگه اونسری که با هم صحبت میکردیم - بعدش نتونستی نام فونت رو از این نوع فایلها استخراج کنی !
ما محتویات یک فایل .fon رو بصورت متنی مشاهده کردیم و دیدم دو تا تگ مربوط به نام داره که براحتی میشه از طریق فرمان Pos و چند تا تابع رشته ای دیگه ای نام و تمامی مشخصات این نوع فونتها رو استخراج کرد!

ضمناً برنامه ای که برای فارسی کردن نوشتین یه ایرادهای کوچکی داره - مثلا وقتی اون رو نصب کنیم و بعدش زبان رو بدون سی دی ویندوز فارسی کنیم - نوشته های فارسی بهم میرزه.
ایراد چندان بزرگی نیست - من با این قضیه زیاد مشکل ندارم.
من فقط میخواستم بدونم آیا بدون ری استارت هم راهی هست که بشه یه برنامه رو فارسی بالا آورد؟
و اینکه چطور میشه دقیقا چک کرد که پشتیبانی زبان فارسی بطور کامل نصب هست یا نه؟

[Mohammad_Mnt]

آرش جان، آخه این که با Pos بخوام کارکنم فکرنکنم روی همه ی فونت ها جواب بده. من چیزی می خوام که کلی باشه

مثلا وقتی اون رو نصب کنیم و بعدش زبان رو بدون سی دی ویندوز فارسی کنیم - نوشته های فارسی بهم میرزه.

منظورت رو نفهمیدم ! مگه برای فارسی کردن به سی دی ویندوز احتیاج داره ؟ :( می شه بحث مربوط به برنامه فارسی ساز رو توی همون تاپیک بگی که من در جریانش باشم؟ ممنون

[arash_ebrahimi_nk]

آرش جان، آخه این که با Pos بخوام کارکنم فکرنکنم روی همه ی فونت ها جواب بده. من چیزی می خوام که کلی باشه
منظورت رو نفهمیدم ! مگه برای فارسی کردن به سی دی ویندوز احتیاج داره ؟ :( می شه بحث مربوط به برنامه فارسی ساز رو توی همون تاپیک بگی که من در جریانش باشم؟ ممنون

اون قسمتی که شما بهش نیاز دارین جزء استراکچر اصلی فایلهایی .fon هستش و همیشه ثابته. اگه غیر از ایه باشه باید یه فونت از همون نوع رو به عنوان نمونه پیدا کرد که استراکچرش فرق داشته باشه. ضمناً از کجا معلوم وقتی برخی از توابع دلفی رو برای دریافت اطلاعات بعضی سوژه ها بکار میبرمد اون تابع خودش همین کار Pos رو انجام نده!

[arash_ebrahimi_nk]

سلام محمد جان
من یه برنامه نوشتم. برای دریافت نام فونتهای fon فکر میکنم کار تو رو راه بندازه. یه روز و نیم الافش بودم. فکر نمیکردم انقدر مشکل باشه.
فایل اجرایی رو هم گذاشتم که تست کنی.

بذار توی برنامه فارسی سازی که ساختی و برنامه رو کامل کن

[arash_ebrahimi_nk]

سلام یه تابع کامل که روی تمام فونتهای FON. جواب میده نوشتم.
نام فونت رو بهش میدیم و اون نامی که برای نصب این فونت مورد استفاده قرار میگیره رو به ما میده.
در مسیر نوشتن این تابع که دو سه روز وقتم رو گرفت چیزای خوبی یاد گرفتم. تقدیم به همه دلفی کارها.

function ByteToHex(B: Byte): String;

const Digits: array[0..$f] of char = '0123456789ABCDEF';

begin

 result := digits[b shr 4] + digits[b and $f];

end;



function HexToStr(HexStr: String): String;

begin

  Result := ' ';

  if HexStr = '21' then Result := '!';

  if HexStr = '22' then Result := '"';

  if HexStr = '23' then Result := '#';

  if HexStr = '24' then Result := '$';

  if HexStr = '25' then Result := '%';

  if HexStr = '26' then Result := '&';

  if HexStr = '27' then Result := '''';

  if HexStr = '28' then Result := '(';

  if HexStr = '29' then Result := ')';

  if HexStr = '2A' then Result := '*';

  if HexStr = '2B' then Result := '+';

  if HexStr = '2C' then Result := ',';

  if HexStr = '2D' then Result := '-';

  if HexStr = '2E' then Result := '.';

  if HexStr = '2F' then Result := '/';

  if HexStr = '30' then Result := '0';

  if HexStr = '31' then Result := '1';

  if HexStr = '32' then Result := '2';

  if HexStr = '33' then Result := '3';

  if HexStr = '34' then Result := '4';

  if HexStr = '35' then Result := '5';

  if HexStr = '36' then Result := '6';

  if HexStr = '37' then Result := '7';

  if HexStr = '38' then Result := '8';

  if HexStr = '39' then Result := '9';

  if HexStr = '3A' then Result := ':';

  if HexStr = '3B' then Result := ';';

  if HexStr = '3C' then Result := '<';

  if HexStr = '3D' then Result := '=';

  if HexStr = '3E' then Result := '>';

  if HexStr = '3F' then Result := '?';

  if HexStr = '40' then Result := '@';

  if HexStr = '41' then Result := 'A';

  if HexStr = '42' then Result := 'B';

  if HexStr = '43' then Result := 'C';

  if HexStr = '44' then Result := 'D';

  if HexStr = '45' then Result := 'E';

  if HexStr = '46' then Result := 'F';

  if HexStr = '47' then Result := 'G';

  if HexStr = '48' then Result := 'H';

  if HexStr = '49' then Result := 'I';

  if HexStr = '4A' then Result := 'J';

  if HexStr = '4B' then Result := 'K';

  if HexStr = '4C' then Result := 'L';

  if HexStr = '4D' then Result := 'M';

  if HexStr = '4E' then Result := 'N';

  if HexStr = '4F' then Result := 'O';

  if HexStr = '50' then Result := 'P';

  if HexStr = '51' then Result := 'Q';

  if HexStr = '52' then Result := 'R';

  if HexStr = '53' then Result := 'S';

  if HexStr = '54' then Result := 'T';

  if HexStr = '55' then Result := 'U';

  if HexStr = '56' then Result := 'V';

  if HexStr = '57' then Result := 'W';

  if HexStr = '58' then Result := 'X';

  if HexStr = '59' then Result := 'Y';

  if HexStr = '5A' then Result := 'Z';

  if HexStr = '5B' then Result := '[';

  if HexStr = '5C' then Result := '\';

  if HexStr = '5D' then Result := ']';

  if HexStr = '5E' then Result := '^';

  if HexStr = '5F' then Result := '_';

  if HexStr = '60' then Result := '`';

  if HexStr = '61' then Result := 'a';

  if HexStr = '62' then Result := 'b';

  if HexStr = '63' then Result := 'c';

  if HexStr = '64' then Result := 'd';

  if HexStr = '65' then Result := 'e';

  if HexStr = '66' then Result := 'f';

  if HexStr = '67' then Result := 'g';

  if HexStr = '68' then Result := 'h';

  if HexStr = '69' then Result := 'i';

  if HexStr = '6A' then Result := 'j';

  if HexStr = '6B' then Result := 'k';

  if HexStr = '6C' then Result := 'l';

  if HexStr = '6D' then Result := 'm';

  if HexStr = '6E' then Result := 'n';

  if HexStr = '6F' then Result := 'o';

  if HexStr = '70' then Result := 'p';

  if HexStr = '71' then Result := 'q';

  if HexStr = '72' then Result := 'r';

  if HexStr = '73' then Result := 's';

  if HexStr = '74' then Result := 't';

  if HexStr = '75' then Result := 'u';

  if HexStr = '76' then Result := 'v';

  if HexStr = '77' then Result := 'w';

  if HexStr = '78' then Result := 'x';

  if HexStr = '79' then Result := 'y';

  if HexStr = '7A' then Result := 'z';

  if HexStr = '7B' then Result := '{';

  if HexStr = '7C' then Result := '|';

  if HexStr = '7D' then Result := '}';

  if HexStr = '7E' then Result := '~';

end;





function ExtractBitmapedFontName(const FonFileName: string): string;

var

  ByteFile: File Of Byte;

  B: Byte;

  S: String;

  I: Integer;

  BoolFONTRES: Boolean;

begin

  I := 0;

  BoolFONTRES := False;

  if FileExists(FonFileName) then begin

    AssignFile(ByteFile, FonFileName);

    Reset(ByteFile);

    try

      while not Eof(ByteFile) do begin

        Read(ByteFile, B);

        if (HexToStr(ByteToHex(B)) = 'F') and (I = 0) then

          I := 1;

        if (HexToStr(ByteToHex(B)) = 'O') and (I = 1) then

          I := 2;

        if (HexToStr(ByteToHex(B)) = 'N') and (I = 2) then

          I := 3;

        if (HexToStr(ByteToHex(B)) = 'T') and (I = 3) then

          I := 4;

        if (HexToStr(ByteToHex(B)) = 'R') and (I = 4) then

          I := 5;

        if (HexToStr(ByteToHex(B)) = 'E') and (I = 5) then

          I := 6;

        if (HexToStr(ByteToHex(B)) = 'S') and (I = 6) then

          I := 7;

        if I = 7 then BoolFONTRES := True;

        if BoolFONTRES then begin

          if ByteToHex(B) = '00' then

            Break else

          S := S + HexToStr(ByteToHex(B));

        end;

      end;

    finally

      CloseFile(ByteFile);

    end;

  Delete(S, 1, Pos(':', S)+1);

  end;

  Result := S;

end;