Question

VB 给图片添加文字水印

要求：
1. 最好是模块，直接调用，比如： AddTxtToPicAndSave(Picture as PictureBox,strText as string, x as long,y as long,SFile as string,SaveType as integer)，其中 Picture为图片框控件名称，strText为待添加上去的文字，xy分别为待添加上去的文字在图片中的左上角坐标, SFile 为保存为的新图像文件名，SaveType 为保存的图像类型，比如jgp或bmp等。
2. 不需要透明度
3. 文字的字体、颜色、字号、字形等通过其他控件来指定和调节
4. 保存为jpg格式的，所得的新图片中，添加上去的文字是清晰的，不能模糊；直接保存为bmp格式当然是清晰的，但文件大小太大。

真心讨教！满足要求功能要求的话，采纳后再嘉奖。
采用 Picture.Print strText 将文字打印到图片上，然后另存为非bmp格式后，文字就变模糊了，肯定不是这种这么简单的方法的。
就像Photoshop这样，在背景图上添加文字图层，然后拼合图层之后，再另存为jpg格式的图像，所得的jpg格式图像文件的大小是最小的，并且添加上去的文字并不因为保存为jpg格式就变模糊仍然是非常清晰的，就想到达这种效果，不知道用什么方法或者控件能实现这种效果。反正目前能尝试的方法都达不到这种效果，采用GDI方式另存为jpg格式，文字就会变模糊，另存为其他方式，文字可能不变模糊，但所得文件大小增大几十倍，不可取。 哪位大侠能赐教可行的呀！
有一个朋友调试出来了一种方法，几乎能跟ps的媲美了！期待中...

Answer 1

VB6.0给已有图片添加文字可通过定位的Print 方法实现。要将添加文字的位图储存为JPG格式文件，需要使用API函数等实现。

具体步骤：

1）在图片框加载需要添加文字水印的图片。

2）使用如下代码实现添加文字到图片框。

Private Sub CmdEdit_Click() '修改
    Dim strTxt As String
    strTxt = "风雨无阻 拍摄"
    Picture1.FontSize = 18
    Picture1.CurrentY = Picture1.ScaleHeight - 30
    Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(strTxt) / 2
    Picture1.ForeColor = vbWhite
    Picture1.FontItalic = True
    Picture1.Print strTxt
End Sub

3）将以下API转换图片格式代码放置于标准模块，模块命名为saveApg。

Option Explicit
    Public Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    Public Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    Public Type EncoderParameter
        GUID As GUID
        NumberOfValues As Long
        type As Long
        Value As Long
    End Type
    Public Type EncoderParameters
        Count As Long
        Parameter As EncoderParameter
    End Type
    Public Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
    Public Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    Public Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
    Public Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    Public Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal fileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    Public Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    Public Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal fileName As Long, Bitmap As Long) As Long

Public Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal fileName As String, Optional ByVal quality As Byte = 80) As Boolean
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    '初始化 GDI+
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI, 0)
    If lRes = 0 Then
        '从句柄创建 GDI+ 图像
        lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
        
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            
            '初始化解码器的GUID标识
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            
            '设置解码器参数
            tParams.Count = 1
            With tParams.Parameter ' Quality
                '得到Quality参数的GUID标识
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(quality)
            End With
            
            '保存图像
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(fileName), tJpgEncoder, tParams)
            
            '销毁GDI+图像
            GdipDisposeImage lBitmap
        End If
        
        '销毁 GDI+
        GdiplusShutdown lGDIP
    End If
    
    If lRes Then
        PictureBoxSaveJPG = False
    Else
        PictureBoxSaveJPG = True
    End If
End Function

4）使用以下代码实现将加好文字水印图片保存为jpg格式图片。

Private Sub Command3_Click() '保存为.jpg图片
    ' 设置“CancelError”为 True
    CommonDialog1.CancelError = True
    On Error GoTo ErrHandler
    ' 设置标志
    CommonDialog1.Flags = cdlOFNHideReadOnly
    ' 设置过滤器
    CommonDialog1.Filter = "JPEG Files" & "(*.jpg)|*.jpg"
    ' 指定缺省的过滤器
    CommonDialog1.FilterIndex = 2
    ' 显示“打开”对话框
    CommonDialog1.ShowSave
    ' 显示选定文件的名字
    'MsgBox CommonDialog1.fileName
    Set Picture2.Picture = Picture1.Image '转移Picture1所绘图为Picture2.Picture赋值
    Dim ret As Boolean
    ret = PictureBoxSaveJPG(Picture2, CommonDialog1.fileName) '保存压缩后的图片
    If ret = False Then
        MsgBox "保存失败"
    End If
    Exit Sub
ErrHandler:
    ' 用户按了“取消”按钮
    Exit Sub
End Sub

Answer 2

jpg属于有损压缩图像格式，是以牺牲图像质量来获得高压缩率的。一般来说，不管是用什么方法把图像保存为jpg格式，都会有选项让你选择jpg的图像质量的，你说PhotoShop保存的jpg图像其文字仍然清晰，是因为PhotoShop默认采用的jpg图像质量是较高的（貌似是80%），如果把这个参数调低，效果也一样是惨不忍睹的。jpg属于一种业界标准，在条件相同的情况下（比如同一张图片、同样的压缩参数），不管用什么方式做出来的效果都是一样的，不会说PhotoShop效果好而其他软件就不好。所以你应该在保存jpg的时候调整好参数，找到图像质量与图像容量之间的平衡点，“又想马儿跑得快，又想马儿少吃草”的好事是不存在的。

追问

我当然知道jpg压缩会损害图像质量呀。问题是即使图像质量受到损害，能达到ps这样的效果，肉眼看不到模糊就可以了。但现在尝试了好几种方法都可以看到文字明显地变模糊了，不晓得ps是如何实现的，它的肉眼看不到文字变模糊呀。

追答

PS中加入文字有两种模式，一种是带锯齿的，一种是圆滑的，后者虽然看起来比较美观，但是当图像质量下降时，文字边沿也会变得模糊；而前者虽然看起来粗糙，但在低分辨率状态下字体的边沿仍然较清晰。事实上，在显示比较小的字体时，用圆滑字体反而会很模糊的。而一般的软件（特别是程序开发语言中的图像转换控件之类的东东）是自动按平滑字体方式来显示的，所以会觉得模糊。可以用API函数关闭平滑字体方式，不过我也没用过，具体的没法帮你了。

Answer 3

其实不用这么麻烦。用一些简单的。例如用PS，把文字水印或者图案水印打上去，让后调整水印位置，最后把水印图层的透明度调低，让后保存为jpg格式，这样的效果比起正规水印操作差不了多少

Answer 4

Private Sub Command1_Click()
AddTxtToPicAndSave Picture1, "文字水印", 100, 200, "c:\1.bmp", 0
End Sub

Private Sub AddTxtToPicAndSave(Picture As PictureBox, strText As String, x As Long, y As Long, SFile As String, SaveType As Integer)
With Picture
.AutoRedraw = True
.CurrentX = x
.CurrentY = y
.Font = "黑体"
.FontBold = True
.ForeColor = vbRed
.FontSize = 22
Picture.Print strText
Select Case SaveType
Case 0 'BMP
SavePicture .Image, SFile
Case 1
'需要第三方控件来保存为其它图像格式
End Select
End With
End Sub

Answer 5

我发一个之前我用过的在网上找到的代码，可以解决你的问题；
需要请发邮箱

追问

15104946@qq.com
谢谢了，试试看。