Linux下用lazarus编写的软件安装自带字体到指定文件夹

lazarus使用报表时遇到某些电脑缺少字体,造成打印出来的效果有差异,为避免这个问题,可以手工安装字体,也可以用程序拷贝字体到指定的文件夹(/usr/share/fonts或~/.local/share/fonts),如果拷贝到~/.local/share/fonts程序不需要root权限,以下代码将应用程序font目录的所有ttf字体文件拷贝到~/.local/share/fonts
直接上代码:

uses FileUtil,LazFileUtils;//要添加这2个单元

procedure TForm1.CopyDirFile(const SourceDirName,DestDir: string);

var
  i, j: integer;
  FilesFoundToCopy : TStringList;
  SourceDirectoryAndFileName, SubDirStructure, FinalisedDestDir, FinalisedFileName : string;
  SourceDir:string;
begin
  SourceDir:= SourceDirName;
  SubDirStructure := '';
  FinalisedDestDir := '';

  SetCurrentDir(SourceDirName);
  FilesFoundToCopy := FindAllFiles(SourceDirName, '*', True);

  try
    for i := 0 to FilesFoundToCopy.Count -1 do
    begin
      SourceDirectoryAndFileName := ChompPathDelim(CleanAndExpandDirectory(FilesFoundToCopy.Strings[i]));

      SubDirStructure := IncludeTrailingPathDelimiter(ExtractFileDir(SourceDirectoryAndFileName));
      if SourceDir+'/'=SubDirStructure then SubDirStructure:='';
      j:= pos(SourceDir,SubDirStructure)+length(SourceDir);
      if pos(SourceDir,SubDirStructure)>0 then
         SubDirStructure:=Copy(SubDirStructure, j,length(SubDirStructure));

      FinalisedDestDir :=DestDir+SubDirStructure;
      FinalisedFileName := ExtractFileName(FilesFoundToCopy.Strings[i]);

      if not DirPathExists(FinalisedDestDir) then
      begin
        ForceDirectories(FinalisedDestDir);
      end;

      if (pos('.ttf',SourceDirectoryAndFileName)>0) then//只拷贝ttf字体文件
        FileUtil.CopyFile(SourceDirectoryAndFileName, FinalisedDestDir+FinalisedFileName, true);
    end;
  finally
    FilesFoundToCopy.free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);

begin
  //只拷贝程序font文件夹的所有ttf字体文件
  CopyDirFile(ExtractFilePath(ParamStr(0))+'font/',ConcatPaths([GetUserDir, '.local', 'share', 'fonts'])+'/');
end;