VB小程序源代码:为图片添加水印文字或水印图案

VB小程序源代码：为图片添加水印文字或水印图案

' '以下是窗体代码，在 VB6 和 WinXP 调试通过

'需在窗体放置以下控件，所有控件不必设置任何属性（包括位置和大小），全部采用默认设置：

' 1 个 文本框：Text1

' 5 个 按钮：Command1、Command2、Command3、Command4、Command5

' 6 个 下拉列表框：Combo1、Combo2、Combo3、Combo4、Combo5、Combo6

' 3 个 选择按钮：Check1、Check2、Check3

' 2 个 图片框：Picture1、Picture2

' 1 个 形状控件：Shape1

'本人原创，转载请注明文章来源：/100bd/blog/item/

Private Type BitMap

bmType As Long '图像类型：0 表示是位图

bmWidth As Long '图像宽度（像素）

bmHeight As Long '图像高度（像素）

bmWidthBytes As Long '每一行图像的字节数

bmPlanes As Integer '图像的图层数

bmBitsPixel As Integer '图像的位数

bmBits As Long '位图的内存指针

End Type

Private Declare Function GetObject Lib "gdi32" Alias

"GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As

Long

Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long,

ByVal dwCount As Long, lpBits As Any) As Long

Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long,

ByVal dwCount As Long, lpBits As Any) As Long

Private Type tyRGB

R As Long: G As Long: B As Long

End Type

Dim ctIsText As Boolean, ctRun As Boolean, ctF As String

Private Sub Form_Load()

n = "水印"

ode = 3

n = "文字水印": pText = "切换到叠加文字水印状态"

n = "图片水印": pText = "切换到叠加图片水印状态"

n = "装载水印图片"

n = "打开": pText = "加载背景图片"

n = "保存": pText = "保存图片"

n = "下凹文字": n = "斜体":

n = "粗体"

draw = True: ode = 3

draw = True: ode = 3

ze = True: ze = True

lor = &H888888

e =

Set ner = Picture1

de = 14

yle = 0

Dim I As Long

For I = 1 To 9

m "0." & I & " 水印清晰度"

Next

m "1 水印清晰度"

dex = 4

m "阴影宽度 1"

m "阴影宽度 2"

m "阴影宽度 3"

dex = 0

For I = 0 To unt - 1

m (I)

Next

= "宋体"

For I = 3 To 72 Step 3

m I & "号"

Next

= "15 号"

m "彩色水印"

m "黑白水印"

m "版画式水印"

dex = 2

For I = 0 To 30

m "背景杂色消除 " & I

Next

dex = 20

= "/100bd" '"一○○度制作" '中国

pText = "在此处输入叠加在图片上的水印文字"

Call SetKj

ctRun = True

e = False: 0, 0

Call AddWater(True)

End Sub

Private Sub SetKj()

Dim H As Long

H = dth("A")

H, H, H * 10, H * 3: H * 12, H, H * 43, H * 3

H, H * 5, H * 12, H * 2: H * 15, H * 4.5, H * 9

H * 24, H * 4.5, H * 23: H * 48, H * 5, H * 8, H * 2

H, H * 7.5, H * 6, H * 3: H * 8, H * 7.5, H * 6, H * 3

H * 15, H * 8, H * 18

H * 33, H * 8, H * 14: H * 48, H * 8.5, H * 8, H * 2

H, H * 11.5, H * 50, H * 40

H * 57, H, H * 10, H * 3: H * 68, H * 1.5, H * 20

H * 57, H * 5, H * 14, H * 3: H * 72, H * 5.5, H * 16

H * 57, H * 8.5, H * 5, H * 5

End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As

Single)

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As

Single)

Dim W As Long, H As Long

If Button <> 1 Then Exit Sub

W = idth: H = eight

X - W * 0.5, Y - H * 0.5, W, H

e = True

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As

Single)

If Button <> 1 Or Not e Then Exit Sub

e = False

Call AddWater(ctIsText)

End Sub

