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

资源描述

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

《VB小程序源代码为图片添加水印文字或水印图案.docx》由会员分享，可在线阅读，更多相关《VB小程序源代码为图片添加水印文字或水印图案.docx（15页珍藏版）》请在冰豆网上搜索。

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

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

'本人原创，转载请注明文章来源：

PrivateTypeBitMap

bmTypeAsLong '图像类型：

0表示是位图

bmWidthAsLong '图像宽度（像素）

bmHeightAsLong '图像高度（像素）

bmWidthBytesAsLong '每一行图像的字节数

bmPlanesAsInteger '图像的图层数

bmBitsPixelAsInteger'图像的位数

bmBitsAsLong '位图的内存指针

EndType

PrivateDeclareFunctionGetObjectLib"gdi32"Alias"GetObjectA"（ByValhObjectAsLong,ByValnCountAsLong,lpObjectAsAny）AsLong

PrivateDeclareFunctionGetBitmapBitsLib"gdi32"（ByValhBitmapAsLong,ByValdwCountAsLong,lpBitsAsAny）AsLong

PrivateDeclareFunctionSetBitmapBitsLib"gdi32"（ByValhBitmapAsLong,ByValdwCountAsLong,lpBitsAsAny）AsLong

PrivateTypetyRGB

RAsLong:

GAsLong:

BAsLong

EndType

DimctIsTextAsBoolean,ctRunAsBoolean,ctFAsString

PrivateSubForm_Load（）

Me.Caption="水印"

Me.ScaleMode=3

Command1.Caption="文字水印":

Command1.ToolTipText="切换到叠加文字水印状态"

Command2.Caption="图片水印":

Command2.ToolTipText="切换到叠加图片水印状态"

Command3.Caption="装载水印图片"

Command4.Caption="打开":

Command4.ToolTipText="加载背景图片"

Command5.Caption="保存":

Command5.ToolTipText="保存图片"

Check1.Caption="下凹文字":

Check2.Caption="斜体":

Check3.Caption="粗体"

Picture1.AutoRedraw=True:

Picture1.ScaleMode=3

Picture2.AutoRedraw=True:

Picture2.ScaleMode=3

Picture1.AutoSize=True:

Picture2.AutoSize=True

Picture1.BackColor=&H888888

Picture2.Picture=Me.Icon

SetShape1.Container=Picture1

Shape1.DrawMode=14

Shape1.FillStyle=0

DimIAsLong

ForI=1To9

Combo1.AddItem"0."&I&"水印清晰度"

Combo1.AddItem"1 水印清晰度"

Combo1.ListIndex=4

Combo2.AddItem"阴影宽度1"

Combo2.AddItem"阴影宽度2"

Combo2.AddItem"阴影宽度3"

Combo2.ListIndex=0

ForI=0ToScreen.FontCount-1

Combo3.AddItemScreen.Fonts（I）

Combo3.Text="宋体"

ForI=3To72Step3

Combo4.AddItemI&"号"

Combo4.Text="15号"

Combo5.AddItem"彩色水印"

Combo5.AddItem"黑白水印"

Combo5.AddItem"版画式水印"

Combo5.ListIndex=2

ForI=0To30

Combo6.AddItem"背景杂色消除"&I

Combo6.ListIndex=20

Text1.Text="'"一○○度制作"'中国

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

CallSetKj

ctRun=True

Shape1.Visible=False:

Shape1.Move0,0

CallAddWater（True）

EndSub

PrivateSubSetKj（）

DimHAsLong

H=Me.TextWidth（"A"）

Command1.MoveH,H,H*10,H*3:

Text1.MoveH*12,H,H*43,H*3

Check1.MoveH,H*5,H*12,H*2:

Combo4.MoveH*15,H*4.5,H*9

Combo3.MoveH*24,H*4.5,H*23:

Check2.MoveH*48,H*5,H*8,H*2

Command4.MoveH,H*7.5,H*6,H*3:

Command5.MoveH*8,H*7.5,H*6,H*3

Combo1.MoveH*15,H*8,H*18

Combo2.MoveH*33,H*8,H*14:

Check3.MoveH*48,H*8.5,H*8,H*2

Picture1.MoveH,H*11.5,H*50,H*40

Command2.MoveH*57,H,H*10,H*3:

Combo6.MoveH*68,H*1.5,H*20

Command3.MoveH*57,H*5,H*14,H*3:

Combo5.MoveH*72,H*5.5,H*16

Picture2.MoveH*57,H*8.5,H*5,H*5

EndSub

PrivateSubPicture1_MouseDown（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）

Picture1.ZOrder

EndSub

PrivateSubPicture1_MouseMove（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）

DimWAsLong,HAsLong

IfButton<>1ThenExitSub

W=Picture2.ScaleWidth:

H=Picture2.ScaleHeight

Shape1.MoveX-W*0.5,Y-H*0.5,W,H

Shape1.Visible=True

EndSub

PrivateSubPicture1_MouseUp（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）

IfButton<>1OrNotShape1.VisibleThenExitSub

Shape1.Visible=False

CallAddWater（ctIsText）

