ASP组件高级入门与精通系列之二
类别: ASP教程 
工程名flysoft 类模块image.cls
Option Explicit
\'*****************************************************
\'名称:缩略水印组件
\'时间: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 = 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 hmD
End Sub
编译成flysoft.dll即可
Option Explicit
\'*****************************************************
\'名称:缩略水印组件
\'时间: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 = 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 hmD
End Sub
编译成flysoft.dll即可
- 上一篇: ASP组件高级入门与精通系列之一
- 下一篇: ASP组件高级入门与精通系列之三
