分享
 
 
 

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

王朝asp·作者佚名  2006-11-24
窄屏简体版  字體: |||超大  

工程名flysoft 类模块image.cls

Option 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 Property

Public 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 Property

Public Property Let LoadFromFile(ByVal vNewValue As Variant)

SourceFileName = vNewValue

End Property

Public 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), bm

vw = bm.bmWidth

vh = bm.bmHeight

'创建一个内存设备场景

Dim hdcSrc As Long

Dim hdcDest As Long

hdcSrc = 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 hmD

End 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 If

Dim vh As Long

Dim vw As Long

Dim bm As Bitmap

GetObject picture1.handle, Len(bm), bm

vw = bm.bmWidth

vh = bm.bmHeight

''创建一个与内存设备场景

Dim hdcSrc As Long

Dim hdcDest As Long

hdcSrc = CreateCompatibleDC(0)

hdcDest = CreateCompatibleDC(0)

'将创建的位图选入设备场景

SelectObject hdcSrc, picture1.handle

Dim 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, TRANSPARENT

nn = SelectObject(hdcSrc, hFont)

'输出

'设置文本前景色

SetTextColor hdcSrc, iColor

TextOut 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 hmD

End 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 If

If 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), bm

vw = bm.bmWidth

vh = bm.bmHeight

Dim vhmark As Long

Dim vwmark As Long

Dim bmm As Bitmap

GetObject picture2.handle, Len(bmm), bmm

vwmark = bmm.bmWidth

vhmark = bmm.bmHeight

'创建一个内存设备场景

Dim hdcSrc As Long

Dim hdcSrcMark As Long

Dim hdcDest As Long

hdcSrc = CreateCompatibleDC(0)

hdcSrcMark = CreateCompatibleDC(0)

hdcDest = CreateCompatibleDC(0)

'将创建的位图选入设备场景

SelectObject hdcSrc, picture1.handle

SelectObject hdcSrcMark, picture2.handle

SetBkMode hdcSrc, TRANSPARENT

Dim lBlend As Long

Dim bf As BLENDFUNCTION

bf.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 = C

[1] [2] 下一页

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
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- 王朝網路 版權所有