EndSub

PrivateSubPicture2_Click（）

Picture2.ZOrder

EndSub

PrivateSubText1_Change（）

CallAddWater（ctIsText）'文字水印

EndSub

PrivateSubCombo1_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCombo2_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCombo3_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCombo4_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCombo5_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCombo6_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCheck1_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCheck2_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCheck3_Click（）

CallAddWater（ctIsText）

EndSub

PrivateSubCommand1_Click（）

CallAddWater（True）'文字水印

EndSub

PrivateSubCommand2_Click（）

CallAddWater '图片水印

EndSub

PrivateSubCommand3_Click（）

'加载水印图案

StaticFAsString

DimnFAsString

IfF=""ThenF=App.Path&"\头像.jpg"

nF=SelectFile（F,"加载水印图案"）

IfnF=""ThenExitSub

IfNotLoadPic（Picture2,nF）ThenExitSub

F=nF

CallAddWater '图片水印

EndSub

PrivateSubCommand4_Click（）

'加载背景图片

DimnFAsString

IfctF=""ThenctF=App.Path&"\Tu1.jpg"

nF=SelectFile（ctF,"加载背景图片"）

IfnF=""ThenExitSub

IfNotLoadPic（Picture1,nF）ThenExitSub

ctF=nF

Shape1.Move0,0

CallAddWater（ctIsText） '图片水印

EndSub

PrivateSubCommand5_Click（）

'保存图片

DimnFAsString,IAsLong

IfctF=""ThenctF=App.Path&"\Tu1"

nF=ctF

ForI=Len（nF）To1Step-1'去掉扩展名

IfMid（nF,I,1）="\"ThenExitFor

IfMid（nF,I,1）="."Then

nF=Left（nF,I-1）:

ExitFor

EndIf

nF=SelectFile（nF,"保存图片",True）

IfnF=""ThenExitSub

IfUCase（Right（nF,4））<>".BMP"Then

MsgBox"无法保存为这种格式的文件：

"&vbCrLf&nF,vbInformation

ExitSub

EndIf

OnErrorGoToErr1

SavePicturePicture1.Image,nF

ctF=nF

ExitSub

Err1:

MsgBox"错误：

"&vbCrLf&Err.Description,vbInformation,"保存图片"

EndSub

PrivateFunctionSelectFile（ByValFAsString,nCapAsString,OptionalIsSaveAsBoolean）AsString

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

DimnDLG'comdlg32.ocx

SetnDLG=CreateObject（"MSComDlg.CommonDialog"）

WithnDLG

.DialogTitle=nCap '对话框标题

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

.CancelError=True

.FileName=F

OnErrorResumeNext

IfIsSaveThen

.DefaultExt=".bmp"

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

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

.ShowSave'显示保存对话框

Else

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

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

.ShowOpen'显示打开对话框

EndIf

IfErr.Number=0ThenSelectFile=.FileName '返回选中的文件名

EndWith

SetnDLG=Nothing

EndFunction

PrivateFunctionLoadPic（KjAsControl,FAsString）AsBoolean

'打开图片文件

OnErrorGoToErr1

Kj.Picture=LoadPicture（F）

LoadPic=True

ExitFunction

Err1:

MsgBox"无法读取文件：

"&vbCrLf&F,vbInformation

EndFunction

PrivateSubAddWater（OptionalIsTextAsBoolean）

DimS1AsLong,W1AsLong,H1AsLong,BM1（）AsByte,Bs1AsLong,BytesW1AsLong,Ps1AsLong

DimS2AsLong,W2AsLong,H2AsLong,BM2（）AsByte,Bs2AsLong,BytesW2AsLong,Ps2AsLong

DimRAsLong,GAsLong,BAsLong,TmpAsLong,Tmp1AsLong,Tmp2AsLong

DimMaxSeAstyRGB,MinSeAstyRGB,BackSeAstyRGB,nStrAsString

DimXAsLong,YAsLong,x0AsLong,y0AsLong,BiAsSingle,nModeAsLong

DimWAsLong,RangeAsLong,x1AsLong,y1AsLong,x2AsLong,y2AsLong

IfNotctRunThenExitSub'防止初始化时多次重复调用

Bi=Val（Combo1.Text）'水印的清晰度0到1

IfBi<0ThenBi=0

IfBi>1ThenBi=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+Combo2.ListIndex'水印边框宽度

nMode=Combo5.ListIndex'水印方式：

彩色\黑白\版画"

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

Picture2.Cls:

Picture2.Visible=NotIsText

IfIsTextThen

nStr=Text1.Text '水印文字

Picture2.BackColor=RGB（120,120,120）

CallWaterStr（nStr,W,Tmp,RGB（Tmp1,Tmp1,Tmp1）,RGB（Tmp2,Tmp2,Tmp2））

Else

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

Picture2.Picture=Picture2.Picture

EndIf

IfCheck1.Value=1Then'下凹水印，否则为上凸水印

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

EndIf

Picture1.Cls:

Picture1.Refresh

GetBmpDatPicture1,W1,H1,BM1,Bs1,BytesW1,

展开阅读全文