Private Sub Picture2_Click()

End Sub

Private Sub Text1_Change()

Call AddWater(ctIsText) '文字水印

End Sub

Private Sub Combo1_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Combo2_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Combo3_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Combo4_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Combo5_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Combo6_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Check1_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Check2_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Check3_Click()

Call AddWater(ctIsText)

End Sub

Private Sub Command1_Click()

Call AddWater(True) '文字水印

End Sub

Private Sub Command2_Click()

Call AddWater '图片水印

End Sub

Private Sub Command3_Click()

'加载水印图案

Static F As String

Dim nF As String

If F = "" Then F = & "头像.jpg"

nF = SelectFile(F, "加载水印图案")

If nF = "" Then Exit Sub

If Not LoadPic(Picture2, nF) Then Exit Sub

F = nF

Call AddWater '图片水印

End Sub

Private Sub Command4_Click()

'加载背景图片

Dim nF As String

If ctF = "" Then ctF = & ""

nF = SelectFile(ctF, "加载背景图片")

If nF = "" Then Exit Sub

If Not LoadPic(Picture1, nF) Then Exit Sub

ctF = nF

0, 0

Call AddWater(ctIsText) '图片水印

End Sub

Private Sub Command5_Click()

'保存图片

Dim nF As String, I As Long

If ctF = "" Then ctF = & "Tu1"

nF = ctF

For I = Len(nF) To 1 Step -1 '去掉扩展名

If Mid(nF, I, 1) = "" Then Exit For

If Mid(nF, I, 1) = "." Then

nF = Left(nF, I - 1): Exit For

End If

Next

nF = SelectFile(nF, "保存图片", True)

If nF = "" Then Exit Sub

If UCase(Right(nF, 4)) <> ".BMP" Then

MsgBox "无法保存为这种格式的文件：" & vbCrLf & nF,

vbInformation

Exit Sub

End If

On Error GoTo Err1

SavePicture , nF

ctF = nF

Exit Sub

Err1:

MsgBox "错误：" & vbCrLf & ption, vbInformation,

"保存图片"

End Sub

Private Function SelectFile(ByVal F As String, nCap As String, Optional IsSave As Boolean)

As String

'调用系统对话框选择文件名

Dim nDLG '

Set nDLG = CreateObject("Dialog")

With nDLG

.DialogTitle = nCap '对话框标题

.MaxFileSize = 255 '文件名最多字符数

.CancelError = True

.FileName = F

On Error Resume Next

If IsSave Then

.DefaultExt = ".bmp"

.Flags = &H2 + &H400 '覆盖确认、扩展名匹配

.Filter = "位图文件 *.bmp|*.bmp" '文件过滤器"

.ShowSave ' 显示保存对话框

Else

.Flags = &H4 + &H1000 '隐藏只读复选框、只能输入已列出文件名

.Filter = "图片文件 *.jpg;*.gif;*.ico;*.bmp|*.jpg;*.gif;*.ico;*.bmp|所有文件 *.*|*.*" '文件过滤器

.ShowOpen ' 显示打开对话框

End If

If = 0 Then SelectFile = .FileName '返回选中的文件名

End With

Set nDLG = Nothing

End Function

Private Function LoadPic(Kj As Control, F As String) As Boolean

'打开图片文件

On Error GoTo Err1

e = LoadPicture(F)

LoadPic = True

Exit Function

Err1:

MsgBox "无法读取文件：" & vbCrLf & F, vbInformation

End Function

Private Sub AddWater(Optional IsText As Boolean)

Dim S1 As Long, W1 As Long, H1 As Long, BM1() As Byte, Bs1 As Long, BytesW1 As

Long, Ps1 As Long

Dim S2 As Long, W2 As Long, H2 As Long, BM2() As Byte, Bs2 As Long, BytesW2 As

Long, Ps2 As Long

Dim R As Long, G As Long, B As Long, Tmp As Long, Tmp1 As Long, Tmp2 As Long

