VB小程序源代码为图片添加水印文字或水印图案Word文件下载.docx
- 文档编号:20492100
- 上传时间:2023-01-23
- 格式:DOCX
- 页数:15
- 大小:19.40KB
VB小程序源代码为图片添加水印文字或水印图案Word文件下载.docx
《VB小程序源代码为图片添加水印文字或水印图案Word文件下载.docx》由会员分享,可在线阅读,更多相关《VB小程序源代码为图片添加水印文字或水印图案Word文件下载.docx(15页珍藏版)》请在冰豆网上搜索。
位图的内存指针
EndType
PrivateDeclareFunctionGetObjectLib&
quot;
gdi32&
Alias&
GetObjectA&
(ByValhObjectAsLong,ByValnCountAsLong,lpObjectAsAny)AsLong
PrivateDeclareFunctionGetBitmapBitsLib&
(ByValhBitmapAsLong,ByValdwCountAsLong,lpBitsAsAny)AsLong
PrivateDeclareFunctionSetBitmapBitsLib&
PrivateTypetyRGB
RAsLong:
GAsLong:
BAsLong
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=&
amp;
H888888
Picture2.Picture=Me.Icon
SetShape1.Container=Picture1
Shape1.DrawMode=14
Shape1.FillStyle=0
DimIAsLong
ForI=1To9
Combo1.AddItem&
0.&
&
I&
水印清晰度&
Next
1
水印清晰度&
Combo1.ListIndex=4
Combo2.AddItem&
阴影宽度1&
阴影宽度2&
阴影宽度3&
Combo2.ListIndex=0
ForI=0ToScreen.FontCount-1
Combo3.AddItemScreen.Fonts(I)
Combo3.Text=&
宋体&
ForI=3To72Step3
Combo4.AddItemI&
号&
Combo4.Text=&
15号&
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
PrivateSubPicture1_MouseDown(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
Picture1.ZOrder
PrivateSubPicture1_MouseMove(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
DimWAsLong,HAsLong
IfButton&
lt;
gt;
1ThenExitSub
W=Picture2.ScaleWidth:
H=Picture2.ScaleHeight
Shape1.MoveX-W*0.5,Y-H*0.5,W,H
Shape1.Visible=True
PrivateSubPicture1_MouseUp(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
1OrNotShape1.VisibleThenExitSub
Shape1.Visible=False
CallAddWater(ctIsText)
PrivateSubPicture2_Click()
Picture2.ZOrder
PrivateSubText1_Change()
CallAddWater(ctIsText)'
文字水印
PrivateSubCombo1_Click()
PrivateSubCombo2_Click()
PrivateSubCombo3_Click()
PrivateSubCombo4_Click()
PrivateSubCombo5_Click()
PrivateSubCombo6_Click()
PrivateSubCheck1_Click()
PrivateSubCheck2_Click()
PrivateSubCheck3_Click()
PrivateSubCommand1_Click()
CallAddWater(True)'
PrivateSubCommand2_Click()
CallAddWater
图片水印
PrivateSubCommand3_Click()
加载水印图案
StaticFAsString
DimnFAsString
IfF=&
ThenF=App.Path&
\头像.jpg&
nF=SelectFile(F,&
加载水印图案&
IfnF=&
ThenExitSub
IfNotLoadPic(Picture2,nF)ThenExitSub
F=nF
PrivateSubCommand4_Click()
加载背景图片
IfctF=&
ThenctF=App.Path&
\Tu1.jpg&
nF=SelectFile(ctF,&
IfNotLoadPic(Picture1,nF)ThenExitSub
ctF=nF
Shape1.Move0,0
CallAddWater(ctIsText)
PrivateSubCommand5_Click()
保存图片
DimnFAsString,IAsLong
\Tu1&
nF=ctF
ForI=Len(nF)To1Step-1'
去掉扩展名
IfMid(nF,I,1)=&
\&
ThenExitFor
.&
Then
nF=Left(nF,I-1):
ExitFor
EndIf
nF=SelectFile(nF,&
True)
IfUCase(Right(nF,4))&
.BMP&
MsgBox&
无法保存为这种格式的文件:
vbCrLf&
nF,vbInformation
ExitSub
OnErrorGoToErr1
SavePicturePicture1.Image,nF
Err1:
错误:
Err.Description,vbInformation,&
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
H4+&
H1000'
隐藏只读复选框、只能输入已列出文件名
图片文件
*.jpg;
*.gif;
*.ico;
*.bmp|*.jpg;
*.bmp|所有文件
*.*|*.*&
文件过滤器
.ShowOpen'
显示打开对话框
IfErr.Number=0ThenSelectFile=.FileName
返回选中的文件名
EndWith
SetnDLG=Nothing
EndFunction
PrivateFunctionLoadPic(KjAsControl,FAsString)AsBoolean
打开图片文件
Kj.Picture=LoadPicture(F)
LoadPic=True
ExitFunction
无法读取文件:
F,vbInformation
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
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))
Range=Combo6.ListIndex'
设置颜色检测误差的范围,是为了消除jpg图片背景杂色
Picture2.Picture=Picture2.Picture
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
Picture1.Cls:
Picture1.Refresh
GetBmpDatPicture1,W1,H1,BM1,Bs1,BytesW1,
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VB 程序 源代码 图片 添加 水印 文字 图案
![提示](https://static.bdocx.com/images/bang_tan.gif)