Herhangi bir klasörden Font okuma

Hancet · Mesaj gönderen **Hancet** » 14 Nis 2007 11:03

S.A. Arkadaşlar

Bilgisayarımda epeyce font var. Bunların hepsini C:\Windows\Font klasörüne kopyalamadan ListBox'ta listelemek ve üzerine tıkladığım ismin Font'unu Label'de göstermek istiyorum.

Kod: Tümünü seç

procedure TForm1.Button1Click(Sender: TObject);
var
  f : integer;
begin
  for f := 0 to Screen.Fonts.Count-1 do
    listbox1.Items.Add(Screen.Fonts.Strings[f]) ;
end;

yukarıda ki kodlar ile standart Font Klasöründeki font'ları ListBox'a atıyorum

Kod: Tümünü seç

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  label1.Font.Name:=ListBox1.Items.Strings[ListBox1.ItemIndex];
end;

bu kod ilede Label'in font'unu değiştiriyorum.

Benim istediğim Standart Font klasöründekileri font'ları değilde FileListBox ile *.ttf uzantılı dosyaları gösterip, üzerine tıkladığım zaman Label'in font'unu seçili ile değiştirmek. Bu şekilde o font'u görmüş oluyorum ve istersem C:\Windows\font klasörüne kopyalayacağım.

Kısacası Label'in font'unda dışarıdan bi font'u nasıl gösterebilirim

Umarım anlatabilmişimdir.

Kolay Gelsin...

Mesaj gönderen **sabanakman** » 14 Nis 2007 11:37

Örnek bir programımı gönderiyorum:

Kod: Tümünü seç

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Panel1: TPanel;
    Splitter1: TSplitter;
    Edit1: TEdit;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    procedure Edit1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1Change(Sender: TObject);
begin
  Label1.Caption:=Edit1.Text;
end;

procedure TForm1.FormCreate(Sender: TObject);
var Bul:TSearchRec; Yol:String; n:Integer;
 function FontAdi(const DosyaAdi:String):String;
 var i:Integer;
 begin
   i:=Length(DosyaAdi);
   while (i>0) and (DosyaAdi[i]<>'.') do Dec(i);
   Dec(i);
   if i>0 then Result:=Copy(DosyaAdi,1,i) else Result:=DosyaAdi; 
 end;