Dim MaxSe As tyRGB, MinSe As tyRGB, BackSe As tyRGB, nStr As String

Dim X As Long, Y As Long, x0 As Long, y0 As Long, Bi As Single, nMode As Long

Dim W As Long, Range As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long

If Not ctRun Then Exit Sub '防止初始化时多次重复调用

Bi = Val() '水印的清晰度 0 到 1

If Bi < 0 Then Bi = 0

If Bi > 1 Then Bi = 1

MaxSe.R = 255: MaxSe.G = 255: MaxSe.B = 255 '水印叠加：亮色

MinSe.R = 30: MinSe.G = 30: MinSe.B = 30 '水印叠加：暗色

Range = 30 '颜色检测误差的范围

Tmp = 255 '过渡图片的文字颜色

Tmp1 = 120 + Range '过渡图片的亮色

Tmp2 = 120 - Range '过渡图片的暗色

Range = Range * 0.9

W = 1 + dex '水印边框宽度

nMode = dex '水印方式：彩色黑白版画"

'在过渡图片上显示水印底稿

: e = Not IsText

If IsText Then

nStr = ' 水印文字

lor = RGB(120, 120, 120)

Call WaterStr(nStr, W, Tmp, RGB(Tmp1, Tmp1, Tmp1), RGB(Tmp2, Tmp2, Tmp2))

Else

Range = dex '设置颜色检测误差的范围，是为了消除 jpg 图片背景杂色

e = e

End If

If = 1 Then '下凹水印，否则为上凸水印

X = MaxSe.R: MaxSe.R = MinSe.R: MinSe.R = X

X = MaxSe.G: MaxSe.G = MinSe.G: MinSe.G = X

X = MaxSe.B: MaxSe.B = MinSe.B: MinSe.B = X

End If

: h

GetBmpDat Picture1, W1, H1, BM1, Bs1, BytesW1, Ps1

GetBmpDat Picture2, W2, H2, BM2, Bs2, BytesW2, Ps2

GetRGB (0, 0), BackSe.R, BackSe.G, BackSe.B '背景色

x0 = : y0 = '水印显示位置

x1 = -x0: y1 = -y0

If x1 < 0 Then x1 = 0

If y1 < 0 Then y1 = 0

x2 = W2 - 1: y2 = H2 - 1

If x2 > W1 - x0 - 1 Then x2 = W1 - x0 - 1

If y2 > H1 - y0 - 1 Then y2 = H1 - y0 - 1

For X = x1 To x2

For Y = y1 To y2

S2 = XYtoIndex(X, Y, BytesW2, Ps2) '像素点在数组 BM2 中的索引:水印底稿

R = BM2(S2 + 2): G = BM2(S2 + 1): B = BM2(S2)

If IsText Then

If SeRange(Range, Tmp1, Tmp1, Tmp1, R, G, B) Then '增加亮度

S1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) '像素点在数组 BM1 中的索引

BM1(S1 + 2) = SeAdd(BM1(S1 + 2), MaxSe.R, Bi)

BM1(S1 + 1) = SeAdd(BM1(S1 + 1), MaxSe.G, Bi)

BM1(S1) = SeAdd(BM1(S1), MaxSe.B, Bi)

End If

If SeRange(Range, Tmp2, Tmp2, Tmp2, R, G, B) Then '减小亮度

S1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) '像素点在数组 BM1 中的索引

BM1(S1 + 2) = SeAdd(BM1(S1 + 2), MinSe.R, Bi)

BM1(S1 + 1) = SeAdd(BM1(S1 + 1), MinSe.G, Bi)

BM1(S1) = SeAdd(BM1(S1), MinSe.B, Bi)

End If

Else

If Not SeRange(Range, BackSe.R, BackSe.G, BackSe.B, R, G, B) Then

S1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) '像素点在数组 BM1 中的索引

If nMode > 0 Then

R = (R + G + B) * 0.33 '黑白

If nMode > 1 Then '版画

If R > 127 Then R = 255 Else R = 0

End If

G = R: B = R

End If

