Question

我有一些代码描绘了一组放置在TImage之上的控件。然后我抓住TImage的MakeScreenshot来保存文件。这现在完美无缺。我现在正在努力改变一个或多个标签/文本样式控件的字体属性。无论我尝试什么，标签都不会改变。以下是我的示例代码： -

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;

如何设置标签的字体以便它们被正确绘制并因此包含在屏幕截图中？

此致 Anthoni

Answer 1

在firemonkey TLabel属性中设置Font.Family和Font.Size的样式。如果要在代码中更改字体大小或族，则需要在此属性上禁用样式。要更改此设置，请正确设置StyledSettings属性。

示例：

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

Answer 2

好的，所以这里有什么对我有用我需要做的是将想要显示的内容包装在TRectangle内的图像中，然后将Rectangle绘制到图像上。我还必须更改Rectangle内控件的默认属性，例如我必须更改字体名称和字体大小。然后我可以把它改成我之后想要的东西。还需要确保显示想要快照的图像的表单是可见的（form.show）

这对我有用，并且在公共场合使用，我没有任何缺点。

Pascal源代码：

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

希望这有助于遇到此问题的其他人。

此致 Anthoni

PS：抱歉忘记添加，请忽略AVConvertor组件，即允许我创建组件的实际视频（mp4），以便我可以将其与另一个合并。

如何以编程方式更改Firemonkey控件中的字体属性

2 个答案: