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;