fontframe.pas

一个可以把源代码以语法高亮的形式转换成HTML格式或RTF格式。

unit FontFrame;

{*******************************************
 * brief: 字体设置模板
 * autor: linzhenqun
 * date: 2005-11-01
 * email: [e-mail]
 * blog: http://blog.csdn.net/linzhengqun
********************************************}

interface

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

type
  TFrameFont = class(TFrame)
    cbFontColor: TColorBox;
    lblFontColor: TLabel;
    cbFontSize: TComboBox;
    lblFontSize: TLabel;
    cbFontName: TComboBox;
    lblFontName: TLabel;
    chkItalic: TCheckBox;
    chkStrikethrough: TCheckBox;
    chkBold: TCheckBox;
    chkUnderline: TCheckBox;
    Bevel1: TBevel;
    pnlFontTest: TPanel;
    procedure cbFontNameExit(Sender: TObject);
    procedure chkItalicClick(Sender: TObject);
    procedure chkBoldClick(Sender: TObject);
    procedure chkStrikethroughClick(Sender: TObject);
    procedure chkUnderlineClick(Sender: TObject);
    procedure cbFontNameSelect(Sender: TObject);
    procedure cbFontSizeSelect(Sender: TObject);
    procedure cbFontColorSelect(Sender: TObject);
  private
    { Private declarations }
    FOldFontName: string;
  public
    { Public declarations }
    constructor Create(Aowner: TComponent); override;
    procedure getLangRes;
  end;

implementation
uses
  CommonUtils;//, gnugettext;
{$R *.dfm}

{* 下面方法取得可用的字体号 *}
var
  VRES: Integer;
const
  MaxStdSizes = 16;

function EnumFontFamiliesProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data:Pointer): Integer; stdcall;

  procedure AddToList(const aValue:String);
  var
    j: Integer;
    c: Boolean;
  begin
    j := 0;
    c := False;
    with TStrings(Data) do
    begin
      while (j < Count) and not c do
      if StrToInt(aValue) >= StrToInt(Strings[j]) then
        Inc(j)
      else
        c := True;
      Insert(j, aValue);
    end;
  end;   // Local

var
  i: Integer;
  c: String;
const
  csizes: array[0..MaxStdSizes-1] of Integer=(8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);
begin    // Main
  result:=0;
  with TStrings(Data) do
  begin
    if (FontType and TRUETYPE_FONTTYPE=TRUETYPE_FONTTYPE) or (FontType in [0, 2]) then
    begin
      For i := 0 to (MaxStdSizes - 1) do
        Add(IntToStr(Csizes[i]));
      result:=0;
    end
    else if (FontType and RASTER_FONTTYPE=RASTER_FONTTYPE) then
      with TextMetric do
      begin
        c := IntToStr(Round((tmHeight - tmInternalLeading) * 72 / VRES));
        if IndexOf(c) = -1 then
          AddToList(c);
        result := 1;
      end;
  end;
end;

procedure GetFontSizeList(FontName:String; SizeList: TStrings);
var
  buffer:array[0..255] of Char;
  DC:HDC;
begin
  SizeList.Clear;
  DC := GetDC(0);
  StrPCopy(Buffer, FontName);
  vres := GetDeviceCaps(DC, LOGPIXELSY);
  EnumFontFamilies(DC, Buffer, @EnumFontFamiliesProc, LongInt(SizeList));
  ReleaseDC(0, DC);
end;

{ TFrameFont }

procedure TFrameFont.getLangRes;
begin              
  lblFontName.Caption := pubGet(401);  
  lblFontSize.Caption := pubGet(402);
  lblFontColor.Caption := pubGet(403);
  chkBold.Caption := pubGet(404);
  chkItalic.Caption := pubGet(405);
  chkUnderline.Caption := pubGet(406);
  chkStrikethrough.Caption := pubGet(407);
  pnlFontTest.Caption := pubGet(408);     

  cbFontName.Hint := pubGet(501);
  cbFontSize.Hint := pubGet(502);
  cbFontColor.Hint := pubGet(503);
  pnlFontTest.Hint := pubGet(504);
  
end;

constructor TFrameFont.Create(Aowner: TComponent);
begin
  inherited;
  //ToDo: TranslateComponent(self);  多语言处理
  getLangRes;
  //为里面的字体赋值
  cbFontName.Items.Assign(Screen.Fonts);
  cbFontName.ItemIndex := cbFontName.Items.IndexOf(Def_FontName);
  cbFontNameSelect(nil);   
  FOldFontName := cbFontName.Text;
end;

procedure TFrameFont.cbFontNameExit(Sender: TObject);
begin
  if cbFontName.Items.IndexOf(cbFontName.Text) = -1 then
  begin
    pnlFontTest.Font.Name := FOldFontName;
    cbFontName.ItemIndex := cbFontName.Items.IndexOf(FOldFontName);
  end;
  FOldFontName := cbFontName.Text;
end;

procedure TFrameFont.chkItalicClick(Sender: TObject);
var
  FStyle: TFontStyles;
begin
  FStyle := pnlFontTest.Font.Style;
  if chkItalic.Checked then
    Include(FStyle, fsItalic)
  else
    Exclude(FStyle, fsItalic);
  pnlFontTest.Font.Style := FStyle;
end;

procedure TFrameFont.chkBoldClick(Sender: TObject);
var
  FStyle: TFontStyles;
begin
  FStyle := pnlFontTest.Font.Style;
  if chkBold.Checked then
    Include(FStyle, fsBold)
  else
    Exclude(FStyle, fsBold);
  pnlFontTest.Font.Style := FStyle;
end;

procedure TFrameFont.chkStrikethroughClick(Sender: TObject);
var
  FStyle: TFontStyles;
begin
  FStyle := pnlFontTest.Font.Style;
  if chkStrikethrough.Checked then
    Include(FStyle, fsStrikeOut)
  else
    Exclude(FStyle, fsStrikeOut);
  pnlFontTest.Font.Style := FStyle;
end;

procedure TFrameFont.chkUnderlineClick(Sender: TObject);
var
  FStyle: TFontStyles;
begin
  FStyle := pnlFontTest.Font.Style;
  if chkUnderline.Checked then
    Include(FStyle, fsUnderline)
  else
    Exclude(FStyle, fsUnderline);
  pnlFontTest.Font.Style := FStyle;
end;

procedure TFrameFont.cbFontNameSelect(Sender: TObject);
var
  SizeIndex: Integer;
begin
  if cbFontName.ItemIndex = - 1 then Exit;
  cbFontSize.Items.Clear;
  GetFontSizeList(cbFontName.Items[cbFontName.ItemIndex], cbFontSize.Items);
  if cbFontSize.Items.Count > 0 then
  begin
    SizeIndex := cbFontSize.Items.IndexOf(IntToStr(Def_FontSize));
    if SizeIndex <> - 1 then
      cbFontSize.ItemIndex := SizeIndex
    else
      cbFontSize.ItemIndex := 0;
  end;
  pnlFontTest.Font.Name := cbFontName.Text;
  cbFontSizeSelect(nil);
end;

procedure TFrameFont.cbFontSizeSelect(Sender: TObject);
begin
  if cbFontSize.ItemIndex <> -1 then
    pnlFontTest.Font.Size := StrToInt(cbFontSize.Items[cbFontSize.ItemIndex]);
end;

procedure TFrameFont.cbFontColorSelect(Sender: TObject);
begin
  pnlFontTest.Font.Color := cbFontColor.Selected;
end;

end.