1、VB小程序源代码：为图片添加水印文字或水印图案 以下是窗体代码，在 VB6 和 WinXP 调试通过需在窗体放置以下控件，所有控件不必设置任何属性（包括位置和大小），全部采用默认设置： 1 个 文本框：Text1 5 个 按钮：Comma nd1、Command2、Command3、 Command4、Command5 6 个 下拉列表框：Combo1、Combo 2、Combo3、Combo4 、Combo5 、Combo6 3 个 选择按钮：Check 1、Check2、Check 3 2 个 图片框：Picture1、Picture2 1 个 形状控件：Shape1本人原创，转载请注明文
2、章来源：Private Type BitMapbmType As Long 图像类型：0 表示是位图bmWidth As Long 图像宽度（像素）bmHeight As Long 图像高度（像素）bmWidthBytes As Long 每一行图像的字节数bmPlanes As Integer 图像的图层数bmBitsPixel As Integer 图像的位数bmBits As Long 位图的内存指针End TypePrivate Declare Function GetObject Lib gdi32 Alias GetObjectA (ByVal hObject As Long, B
3、yVal nCount As Long, lpObject As Any) As LongPrivate Declare Function GetBitmapBits Lib gdi32 (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate Declare Function SetBitmapBits Lib gdi32 (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate Type tyRGBR
4、 As Long: G As Long: B As LongEnd TypeDim ctIsText As Boolean, ctRun As Boolean, ctF As StringPrivate Sub Form_Load()Me.Caption = 水印Me.ScaleMode = 3Command1.Caption = 文字水印: Command1.ToolTipText = 切换到叠加文字水印状态Command2.Caption = 图片水印: Command2.ToolTipText = 切换到叠加图片水印状态Command3.Caption = 装载水印图片Command4.
5、Caption = 打开: Command4.ToolTipText = 加载背景图片Command5.Caption = 保存: Command5.ToolTipText = 保存图片Check1.Caption = 下凹文字: Check2.Caption = 斜体: Check3.Caption = 粗体 Picture1.AutoRedraw = True: Picture1.ScaleMode = 3Picture2.AutoRedraw = True: Picture2.ScaleMode = 3Picture1.AutoSize = True: Picture2.AutoSize
6、 = TruePicture1.BackColor = H888888Picture2.Picture = Me.IconSet Shape1.Container = Picture1Shape1.DrawMode = 14Shape1.FillStyle = 0Dim I As LongFor I = 1 To 9Combo1.AddItem 0. I 水印清晰度NextCombo1.AddItem 1 水印清晰度Combo1.ListIndex = 4Combo2.AddItem 阴影宽度 1Combo2.AddItem 阴影宽度 2Combo2.AddItem 阴影宽度 3Combo2.
7、ListIndex = 0For I = 0 To Screen.FontCount - 1Combo3.AddItem Screen.Fonts(I)NextCombo3.Text = 宋体For I = 3 To 72 Step 3Combo4.AddItem I 号NextCombo4.Text = 15 号Combo5.AddItem 彩色水印Combo5.AddItem 黑白水印Combo5.AddItem 版画式水印Combo5.ListIndex = 2For I = 0 To 30Combo6.AddItem 背景杂色消除 INextCombo6.ListIndex = 20T
8、ext1.Text = http:/ 一度制作 中国Text1.ToolTipText = 在此处输入叠加在图片上的水印文字Call SetKjctRun = TrueShape1.Visible = False: Shape1.Move 0, 0Call AddWater(True)End SubPrivate Sub SetKj()Dim H As LongH = Me.TextWidth(A)Command1.Move H, H, H * 10, H * 3: Text1.Move H * 12, H, H * 43, H * 3Check1.Move H, H * 5, H * 12,
9、 H * 2: Combo4.Move H * 15, H * 4.5, H * 9Combo3.Move H * 24, H * 4.5, H * 23: Check2.Move H * 48, H * 5, H * 8, H * 2Command4.Move H, H * 7.5, H * 6, H * 3: Command5.Move H * 8, H * 7.5, H * 6, H * 3Combo1.Move H * 15, H * 8, H * 18Combo2.Move H * 33, H * 8, H * 14: Check3.Move H * 48, H * 8.5, H *
10、 8, H * 2Picture1.Move H, H * 11.5, H * 50, H * 40Command2.Move H * 57, H, H * 10, H * 3: Combo6.Move H * 68, H * 1.5, H * 20Command3.Move H * 57, H * 5, H * 14, H * 3: Combo5.Move H * 72, H * 5.5, H * 16Picture2.Move H * 57, H * 8.5, H * 5, H * 5End SubPrivate Sub Picture1_MouseDown(Button As Integ
11、er, Shift As Integer, X As Single, Y As Single)Picture1.ZOrderEnd SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Dim W As Long, H As LongIf Button 1 Then Exit SubW = Picture2.ScaleWidth: H = Picture2.ScaleHeightShape1.Move X - W * 0.5, Y - H * 0.5, W,
12、 HShape1.Visible = TrueEnd SubPrivate Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button 1 Or Not Shape1.Visible Then Exit SubShape1.Visible = FalseCall AddWater(ctIsText)End SubPrivate Sub Picture2_Click()Picture2.ZOrderEnd SubPrivate Sub Text1_Change()Call
13、 AddWater(ctIsText) 文字水印End SubPrivate Sub Combo1_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo2_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo3_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo4_Click()Call AddWater(ctIsText)End SubPrivate Sub Combo5_Click()Call AddWater(ctIsT
14、ext)End SubPrivate Sub Combo6_Click()Call AddWater(ctIsText)End SubPrivate Sub Check1_Click()Call AddWater(ctIsText)End SubPrivate Sub Check2_Click()Call AddWater(ctIsText)End SubPrivate Sub Check3_Click()Call AddWater(ctIsText)End SubPrivate Sub Command1_Click()Call AddWater(True) 文字水印End SubPrivat
15、e Sub Command2_Click()Call AddWater 图片水印End SubPrivate Sub Command3_Click()加载水印图案Static F As StringDim nF As StringIf F = Then F = App.Path 头像.jpgnF = SelectFile(F, 加载水印图案)If nF = Then Exit SubIf Not LoadPic(Picture2, nF) Then Exit SubF = nFCall AddWater 图片水印End SubPrivate Sub Command4_Click()加载背景图片
16、Dim nF As StringIf ctF = Then ctF = App.Path Tu1.jpgnF = SelectFile(ctF, 加载背景图片)If nF = Then Exit SubIf Not LoadPic(Picture1, nF) Then Exit SubctF = nFShape1.Move 0, 0Call AddWater(ctIsText) 图片水印End SubPrivate Sub Command5_Click()保存图片Dim nF As String, I As LongIf ctF = Then ctF = App.Path Tu1nF = ct
17、FFor I = Len(nF) To 1 Step -1 去掉扩展名If Mid(nF, I, 1) = Then Exit ForIf Mid(nF, I, 1) = . ThennF = Left(nF, I - 1): Exit ForEnd IfNextnF = SelectFile(nF, 保存图片, True)If nF = Then Exit SubIf UCase(Right(nF, 4) .BMP ThenMsgBox 无法保存为这种格式的文件： vbCrLf nF, vbInformationExit SubEnd IfOn Error GoTo Err1SavePict
18、ure Picture1.Image, nFctF = nFExit SubErr1:MsgBox 错误： vbCrLf Err.Description, vbInformation, 保存图片End SubPrivate Function SelectFile(ByVal F As String, nCap As String, Optional IsSave As Boolean) As String调用系统对话框选择文件名Dim nDLG comdlg32.ocxSet nDLG = CreateObject(MSComDlg.CommonDialog)With nDLG.DialogT
19、itle = nCap 对话框标题.MaxFileSize = 255 文件名最多字符数.CancelError = True.FileName = FOn Error Resume NextIf IsSave Then.DefaultExt = .bmp.Flags = H2 + H400 覆盖确认、扩展名匹配.Filter = 位图文件 *.bmp|*.bmp 文件过滤器.ShowSave 显示保存对话框Else.Flags = H4 + H1000 隐藏只读复选框、只能输入已列出文件名.Filter = 图片文件 *.jpg;*.gif;*.ico;*.bmp|*.jpg;*.gif;*
20、.ico;*.bmp|所有文件 *.*|*.* 文件过滤器.ShowOpen 显示打开对话框End IfIf Err.Number = 0 Then SelectFile = .FileName 返回选中的文件名End WithSet nDLG = NothingEnd FunctionPrivate Function LoadPic(Kj As Control, F As String) As Boolean打开图片文件On Error GoTo Err1Kj.Picture = LoadPicture(F)LoadPic = TrueExit FunctionErr1:MsgBox 无法读
21、取文件： vbCrLf F, vbInformationEnd FunctionPrivate 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 LongDim S2 As Long, W2 As Long, H2 As Long, BM2() As Byte, Bs2 As Long, BytesW2 As Long, Ps2 As LongDim R As Long, G As
22、Long, B As Long, Tmp As Long, Tmp1 As Long, Tmp2 As LongDim MaxSe As tyRGB, MinSe As tyRGB, BackSe As tyRGB, nStr As StringDim X As Long, Y As Long, x0 As Long, y0 As Long, Bi As Single, nMode As LongDim W As Long, Range As Long, x1 As Long, y1 As Long, x2 As Long, y2 As LongIf Not ctRun Then Exit S
23、ub 防止初始化时多次重复调用Bi = Val(Combo1.Text) 水印的清晰 度 0 到 1If Bi 0 Then Bi = 0If Bi 1 Then Bi = 1MaxSe.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.9W
24、= 1 + Combo2.ListIndex 水印边框宽度nMode = Combo5.ListIndex 水印方式：彩色黑白 版画在过渡图片上显示水印底稿Picture2.Cls: Picture2.Visible = Not IsTextIf IsText ThennStr = Text1.Text 水印文字Picture2.BackColor = RGB(120, 120, 120)Call WaterStr(nStr, W, Tmp, RGB(Tmp1, Tmp1, Tmp1), RGB(Tmp2, Tmp2, Tmp2)ElseRange = Combo6.ListIndex 设置颜
25、色检测误差的范围，是为了消除 jpg 图片背景杂色Picture2.Picture = Picture2.PictureEnd IfIf Check1.Value = 1 Then 下凹水印，否则为上凸水印X = MaxSe.R: MaxSe.R = MinSe.R: MinSe.R = XX = MaxSe.G: MaxSe.G = MinSe.G: MinSe.G = XX = MaxSe.B: MaxSe.B = MinSe.B: MinSe.B = XEnd IfPicture1.Cls: Picture1.RefreshGetBmpDat Picture1, W1, H1, BM1,
26、 Bs1, BytesW1, Ps1GetBmpDat Picture2, W2, H2, BM2, Bs2, BytesW2, Ps2GetRGB Picture2.Point(0, 0), BackSe.R, BackSe.G, BackSe.B 背景色x0 = Shape1.Left: y0 = Shape1.Top 水印显示位置x1 = -x0: y1 = -y0If x1 0 Then x1 = 0If y1 0 Then y1 = 0x2 = W2 - 1: y2 = H2 - 1If x2 W1 - x0 - 1 Then x2 = W1 - x0 - 1If y2 H1 - y
27、0 - 1 Then y2 = H1 - y0 - 1For X = x1 To x2For Y = y1 To y2S2 = XYtoIndex(X, Y, BytesW2, Ps2) 像素点在数组 BM2 中的索引:水印底稿R = BM2(S2 + 2): G = BM2(S2 + 1): B = BM2(S2)If IsText ThenIf SeRange(Range, Tmp1, Tmp1, Tmp1, R, G, B) Then 增加亮度S1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) 像素点在数组 BM1 中的索引BM1(S1 + 2) =
28、 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 IfIf 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(B
29、M1(S1 + 1), MinSe.G, Bi)BM1(S1) = SeAdd(BM1(S1), MinSe.B, Bi)End IfElseIf Not SeRange(Range, BackSe.R, BackSe.G, BackSe.B, R, G, B) ThenS1 = XYtoIndex(x0 + X, y0 + Y, BytesW1, Ps1) 像素点在数组 BM1 中的索引If nMode 0 ThenR = (R + G + B) * 0.33 黑白If nMode 1 Then 版画If R 127 Then R = 255 Else R = 0End IfG = R: B
30、 = REnd IfBM1(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 IfEnd IfNextNextSetBitmapBits Picture1.Image, Bs1, BM1(0) 将 Picture1 的图像设置为旋转后的二进数组 BM1()ctIsText = IsTextCheck1.Enabled = IsText: Check2.Enabled = IsText: Check3.Enabled = IsTe
31、xtCombo2.Enabled = IsText: Combo3.Enabled = IsText: Combo4.Enabled = IsTextText1.Enabled = IsTextCommand3.Enabled = Not IsText: Combo5.Enabled = Not IsText: Combo6.Enabled = Not IsTextEnd SubPrivate Sub GetBmpDat(Kj As Control, W As Long, H As Long, B() As Byte, Bs As Long, BytesW As Long, Ps As Lon
32、g)获取控件 Kj 的图像数据Dim MapInf As BitMapGetObject Kj.Image, Len(MapInf), MapInf 用 MapInf 得到 Kj 的图像信息W = MapInf.bmWidth: H = MapInf.bmHeight 图像宽度、高度（像素）BytesW = MapInf.bmWidthBytes 每行占用字节数Ps = BytesW W 每个像素字节数( 一般为4)Bs = W * H * Ps 总字节数= 宽度* 高度*每个像素字节ReDim B(0 To Bs - 1)GetBitmapBits Kj.Image, Bs, B(0) 将
33、Kj 图像所有像素点的颜色值读入二进数组 B()End SubPrivate 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 * PsEnd FunctionPrivate Function SeRange(Range As Long, r1 As Long, g1 As Long, b1 As Long, r2 As
34、 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 FunctionSeRange = TrueEnd FunctionPrivate Function SeAdd(ByVal Se1 As Long, ByVal Se2 As Long, Bi2 As Single) As Long两种单通道颜色叠加，Bi2 表示 Se2 的比例SeAdd = Se1 + (Se2 - Se
35、1) * Bi2End FunctionPrivate 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 LongOn Error Resume NextPicture2.Font.Size = Val(Combo4.Text)Picture2.Font.Name = Combo3.Text 字体Picture2.Font.Italic = Check2.Value = 1 斜体Picture2.Font.Bold = Che
36、ck3.Value = 1 粗体On Error GoTo 0S = 6 + W * 2 + Picture2.TextWidth(nStr)If Picture2.Font.Italic Then S = S + Picture2.TextWidth(A) * 0.5Picture2.Width = SPicture2.Height = 6 + W * 2 + Picture2.TextHeight(nStr)Picture2.ClsPicture2.Line (0, 0)-(Picture2.ScaleWidth - 1, Picture2.ScaleHeight - 1), Pictur
37、e2.BackColor, BFDoEventsShowStr1 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 本色 255End SubPrivate Sub ShowStr1(Kj, nStr As String, Se As Long, x0 As Long, y0 As Long, Optional ToX As
38、Long, Optional ToY As Long)Dim X As Long, Y As LongKj.ForeColor = SeFor Y = y0 To y0 + ToYFor X = x0 To x0 + ToXKj.CurrentX = X: Kj.CurrentY = Y: Kj.Print nStrNextNextEnd SubPrivate Sub GetRGB(ByVal Se As Long, R As Long, G As Long, B As Long)B = Se 65536: Se = Se Mod 65536G = Se 256: R = Se Mod 256B = B Mod 256End Sub本文保存的图片格式是 BMP 格式，要保存为其他格式，请参见：查看文档来源：
