转载：Delphi图片上写水印文字函数

Delphi图片上写水印文字函数

https://blog.csdn.net/lqena/article/details/22858847

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  untImagePaintText;
{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
begin
  if OpenDialog1.Execute then
  begin
    Image1.Picture.LoadFromFile(OpenDialog1.FileName);
    sl := TStringList.Create;
    sl.Add('你好，彭XX');
    sl.Add('你好，习XX');
    if ImagePaintText(OpenDialog1.FileName, 20, 30, sl) then
      Image1.Picture.LoadFromFile(OpenDialog1.FileName);
  end;
end;

end.

View Code

unit untImagePaintText;

interface

uses
  jpeg, Classes, Graphics, SysUtils;

/// <summary>
/// 打开一幅图片(jpg,bmp)在上写入文字
/// </summary>
/// <param name="FilePath">图片路径</param>
/// <param name="X">文字左边距</param>
/// <param name="Y">文字上边距</param>
/// <param name="Texts">写入文字内容</param>
/// <returns>写入是否成功</returns>
function ImagePaintText(FilePath: string; X, Y: Integer; Texts: TStringList): Boolean;

implementation

function JpgToBmp(FilePath: string): string;
var
  MyJPEG: TJPEGImage;
  MyBMP: TBitmap;
  s: string;
begin
  Result := '';
  s := copy(FilePath, 1, Length(FilePath) - 4) + FormatDateTime('YYYYMMDDhhmmsszzz', Now) + '.bmp';
  MyJPEG := TJPEGImage.Create;
  with MyJPEG do
  begin
    LoadFromFile(FilePath);
    MyBMP := TBitmap.Create;
    with MyBMP do
    begin
      Width := MyJPEG.Width;
      Height := MyJPEG.Height;
      Canvas.Draw(0, 0, MyJPEG);
      SaveToFile(s);
      Result := s;
      Free;
    end;
    Free;
  end;
end;

function BmpToJpg(FilePath, FilePathJpg: string): string;
var
  Jpg: TJpegImage;
  BMP: TBitMap;
  s: string;
begin
  Jpg := TJpegImage.Create;
  BMP := TBitmap.Create;
  BMP.LoadFromFile(FilePath);
  Jpg.Assign(BMP);
  Jpg.SaveToFile(FilePathJpg);
  BMP.Free;
  Jpg.Free;
end;

function ImagePaintText(FilePath: string; X, Y: Integer; Texts: TStringList): Boolean;
var
  Pic: TPicture;
  fp: string;
  i: Integer;
begin
  Result := false;
  if UpperCase(ExtractFileExt(FilePath)) = UpperCase('.jpg') then
    fp := JpgToBmp(FilePath)
  else
    fp := FilePath;
  Pic := TPicture.Create;
  try
    Pic.LoadFromFile(fp);
    with Pic.Bitmap.Canvas do
    begin
      Brush.Style := bsClear;
      Font.Size := 15;
      Font.Color := clWhite;
      Font.Name := '黑体';
      for i := 0 to Texts.Count - 1 do
        TextOut(X, Y + (i * 22), Texts[i])
    end;

    if UpperCase(ExtractFileExt(FilePath)) = UpperCase('.jpg') then
    begin
      Pic.SaveToFile(fp);
      BmpToJpg(fp, FilePath);
      DeleteFile(fp);
    end
    else
      Pic.SaveToFile(FilePath);
  finally
    FreeAndNil(Pic);
  end;

  Result := True;
end;

end.

View Code