Delphi图片上写水印文字函数

本文整理自网络，侵删。

 
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.
 
//首引用单元untImagePaintText
//调用
//procedure TForm1.btn1Click(Sender: TObject);
//var
//    sl: TStringList;
//begin
//    if dlgOpen1.Execute then
//    begin
//        img1.Picture.LoadFromFile(dlgOpen1.FileName);
//        sl := TStringList.Create;
//        sl.Add('你好，彭XX');
//        sl.Add('你好，习XX');
//        if ImagePaintText(dlgOpen1.FileName, 20, 30, sl) then
//        img1.Picture.LoadFromFile(dlgOpen1.FileName);
//    end;
//end;

――――――――――――――――

原文链接：https://blog.csdn.net/lqena/article/details/22858847
 

相关阅读 >>

Delphi 正则表达式的匹配模式

Delphi windows 编程[2] - 学习窗体生成的过程二

Delphi 以低用户权限启动一个进程.比如vista或者win7中的ie

Delphi中使用activex的一些心得

Delphi 获取汉字拼音首字母

Delphi 怎么不注册 dll 就调用 com

Delphi 当前日期的加减运算

Delphi 递归获取文件夹大小

Delphi 为数字补充前缀0

Delphi listbox防止添加重复

更多相关阅读请进入《Delphi》频道 >>

转载请注明出处：木庄网络博客 » Delphi图片上写水印文字函数