دریافت نام فونت 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;