Как программно изменить свойства шрифта в элементах управления Firemonkey

Question

Как программно изменить свойства шрифта в элементах управления Firemonkey

У меня есть код, который рисует набор элементов управления, наложенных поверх TImage. Затем я беру MakeScreenshot TImage, чтобы сохранить файл. Теперь это работает отлично. Теперь я борюсь с тем, чтобы изменить свойства шрифта одного или нескольких элементов управления стилями надписей / текста. Что бы я ни старался, ярлык не меняется. Ниже приведен мой пример кода:-

procedure TfrmSnapshot.Process;
var
  LRect1, LRect2, LRect3, LRect4: TRectF;
  X, Y, W, H: Integer;

begin
//
X := Round(Label1.Position.X);
Y := Round(Label1.Position.Y);
W := Round(X + Label1.Width);
H := Round(Y + Label1.Height);
LRect1.Create(X, Y, W, H);

X := Round(Label2.Position.X);
Y := Round(Label2.Position.Y);
W := Round(X + Label2.Width);
H := Round(Y + Label2.Height);
LRect2.Create(X, Y, W, H);

X := Round(Label3.Position.X);
Y := Round(Label3.Position.Y);
W := Round(X + Label3.Width);
H := Round(Y + Label3.Height);
LRect3.Create(X, Y, W, H);

X := Round(Rect1.Position.X);
Y := Round(Rect1.Position.Y);
W := Round(X + Rect1.Width);
H := Round(Y + Rect1.Height);
LRect4.Create(X, Y, W, H);

Label1.Text := fTitle;
Label1.Font.Size := 40.0;
Label2.Text := fSub;
Label3.Text := fSite;

With imgSnap.Bitmap Do
Begin
  Label1.Font.Size = 40; //Does not work
  Label1.Font.Family = 'Arial'; //Does not work
  Label1.PaintTo(Canvas, LRect1);
  Label2.PaintTo(Canvas, LRect2);
  Label3.PaintTo(Canvas, LRect3);
  Rect1.PaintTo(Canvas, LRect4);
End;

imgSnap.MakeScreenshot.SaveToFile('test.jpg');
end;

Как настроить шрифты надписей так, чтобы они правильно рисовались и, таким образом, включались в скриншот?

С уважением, Антони

2

delphi fonts firemonkey firemonkey-fm2

Источник

user298882 14 дек '12 в 18:11

2 ответа

Решение

В Firemonkey TLabel используются стили Font.Family и Font.Size. Если вы хотите изменить размер шрифта или семейство в коде, вам нужно отключить стилизацию для этих свойств. Чтобы изменить это, установите правильно свойство StyledSettings.

пример:

Label1.StyledSettings:=Label1.StyledSettings -[TStyledSetting.ssFamily,TStyledSetting.ssSize]

10

Источник

user1761106 28 дек '12 в 14:09

Другие вопросы по тегам delphi fonts firemonkey firemonkey-fm2

user298882 03 янв '13 в 07:46 2013-01-03 07:46 · Accepted Answer · 2013-01-03 07:46

Итак, вот что работает для меня.
Мне нужно было обернуть то, что я хотел отобразить на изображении внутри TRectangle, а затем нарисовать прямоугольник на изображении. Мне также пришлось изменить свойства элемента управления по умолчанию внутри прямоугольника, например, мне пришлось изменить имя шрифта и размер шрифта. Тогда я мог бы изменить их на то, что я хотел после этого. Также необходимо убедиться, что форма, отображающая изображение, хочет, чтобы моментальный снимок был виден (form.show)

Это работает для меня и находится в общественном пользовании, и у меня не было ошибок с ним.

Исходный код Паскаля:

unit FormSnap;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.UIConsts, System.Rtti, System.Classes,
  System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Objects, FMX.Layouts, AVConverter;

