TFont,TLogFont使用

TFont,TLogFont使用

代码

procedure RotateText(ACanvas:TCanvas);
var
LF: TLogFont;
aFont: TFont;
begin
with ACanvas do
begin
Font.Name : = ' Arial ' ;
Font.Size : = 18 ;
aFont : = TFont.Create;
try
aFont.Assign(Font) ;
GetObject(aFont.Handle, sizeof(LF), @LF) ;
LF.lfEscapement : = 1800 ; // 360 * 10
LF.lfOrientation : = 0 ;
aFont.Handle : = CreateFontIndirect(LF) ;
Font.Assign(aFont) ;
finally
aFont.Free;
end ;
TextOut( 20 , 100 , ' Rotated Text! ' ) ;
end ;
end ;

procedure SetLogicFont(ACanvas: TCanvas);
var
LF: TLogFont;
begin
with LF,ACanvas.Font do
begin
lfHeight : = - 12 ;
lfWidth : = 6 ;
lfEscapement : = 0 ;
lfOrientation : = 0 ;
lfWeight : = 400 ;
lfItalic : = 0 ;
lfUnderline : = 0 ;
lfStrikeOut : = 0 ;
lfCharSet : = 129 ;
lfOutPrecision : = 0 ;
lfClipPrecision : = 0 ;
lfQuality : = 0 ;
lfPitchAndFamily : = 0 ;
lfFaceName : = ' Courier New ' ;
end ;
ACanvas.Font.Handle : = CreateFontIndirect(LF);
end ;

procedure TForm1.btGetFontClick(Sender: TObject);
var
h: THandle;
LF: TLogFont;
hCurrFont,hNewFont,hOldFont: THandle;
begin
h : = edtFont.Handle;
hCurrFont : = SendMessage(h, WM_GETFONT, 0 , 0 );
if GetObject(hCurrFont,SizeOf(LF),Addr(LF)) > 0 then
begin
Memo1.Lines.Add( ' LF.lfHeight: ' + inttostr(LF.lfHeight));
Memo1.Lines.Add( ' LF.lfWidth: ' + inttostr(LF.lfWidth));
Memo1.Lines.Add( ' LF.lfEscapement: ' + inttostr(LF.lfEscapement));
Memo1.Lines.Add( ' LF.lfOrientation: ' + inttostr(LF.lfOrientation));
Memo1.Lines.Add( ' LF.lfWeight: ' + inttostr(LF.lfWeight));
Memo1.Lines.Add( ' LF.lfItalic: ' + inttostr(LF.lfItalic));
Memo1.Lines.Add( ' LF.lfUnderline: ' + inttostr(LF.lfUnderline));
Memo1.Lines.Add( ' LF.lfStrikeOut: ' + inttostr(LF.lfStrikeOut));
Memo1.Lines.Add( ' LF.lfCharSet: ' + inttostr(LF.lfCharSet));
Memo1.Lines.Add( ' LF.lfOutPrecision: ' + inttostr(LF.lfOutPrecision));
Memo1.Lines.Add( ' LF.lfClipPrecision: ' + inttostr(LF.lfClipPrecision));
Memo1.Lines.Add( ' LF.lfQuality: ' + inttostr(LF.lfQuality));
Memo1.Lines.Add( ' LF.lfPitchAndFamily: ' + inttostr(LF.lfPitchAndFamily));
Memo1.Lines.Add( ' LF.lfFaceName: ' + LF.lfFaceName);

hNewFont : = CreateFontIndirect(LF);
hOldFont : = SelectObject(edtTest.Handle, hNewFont);
SendMessage(edtTest.Handle, WM_SETFONT, hNewFont, 1 );
DeleteObject(hOldFont);
// DeleteObject(hNewFont);
end ;
end ;

procedure TForm1.btnSetFontClick(Sender: TObject);
var
aFont: TFont;
begin
if FontDialog1.Execute then
aFont : = FontDialog1.Font;
SendMessage(edtFont.Handle, WM_SETFONT, aFont.Handle, 0 );
end ;

 

转载于:https://www.cnblogs.com/Jekhn/archive/2010/12/30/1921697.html