WinAPI: CreateFontIndirect - 根据字体结构建立逻辑字体

//声明:

CreateFontIndirect(

  const p1: TLogFont {字体结构}

): HFONT;            {返回新字体指针}



//TLogFont 是 tagLOGFONTA 结构的重定义:

tagLOGFONTA = packed record

  lfHeight: Longint;      {字体高度}

  lfWidth: Longint;       {字体平均宽度}

  lfEscapement: Longint;  {角度, 单位是 1/10 度}

  lfOrientation: Longint; {基线角度}

  lfWeight: Longint;      {粗体, 取值: 0-1000}

  lfItalic: Byte;         {斜体}

  lfUnderline: Byte;      {下划线}

  lfStrikeOut: Byte;      {删除线}

  lfCharSet: Byte;        {字符集}

  lfOutPrecision: Byte;   {输出精度}

  lfClipPrecision: Byte;  {剪裁精度}

  lfQuality: Byte;        {输出质量}

  lfPitchAndFamily: Byte; {间距及字族}

  lfFaceName: array[0..LF_FACESIZE - 1] of AnsiChar; {字样名称}

end;


 
   




//例1:

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

var

  FontInfo: TLogFont; {声明字体结构}

  FH1,FH2: HFONT;     {声明字体句柄}

const

  str = '万一的 Delphi 博客';

begin

  {定义字体特征}

  FontInfo.lfHeight := 0;     {赋值 0, 系统自动给一个值}

  FontInfo.lfWidth := 0;      {赋值 0, 系统自动给一个值}

  FontInfo.lfEscapement := 0; {无角度}

  FontInfo.lfWeight := 500;   {中等加粗}

  FontInfo.lfItalic := 0;     {非斜体}

  FontInfo.lfUnderline := 0;  {无下划线}

  FontInfo.lfStrikeOut := 0;  {无删除线}

  FontInfo.lfFaceName := '宋体';

  

  FH1 := CreateFontIndirect(FontInfo);

  FH2 := SelectObject(Canvas.Handle, FH1);

  {用 CreateFontIndirect 建立逻辑字体; 用 SelectObject 选人设备; 并返回字体句柄}

  

  TextOut(Canvas.Handle, X, Y, str, Length(str));

  

  DeleteObject(FH1);

  DeleteObject(FH2);

end;


 
   




//效果图:

---

//例2: 扁字

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

var

  FontInfo: TLogFont; 

  FH1,FH2: HFONT; 

const

  str = '万一的 Delphi 博客';

begin

  FontInfo.lfHeight := 0;     

  FontInfo.lfWidth := 12;     {只修改了此处} 

  FontInfo.lfEscapement := 0; 

  FontInfo.lfWeight := 500;   

  FontInfo.lfItalic := 0;     

  FontInfo.lfUnderline := 0;  

  FontInfo.lfStrikeOut := 0;  

  FontInfo.lfFaceName := '宋体';

  

  FH1 := CreateFontIndirect(FontInfo);

  FH2 := SelectObject(Canvas.Handle, FH1);



  TextOut(Canvas.Handle, X, Y, str, Length(str));



  DeleteObject(FH1);

  DeleteObject(FH2);

end;


 
   




//效果图:

---

//例3: 长字

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

var

  FontInfo: TLogFont; 

  FH1,FH2: HFONT;   

const

  str = '万一的 Delphi 博客';

begin

  FontInfo.lfHeight := 32;    {修改了此处}  

  FontInfo.lfWidth := 12;     

  FontInfo.lfEscapement := 0; 

  FontInfo.lfWeight := 500;   

  FontInfo.lfItalic := 0;     

  FontInfo.lfUnderline := 0;  

  FontInfo.lfStrikeOut := 0;  

  FontInfo.lfFaceName := '宋体';

  

  FH1 := CreateFontIndirect(FontInfo);

  FH2 := SelectObject(Canvas.Handle, FH1);



  TextOut(Canvas.Handle, X, Y, str, Length(str));



  DeleteObject(FH1);

  DeleteObject(FH2);

end;


 
   




//效果图:

---

//例4: 旋转

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

var

  FontInfo: TLogFont; 

  FH1,FH2: HFONT;       

const

  str = '万一的 Delphi 博客';

begin

  FontInfo.lfHeight := 0;      

  FontInfo.lfWidth := 0;     

  FontInfo.lfEscapement := 450; {修改了此处}

  FontInfo.lfWeight := 500;   

  FontInfo.lfItalic := 0;     

  FontInfo.lfUnderline := 0;  

  FontInfo.lfStrikeOut := 0;  

  FontInfo.lfFaceName := '宋体';

  

  FH1 := CreateFontIndirect(FontInfo);

  FH2 := SelectObject(Canvas.Handle, FH1);



  TextOut(Canvas.Handle, X, Y, str, Length(str));



  DeleteObject(FH1);

  DeleteObject(FH2);

end;


 
   




//效果图:

---

//一个利用角度的示例:

procedure TForm1.FormPaint(Sender: TObject);

var

  FontInfo: TLogFont; 

  FH1,FH2: HFONT; 

  x,y,i: Integer;

const

  str = '万一的 Delphi 博客';

begin

  FontInfo.lfHeight := 0; 

  FontInfo.lfWidth := 0;     

  FontInfo.lfEscapement := 0; 

  FontInfo.lfWeight := 1000;   

  FontInfo.lfItalic := 0;     

  FontInfo.lfUnderline := 0;  

  FontInfo.lfStrikeOut := 0;  

  FontInfo.lfFaceName := '宋体';



  x := ClientWidth div 2;

  y := ClientHeight div 2;



  SetBkMode(Canvas.Handle, TRANSPARENT);



  i := 0;

  while i<360 do

  begin

    FontInfo.lfEscapement := i * 10;

    FH1 := CreateFontIndirect(FontInfo);

    FH2 := SelectObject(Canvas.Handle, FH1);

    TextOut(Canvas.Handle, X, Y, str, Length(str));

    Inc(i,10);

  end;

 

  DeleteObject(FH1);

  DeleteObject(FH2);

end;


 
   




//效果图:

---