type
  TfrmSnapshot = class(TForm)
    lblMainTitle: TLabel;
    lblSubTitle: TLabel;
    lblWebsite: TLabel;
    imgSnap: TImage;
    RectMainTitle: TRectangle;
    RectSubTitle: TRectangle;
    RectWebsite: TRectangle;
    AVConvert: TAVConverter;

    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
    procedure FormDestroy(Sender: TObject);
    procedure AVConvertComplete(Sender: TObject);

  private
    fBitmap: TBitmap;
    fSub: String;
    fTitle: String;
    fSite: String;
    fShown, fProcessingVideo: Boolean;
    fSaveTo, fSaveVideoTo: String;
    fColorBack: Cardinal;
    fColorSub: Cardinal;
    fColorTitle: Cardinal;
    fColorSite: Cardinal;
    fOnReady, fOnFinished: TNotifyEvent;

    Procedure zp_CreateImage;
    Function zp_GetLRect(Const AControl: TControl): TRectF;
  public
    Property ColorBack: Cardinal read fColorBack write fColorBack;
    Property ColorTitle: Cardinal read fColorTitle write fColorTitle;
    Property ColorSub: Cardinal read fColorSub write fColorSub;
    Property ColorWebsite: Cardinal read fColorSite write fColorSite;
    Property SaveTo: String read fSaveTo write fSaveTo;
    Property SaveVideoTo: String read fSaveVideoTo write fSaveVideoTo;
    Property SlideTitle: String read fTitle write fTitle;
    Property SlideSubTitle: String read fSub write fSub;
    Property SlideWebsite: String read fSite write fSite;

    Procedure Process;
    Procedure ProcessVideo;
    Property OnFinished: TNotifyEvent read fOnFinished write fOnFinished;
    Property OnReady: TNotifyEvent read fOnReady write fOnReady;
  end;

var
  frmSnapshot: TfrmSnapshot;

implementation
Uses uShared.Project, AVCodec, AVLib;

{$R *.fmx}
procedure TfrmSnapshot.AVConvertComplete(Sender: TObject);
begin
  //
  if Pos('temp', Lowercase(fSaveTo)) <> 0 then
    DeleteFile(fSaveTo);

  if Assigned(fOnFinished) then
    fOnFinished(Self);
end;

procedure TfrmSnapshot.FormCreate(Sender: TObject);
begin
  //
  imgSnap.Bitmap := TBitmap.Create(Round(imgSnap.Width), Round(imgSnap.Height));
  fColorBack := claYellow;
  fColorSub := claBlack;
  fColorTitle := claBlack;
  fColorSite := claBlue;
  fTitle := 'Simple slide';
  fSub := 'Another slide';
  fSite := '';

  fBitmap := TBitmap.Create(0, 0);
  Height := 360;
  Width := 640;
end;

procedure TfrmSnapshot.FormDestroy(Sender: TObject);
begin
  //
  fBitmap.Free;
end;

procedure TfrmSnapshot.FormPaint(Sender: TObject; Canvas: TCanvas; const ARect: TRectF);
begin
  //
  if (Assigned(fOnReady)) AND (NOT fShown) then
  Begin
    fOnReady(Self);
    fShown := True;
  End;
end;

procedure TfrmSnapshot.Process;
begin
  //
  fProcessingVideo := False;
  zp_CreateImage;
  if Assigned(fOnFinished) then
    fOnFinished(Self);
end;

procedure TfrmSnapshot.ProcessVideo;
begin
  //
  fProcessingVideo := True;
  fSaveTo := Project.FolderTemp + 'snap.jpg';

  With AVConvert Do
  Begin
    if State <> csRunning then
    Begin
      zp_CreateImage;
      fBitmap.LoadFromFile(fSaveTo);

      ConvertOptions.InputFormats.Text:='bmpcap';
      InputFiles.Add(IntToStr(Integer(fBitmap)));
      OutputFiles.Text:= fSaveVideoTo;
      ConvertOptions.RecordingTime:=30*AV_TIME_BASE;
      Convert();
    End;
  End;
end;

procedure TfrmSnapshot.zp_CreateImage;
begin
  //
  RectMainTitle.Fill.Color := fColorBack;
  RectSubTitle.Fill.Color := fColorBack;
  RectWebsite.Fill.Color := fColorBack;

  With lblMainTitle Do
  Begin
    FontColor := fColorTitle;
    Text := fTitle;
  End;

  With lblSubTitle Do
  Begin
    FontColor := fColorSub;
    Text := fSub;
  End;

  With lblWebsite Do
  Begin
    FontColor := fColorSite;
    Text := fSite;
  End;

  With imgSnap.Bitmap Do
  Begin
    Clear(fColorBack);
    RectMainTitle.PaintTo(Canvas, zp_GetLRect(RectMainTitle));
    RectSubTitle.PaintTo(Canvas, zp_GetLRect(RectSubTitle));
    RectWebsite.PaintTo(Canvas, zp_GetLRect(RectWebsite));
  End;

  imgSnap.MakeScreenshot.SaveToFile(fSaveTo);
end;

function TfrmSnapshot.zp_GetLRect(const AControl: TControl): TRectF;
var
  X, Y, W, H: Single;

begin
  //
  X := AControl.Position.X;
  Y := AControl.Position.Y;
  W := X + AControl.Width;
  H := Y + AControl.Height;
  Result := TRectF.Create(X, Y, W, H);
end;

end.

Исходный код формы:

