王朝网络
分享
 
 
 

Asp组件高级入门与精通系列之二

王朝asp·作者佚名  2008-06-01
宽屏版  字体: |||超大  

工程名flysoft 类模块image.clsOption EXPlicit'*****************************************************

'CSDN VB版 online(龙卷风3.0 笑傲江湖)

'2005-6-30日修改部分代码'名称:缩略水印组件

'时间:2005-02-11

'功能:增加了文字水印功能

'时间:2005-02-12

'功能:增加了图片水印功能

'时间:2005-02-13

'增加了对jpg,gif图像导入

'*****************************************************'定义输入文件名

Private SourceFileName As String

'定义缩放率

Private iRate As Single

'定义文字水印输出字符串

Private sMaskText As String * 256

'定义文字字体

Private sMaskTextFontName As String

'定义文本倾斜度

Private iMarkRotate As Single

'需要贴的水印的图片

Private MaskFileName As String'装载水印图片

Public Property Get LoadFromMaskImgFile() As Variant

LoadFromMaskImgFile = MaskFileName

End PropertyPublic Property Let LoadFromMaskImgFile(ByVal vNewValue As Variant)

MaskFileName = vNewValue

End Property'设置水印文本旋转度

'设置写入属性

Public Property Let MarkRotate(ByVal vNewValue As Variant)

If vNewValue = "" Then

iMarkRotate = 0

Else

iMarkRotate = vNewValue * 10

End If

End Property'设置水印字体名称

'设置写入属性

Public Property Let MaskTextFontName(ByVal vNewValue As Variant)

sMaskTextFontName = vNewValue

End Property'定义属性,得到输入的水印文字

'设置写入属性

Public Property Let MaskText(ByVal vNewValue As Variant)

If vNewValue = "" Then

sMaskText = "龙卷风制作"

Else

sMaskText = vNewValue

End If

End PropertyPublic Property Let LoadFromFile(ByVal vNewValue As Variant)

SourceFileName = vNewValue

End PropertyPublic Property Let Rate(ByVal vNewValue As Variant)

iRate = vNewValue

End Property'输出缩略图

Public Sub OutputImgFile(ByVal filename As String)Dim picture1 As New StdPicture'判定文件是否存在,不存在抛出错误

If Dir(SourceFileName) <> "" Then

Set picture1 = LoadPicture(SourceFileName)

Else

Err.Raise vbObjectError + 513, , Err.Description + "装载文件时发生了错误,请检查"

Exit Sub

End If

Dim vh As Long

Dim vw As Long

Dim bm As Bitmap

GetObject picture1.handle, Len(bm), bmvw = bm.bmWidth

vh = bm.bmHeight

'创建一个内存设备场景

Dim hdcSrc As Long

Dim hdcDest As LonghdcSrc = CreateCompatibleDC(0)

hdcDest = CreateCompatibleDC(0)'将创建的位图选入设备场景

SelectObject hdcSrc, picture1.handle

'按照指定大小创建一幅与设备有关位图

Dim hmD As Long

hmD = CreateCompatibleBitmap(hdcSrc, vw * iRate, vh * iRate)

SelectObject hdcDest, hmD'处理伸缩模式

Dim lOrigMode As Long

Dim lRet As Long

lOrigMode = SetStretchBltMode(hdcDest, STRETCH_HALFTONE)

'按照比例缩放

StretchBlt hdcDest, 0, 0, vw * iRate, vh * iRate, hdcSrc, 0, 0, vw, vh, SRCCOPY

'恢复以前的设置

lRet = SetStretchBltMode(hdcDest, lOrigMode)'生成jpeg文件

SaveJPG hmD, filename

'删除设备场景

DeleteDC hdcSrc

DeleteDC hdcDest

'删除位图对象

DeleteObject hmDEnd Sub'文字水印

Public Sub OutputTxtImgFile(ByVal filename As String, ByVal iColor As String, Optional ByVal iWidth As Single = 20, Optional ByVal iHeight As Single = 50, Optional ByVal iLeft As Single = 10, Optional ByVal iTop As Single = 100)Dim picture1 As New StdPicture'判定文件是否存在,不存在抛出错误

If Dir(SourceFileName) <> "" Then

Set picture1 = LoadPicture(SourceFileName)

Else

Err.Raise vbObjectError + 513, , Err.Description + "装载文件时发生了错误,请检查"

Exit Sub

End IfDim vh As Long

Dim vw As Long

Dim bm As Bitmap

GetObject picture1.handle, Len(bm), bmvw = bm.bmWidth

vh = bm.bmHeight''创建一个与内存设备场景

Dim hdcSrc As Long

Dim hdcDest As LonghdcSrc = CreateCompatibleDC(0)

hdcDest = CreateCompatibleDC(0)'将创建的位图选入设备场景

SelectObject hdcSrc, picture1.handleDim lf As LOGFONT

Dim hFont As Long

Dim nn As Long

lf.lfHeight = iHeight '字符高度

lf.lfWidth = iWidth '字符宽度

lf.lfEscapement = iMarkRotate '文本倾斜度,逆时针方向为正,一圈总角度为3600