begin
  Edit1.Text:='abcABCğüşiöçıĞÜŞİÖÇI';
  SpinEdit1.Value:=Label1.Font.Size;
  Yol:=ExtractFilePath(Application.ExeName);
  n:=Length(Yol);
  if (Yol<>'') and (Yol[n]='\') then begin
    Delete(Yol,n,1);
  end;
  Yol:=ExtractFilePath(Yol);
  if (Yol<>'') and (Yol[Length(Yol)]<>'\') then Yol:=Yol+'\';
  ListBox1.Items.Clear;
  if FindFirst(Yol+'*.ttf',faAnyFile,Bul)=0 then repeat
    ListBox1.Items.Add(FontAdi(Bul.Name));
    AddFontResource(PChar(Yol+Bul.Name));
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  until FindNext(Bul)<>0;
  FindClose(Bul);
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  if (ListBox1.ItemIndex>=0) and (ListBox1.ItemIndex<ListBox1.Items.Count) then
   Label1.Font.Name:=ListBox1.Items[ListBox1.ItemIndex];
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
  if SpinEdit1.Text<>'' then Label1.Font.Size:=SpinEdit1.Value;
end;

end.

bu da .dfm dosyası

Kod: Tümünü seç

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Splitter1: TSplitter
    Left = 161
    Top = 0
    Width = 3
    Height = 453
    Cursor = crHSplit
  end
  object ListBox1: TListBox
    Left = 0
    Top = 0
    Width = 161
    Height = 453
    Align = alLeft
    ItemHeight = 13
    TabOrder = 0
    OnClick = ListBox1Click
  end
  object Panel1: TPanel
    Left = 164
    Top = 0
    Width = 524
    Height = 453
    Align = alClient
    TabOrder = 1
    object Label1: TLabel
      Left = 1
      Top = 432
      Width = 522
      Height = 20
      Align = alBottom
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -16
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      ParentFont = False
    end
    object Edit1: TEdit
      Left = 8
      Top = 8
      Width = 497
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 0
      OnChange = Edit1Change
    end
    object SpinEdit1: TSpinEdit
      Left = 8
      Top = 32
      Width = 121
      Height = 22
      MaxValue = 0
      MinValue = 0
      TabOrder = 1
      Value = 0
      OnChange = SpinEdit1Change
    end
  end
end

bu program .exe'nin bulunduğu klasörün bir üstündeki klasöre bakıyor. Sen bunu istersen FormCreate kodunu bit Button içine alıp Yol değişkenine font klasör yolunu vererek çalıştırabilirsin.

Hancet · Mesaj gönderen **Hancet** » 21 Nis 2007 12:37

Hocam ilginiz için teşekkür ederim, birkaç gündür uğraşıyorum yanlız sanırım beceremedim.

Times New Roman dışındaki fontları label'de göremiyorum. Ayrıca fontların yüklenmeside çok uzun sürüyor. Sanırım AddFontResource(PChar(Yol+Bul.Name)); bu koddan kaynaklanıyor.

benim kullanım alanım biraz geniş. Elimde binlerce font var ve bunları programım ile görüp, istediklerimi Standart Font klasörüne kopyalamak istiyorum. bu yüzden hız biraz önemli.

Bu konuda yardımcı olabilirseniz çok teşekkür ederim.

Kolay Gelsin...

Mesaj gönderen **sabanakman** » 21 Nis 2007 10:28

DirectoryListBox ve FileListBox kulanarak FileListBox üzerinde çift veya tek tıklanan font dosyasnı sisteme yükle o zaman. Böylelikle sadece tıklanan font yükleneceği için bekleme olayı ortadan kalkacaktır.

Hancet · Mesaj gönderen **Hancet** » 21 Nis 2007 10:36

Kod: Tümünü seç

procedure TForm1.FileListBox1Click(Sender: TObject);
begin
    AddFontResource(PChar(FileListBox1.FileName));
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  Label1.Font.Name:=FileListBox1.FileName;
end;

Hocam bu şekilde yapıyorum zaten, fakat font'ları label'de gösteremiyorum bi türlü. Bunun nedeni nedir sizce?

Birde DirectoryListBox'ta Windows\Fonts klasörünü göremiyorum. Sizce normal mi bu?

Mesaj gönderen **sabanakman** » 21 Nis 2007 12:34

Hancet yazdı:
Kod: Tümünü seç
.
.
.
  Label1.Font.Name:=FileListBox1.FileName;
end;
Hocam bu şekilde yapıyorum zaten, fakat font'ları label'de gösteremiyorum bi türlü. Bunun nedeni nedir sizce?

Birde DirectoryListBox'ta Windows\Fonts klasörünü göremiyorum. Sizce normal mi bu?

Normal

Kod: Tümünü seç

function FontAdi(const DosyaAdi:String):String;
 var i:Integer;
 begin
   i:=Length(DosyaAdi);
   while (i>0) and (DosyaAdi[i]<>'.') do Dec(i);
   Dec(i);
   if i>0 then Result:=Copy(DosyaAdi,1,i) else Result:=DosyaAdi;
 end;
.
.
.
Label1.Font.Name:=FontAdi(FileListBox1.FileName);

yaparsan düzeleceğini umuyorum.

Hancet · Mesaj gönderen **Hancet** » 22 Nis 2007 12:46

Hocam hala olmuyor...

Kod: Tümünü seç

procedure TForm1.FileListBox1Click(Sender: TObject);
var Bul:TSearchRec; Yol:String; n:Integer;
 function FontAdi(const DosyaAdi:String):String;
 var i:Integer;
 begin
   i:=Length(DosyaAdi);
   while (i>0) and (DosyaAdi[i]<>'.') do Dec(i);
   Dec(i);
   if i>0 then Result:=Copy(DosyaAdi,1,i) else Result:=DosyaAdi;
 end;
begin
  Yol:=FileListBox1.FileName;
  showmessage(yol);
  n:=Length(Yol);
  if (Yol<>'') and (Yol[n]='\') then begin
    Delete(Yol,n,1);
  end;
  Yol:=ExtractFilePath(Yol);
  showmessage(yol);
  if (Yol<>'') and (Yol[Length(Yol)]<>'\') then Yol:=Yol+'\';
   showmessage(yol);
    AddFontResource(PChar(Yol+Bul.Name));
    showmessage(yol+bul.Name);
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
    Label1.Font.Name:=FontAdi(FileListBox1.FileName);
end;

nerde yanlış yapıyorum anlamadım

Mesaj gönderen **sabanakman** » 24 Nis 2007 08:46

Niye o kadar kastın ki. Alt tarafı dosyayı AddFontResource ile ekleyip, fontname'ini doğru vermen gerekiyor. Bu arada font adı dosya adından farklı bir değer olabilir bunu nasıl elde ederiz bilmiyorum ama genelde dosya adı font adı ile aynı olmaktadır.

Kod: Tümünü seç

procedure TForm1.FileListBox1Click(Sender: TObject);
var Bul:TSearchRec; Yol:String; n:Integer;
 function FontAdi(const DosyaAdi:String):String;
 var i:Integer;
 begin
   i:=Length(DosyaAdi);
   while (i>0) and (DosyaAdi[i]<>'.') do Dec(i);
   Dec(i);
   if i>0 then Result:=Copy(DosyaAdi,1,i) else Result:=DosyaAdi;
 end;
begin
  AddFontResource(PChar(FileListBox1.FileName));//fontu yükle
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);//fontu aktif yap
  Label1.Font.Name:=FontAdi(ExtractFileName(FileListBox1.FileName));//fontu seç
end;

Bu kadar sade bir kod yazman gerekiyor.

Hancet · Mesaj gönderen **Hancet** » 25 Nis 2007 01:17

Hocam ilk gönderdiğiniz kod ve son gönderdiğiniz koda kadar hepsini denedim, ayrıca kendimde farklı yollar denedim, bazılarını yazdım buraya ama hala olmadı. bi klasöre 3 tane font kopyaladım. Arial, comic sans, times new roman. bu 3 fonttan sadece times new roman'ın üzerine gelince Label'in fontu değişiyor, diğer 2 fontta aynı tür font görünüyor. farklı fontlarda denedim hiç birinde olmadı.

mantığı anladım, önce fontu AddFontResource ile kayıt edeceğiz, sonrada SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); bu komut ile aktif yapacağız ama olmadı bi türlü

Program sizde nasıl çalışıyor? ben hala bir yerde eksiklik mi yapıyorum yoksa benim bilgisayarımda mı sorun var anlamadım...

Mesaj gönderen **sabanakman** » 25 Nis 2007 10:06

İlk kodlar bende çalışıyorlar fakat bu durumda benim aklıma başka birşey gelmiyor.

Hancet · Mesaj gönderen **Hancet** » 28 Nis 2007 09:34

Hocam zahmet olmazsa bana derlenmiş bir halini gönderebilir misiniz? bende hala sadece Times New Roman fontunu gösteriyor, diğerlerini takmıyor

Mesaj gönderen **sabanakman** » 30 Nis 2007 09:25

Unit1.pas

Kod: Tümünü seç

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Panel1: TPanel;
    Splitter1: TSplitter;
    Edit1: TEdit;
    Label1: TLabel;
    SpinEdit1: TSpinEdit;
    procedure Edit1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure SpinEdit1Change(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1Change(Sender: TObject);
begin
  Label1.Caption:=Edit1.Text;
end;

procedure TForm1.FormCreate(Sender: TObject);
var Bul:TSearchRec; Yol:String; n:Integer;
 function FontAdi(const DosyaAdi:String):String;
 var i:Integer;
 begin
   i:=Length(DosyaAdi);
   while (i>0) and (DosyaAdi[i]<>'.') do Dec(i);
   Dec(i);
   if i>0 then Result:=Copy(DosyaAdi,1,i) else Result:=DosyaAdi; 
 end;
begin
  Edit1.Text:='abcABCğüşiöçıĞÜŞİÖÇI';
  SpinEdit1.Value:=Label1.Font.Size;
  Yol:=ExtractFilePath(Application.ExeName);
  n:=Length(Yol);
  if (Yol<>'') and (Yol[n]='\') then begin
    Delete(Yol,n,1);
  end;
  Yol:=ExtractFilePath(Yol);
  if (Yol<>'') and (Yol[Length(Yol)]<>'\') then Yol:=Yol+'\';
  ListBox1.Items.Clear;
  if FindFirst(Yol+'*.ttf',faAnyFile,Bul)=0 then repeat
    ListBox1.Items.Add(FontAdi(Bul.Name));
    AddFontResource(PChar(Yol+Bul.Name));
    SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
  until FindNext(Bul)<>0;
  FindClose(Bul);
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
  if (ListBox1.ItemIndex>=0) and (ListBox1.ItemIndex<ListBox1.Items.Count) then
   Label1.Font.Name:=ListBox1.Items[ListBox1.ItemIndex];
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
  if SpinEdit1.Text<>'' then Label1.Font.Size:=SpinEdit1.Value;
end;

end.

Unit1.dfm

Kod: Tümünü seç

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Splitter1: TSplitter
    Left = 161
    Top = 0
    Width = 3
    Height = 453
    Cursor = crHSplit
  end
  object ListBox1: TListBox
    Left = 0
    Top = 0
    Width = 161
    Height = 453
    Align = alLeft
    ItemHeight = 13
    TabOrder = 0
    OnClick = ListBox1Click
  end
  object Panel1: TPanel
    Left = 164
    Top = 0
    Width = 524
    Height = 453
    Align = alClient
    TabOrder = 1
    object Label1: TLabel
      Left = 1
      Top = 432
      Width = 522
      Height = 20
      Align = alBottom
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -16
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      ParentFont = False
    end
    object Edit1: TEdit
      Left = 8
      Top = 8
      Width = 497
      Height = 21
      Anchors = [akLeft, akTop, akRight]
      TabOrder = 0
      OnChange = Edit1Change
    end
    object SpinEdit1: TSpinEdit
      Left = 8
      Top = 32
      Width = 121
      Height = 22
      MaxValue = 0
      MinValue = 0
      TabOrder = 1
      Value = 0
      OnChange = SpinEdit1Change
    end
  end
end