object frmSnapshot: TfrmSnapshot
  Left = 0
  Top = 0
  BorderStyle = bsNone
  ClientHeight = 360
  ClientWidth = 640
  Position = poScreenCenter
  FormFactor.Width = 1920
  FormFactor.Height = 1080
  FormFactor.Devices = [dkDesktop]
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnPaint = FormPaint
  object imgSnap: TImage
    Align = alClient
    Height = 360.000000000000000000
    Width = 640.000000000000000000
  end
  object RectMainTitle: TRectangle
    Height = 90.000000000000000000
    Position.X = 8.000000000000000000
    Position.Y = 60.000000000000000000
    Stroke.Kind = bkNone
    Width = 625.000000000000000000
    object lblMainTitle: TLabel
      Align = alClient
      Font.Family = 'Impact'
      Font.Size = 40.000000000000000000
      FontColor = claAliceblue
      StyledSettings = []
      Height = 90.000000000000000000
      Text = 'I am just some silly information. Testing Wordwrap'
      TextAlign = taCenter
      Width = 625.000000000000000000
    end
  end
  object RectSubTitle: TRectangle
    Height = 90.000000000000000000
    Position.X = 8.000000000000000000
    Position.Y = 200.000000000000000000
    Stroke.Kind = bkNone
    Width = 625.000000000000000000
    object lblSubTitle: TLabel
      Align = alClient
      Font.Family = 'Impact'
      Font.Size = 20.000000000000000000
      FontColor = claAliceblue
      StyledSettings = []
      Height = 90.000000000000000000
      Text = 'More Information'
      TextAlign = taCenter
      Width = 625.000000000000000000
    end
  end
  object RectWebsite: TRectangle
    Height = 17.000000000000000000
    Position.Y = 340.000000000000000000
    Stroke.Kind = bkNone
    Width = 640.000000000000000000
    object lblWebsite: TLabel
      Align = alClient
      Font.Family = 'Impact'
      FontColor = claAliceblue
      StyledSettings = [ssSize]
      Height = 17.000000000000000000
      Text = 'Just a website'
      TextAlign = taCenter
      Width = 640.000000000000000000
    end
  end
  object AVConvert: TAVConverter
    ConvertOptions.LimitFileSize = 9223372036854775807
    ConvertOptions.AudioOptions.AudioChannels = 0
    ConvertOptions.AudioOptions.AudioSampleRate = 0
    ConvertOptions.AudioOptions.AudioVolume = 256
    ConvertOptions.AudioOptions.AudioSyncMethod = 0
    ConvertOptions.AudioOptions.AudioDisable = False
    ConvertOptions.AudioOptions.AudioSampleFmt = sfAuto
    ConvertOptions.AudioOptions.AudioStreamCopy = False
    ConvertOptions.AudioOptions.AudioCodecTag = 0
    ConvertOptions.AudioOptions.AudioQScale = -99999.000000000000000000
    ConvertOptions.AudioOptions.AudioDriftThreshold = 0.100000001490116100
    ConvertOptions.AudioOptions.Bitrate = 0
    ConvertOptions.AudioOptions.MaxFrames = 9223372036854775807
    ConvertOptions.SubtitleOptions.SubtitleDisable = False
    ConvertOptions.SubtitleOptions.SubtitleCodecTag = 0
    ConvertOptions.VideoOptions.FrameWidth = 0
    ConvertOptions.VideoOptions.FrameHeight = 0
    ConvertOptions.VideoOptions.VideoDisable = False
    ConvertOptions.VideoOptions.VideoStreamCopy = False
    ConvertOptions.VideoOptions.VideoCodecTag = 0
    ConvertOptions.VideoOptions.IntraOnly = False
    ConvertOptions.VideoOptions.TopFieldFirst = -1
    ConvertOptions.VideoOptions.ForceFPS = False
    ConvertOptions.VideoOptions.FrameRate.num = 0
    ConvertOptions.VideoOptions.FrameRate.den = 0
    ConvertOptions.VideoOptions.MeThreshold = 0
    ConvertOptions.VideoOptions.Deinterlace = False
    ConvertOptions.VideoOptions.Pass = 0
    ConvertOptions.VideoOptions.MaxFrames = 2147483647
    ConvertOptions.VideoOptions.Bitrate = 0
    ConvertOptions.MuxerOptions.MuxPreload = 0.500000000000000000
    ConvertOptions.StartTime = 0
    ConvertOptions.RecordingTime = 9223372036854775807
    OnComplete = AVConvertComplete
    Left = 304
    Top = 200
  end
end

Надеюсь, что это помогает кому-то еще, кто имеет эту проблему.

С уважением, Антони

PS: Извините, забыл добавить, пожалуйста, игнорируйте компонент AVConvertor, который позволяет мне создавать фактическое видео компонента (mp4), чтобы я мог объединить его с другим.