lf.lfOrientation = 0 '字符倾斜角度

lf.lfWeight = 0 '字体的轻重

lf.lfUnderline = 0 '是否加下划线

lf.lfStrikeOut = 0 '是否加删除线

lf.lfCharSet = 1 '指定字符集

lf.lfOutPrecision = 0 '输出、输入精度

lf.lfClipPrecision = 0 '剪辑精度

lf.lfQuality = 0 '设置输出质量

lf.lfPitchAndFamily = 0 '字间距

lf.lfFaceName = sMaskTextFontName + Chr(0) '字体名称

'创建逻辑字体

hFont = CreateFontIndirect(lf)

SetBkMode hdcSrc, TRANSPARENTnn = SelectObject(hdcSrc, hFont)

'输出

'设置文本前景色

SetTextColor hdcSrc, iColorTextOut hdcSrc, iLeft, iTop, sMaskText, Len(sMaskText) * 2'按照指定大小创建一幅与设备有关位图

Dim hmD As Long

hmD = CreateCompatibleBitmap(hdcSrc, vw * iRate, vh * iRate)

SelectObject hdcDest, hmD

'处理伸缩模式

Dim lOrigMode As Long

Dim lRet As Long

lOrigMode = SetStretchBltMode(hdcDest, STRETCH_HALFTONE)

'按照比例缩放

StretchBlt hdcDest, 0, 0, vw * iRate, vh * iRate, hdcSrc, 0, 0, vw, vh, SRCCOPY

'恢复以前的设置

lRet = SetStretchBltMode(hdcDest, lOrigMode)'生成jpeg文件

SaveJPG hmD, filename'删除设备场景

DeleteDC hdcDest

DeleteDC hdcSrc

'删除位图对象

DeleteObject nn

DeleteObject hFont

DeleteObject hmDEnd Sub'图片水印

Public Sub OutputMarkImgFile(ByVal filename As String, Optional ByVal iLeft As Single = 10, Optional ByVal iTop As Single = 100, Optional Alpha As Single = 70)Dim picture1 As New StdPicture

Dim picture2 As New StdPicture'判定文件是否存在,不存在抛出错误

If Dir(SourceFileName) <> "" Then

Set picture1 = LoadPicture(SourceFileName)

Else

Err.Raise vbObjectError + 513, , Err.Description + "装载文件时发生了错误,请检查"

Exit Sub

End IfIf Dir(MaskFileName) <> "" Then

Set picture2 = LoadPicture(MaskFileName)

Else

Err.Raise vbObjectError + 514, , Err.Description + "装载水印图片文件时发生了错误,请检查"

Exit Sub

End If

Dim vh As Long

Dim vw As Long

Dim bm As Bitmap

GetObject picture1.handle, Len(bm), bmvw = bm.bmWidth

vh = bm.bmHeightDim vhmark As Long

Dim vwmark As Long

Dim bmm As Bitmap

GetObject picture2.handle, Len(bmm), bmmvwmark = bmm.bmWidth

vhmark = bmm.bmHeight

'创建一个内存设备场景

Dim hdcSrc As Long

Dim hdcSrcMark As Long

Dim hdcDest As LonghdcSrc = CreateCompatibleDC(0)

hdcSrcMark = CreateCompatibleDC(0)

hdcDest = CreateCompatibleDC(0)'将创建的位图选入设备场景

SelectObject hdcSrc, picture1.handle

SelectObject hdcSrcMark, picture2.handleSetBkMode hdcSrc, TRANSPARENTDim lBlend As Long

Dim bf As BLENDFUNCTIONbf.BlendOp = AC_SRC_OVER

bf.BlendFlags = 0

bf.SourceConstantAlpha = Alpha

bf.AlphaFormat = 0

CopyMemory lBlend, bf, 4

AlphaBlend hdcSrc, iLeft, iTop, vwmark, vhmark, hdcSrcMark, 0, 0, vwmark, vhmark, lBlend

'按照指定大小创建一幅与设备有关位图

Dim hmD As Long

hmD = CreateCompatibleBitmap(hdcSrc, vw * iRate, vh * iRate)

SelectObject hdcDest, hmD

'处理伸缩模式

Dim lOrigMode As Long

Dim lRet As Long

lOrigMode = SetStretchBltMode(hdcDest, STRETCH_HALFTONE)

'按照比例缩放

StretchBlt hdcDest, 0, 0, vw * iRate, vh * iRate, hdcSrc, 0, 0, vw, vh, SRCCOPY'恢复以前的设置

lRet = SetStretchBltMode(hdcDest, lOrigMode)'生成jpeg文件

SaveJPG hmD, filename

'删除设备场景

DeleteDC hdcDest

DeleteDC hdcSrcMark

DeleteDC hdcSrc

'删除位图对象

DeleteObject hmDEnd Sub

编译成flysoft.dll即可

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
>>返回首页<<
推荐阅读
 
 
频道精选
 
静静地坐在废墟上,四周的荒凉一望无际,忽然觉得,凄凉也很美
© 2005- 王朝网络 版权所有