BM1(S1 + 2) = SeAdd(BM1(S1 + 2), R, Bi)

BM1(S1 + 1) = SeAdd(BM1(S1 + 1), G, Bi)

BM1(S1) = SeAdd(BM1(S1), B, Bi)

End If

End If

Next

Next

SetBitmapBits , Bs1, BM1(0) '将 Picture1 的图像设置为旋转后的二进数组

BM1()

ctIsText = IsText

d = IsText: d = IsText: d = IsText

d = IsText: d = IsText: d = IsText

d = IsText

d = Not IsText: d = Not IsText: d =

Not IsText

End Sub

Private Sub GetBmpDat(Kj As Control, W As Long, H As Long, B() As Byte, Bs As Long,

BytesW As Long, Ps As Long)

'获取控件 Kj 的图像数据

Dim MapInf As BitMap

GetObject , Len(MapInf), MapInf '用 MapInf 得到 Kj 的图像信息

W = h: H = ht '图像宽度、高度（像素）

BytesW = hBytes '每行占用字节数

Ps = BytesW W '每个像素字节数(一般为4)

Bs = W * H * Ps '总字节数=宽度*高度*每个像素字节

ReDim B(0 To Bs - 1)

GetBitmapBits , Bs, B(0) '将 Kj 图像所有像素点的颜色值读入二进数组 B()

End Sub

Private Function XYtoIndex(X As Long, Y As Long, BytesW As Long, Ps As Long) As Long

'返回图像坐标 x,y 在颜色数组中的序号位置。

'BytesW：每行图像占用字节数，Ps：每个像素点占用字节数(一般为4)

XYtoIndex = Y * BytesW + X * Ps

End Function

Private Function SeRange(Range As Long, r1 As Long, g1 As Long, b1 As Long, r2 As Long,

g2 As Long, b2 As Long) As Boolean

'两种颜色误差是否在 Range 范围内

If Abs(r1 - r2) > Range Or Abs(g1 - g2) > Range Or Abs(b1 - b2) > Range Then

Exit Function

SeRange = True

End Function

Private Function SeAdd(ByVal Se1 As Long, ByVal Se2 As Long, Bi2 As Single) As Long

'两种单通道颜色叠加，Bi2 表示 Se2 的比例

SeAdd = Se1 + (Se2 - Se1) * Bi2

End Function

Private Sub WaterStr(nStr As String, W As Long, Se As Long, Se1 As Long, Se2 As Long)

Dim x0 As Long, y0 As Long, S As Long

On Error Resume Next

= Val()

= '字体

= = 1 '斜体

= = 1 '粗体

On Error GoTo 0

S = 6 + W * 2 + dth(nStr)

If Then S = S + dth("A") * 0.5

= S

= 6 + W * 2 + ight(nStr)

(0, 0)-(idth - 1, eight - 1),

lor, BF

DoEvents

ShowStr1 Picture2, nStr, Se1, x0, y0, W * 2.5, W * 2.5 '亮

ShowStr1 Picture2, nStr, Se2, x0 + W, y0 + W, W * 2 + 1, W * 2 '暗

ShowStr1 Picture2, nStr, Se, x0 + W, y0 + W, W, W '本色'255

End Sub

Private Sub ShowStr1(Kj, nStr As String, Se As Long, x0 As Long, y0 As Long, Optional ToX

As Long, Optional ToY As Long)

Dim X As Long, Y As Long

lor = Se

For Y = y0 To y0 + ToY

For X = x0 To x0 + ToX

tX = X: tY = Y: nStr

Next

Next

End Sub

Private Sub GetRGB(ByVal Se As Long, R As Long, G As Long, B As Long)

B = Se 65536: Se = Se Mod 65536

G = Se 256: R = Se Mod 256

B = B Mod 256

End Sub

'本文保存的图片格式是 BMP 格式，要保存为其他格式，请参见：将图片保存或转变为JPG格式

查看文档来源：/100bd/item/8081bbce1fdda50aad092fc2