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

　2008-03-08 12:54:12　来源：WEB开发网　闂傚倸鍊搁崐鎼佸磹妞嬪孩顐芥慨姗嗗厳缂傛氨鎲稿鍫罕闂備礁婀遍搹搴ㄥ窗閺嶎偆涓嶆い鏍仦閻撱儵鏌ｉ弴鐐测偓鍦偓姘炬嫹

闂傚倸鍊搁崐鎼佸磹妞嬪海鐭嗗〒姘ｅ亾妤犵偛顦甸弫鎾绘偐閹绘帞鈧參姊哄Ч鍥х仼闁诲繑鑹鹃悾鐑藉蓟閵夛妇鍘甸梺瑙勵問閸犳牠銆傛總鍛婄厱閹艰揪绱曟牎闂侀潧娲ょ€氫即鐛幒妤€绠ｆ繝闈涘暙娴滈箖鏌ｉ姀鈶跺湱澹曟繝姘厵闁绘劦鍓氶悘杈ㄤ繆閹绘帞澧涚紒缁樼洴瀹曞崬螖閸愬啠鍓濈换娑樼暆婵犱胶鏁栫紓浣介哺閹瑰洤鐣烽幒鎴僵闁瑰吀鐒﹂悗鎼佹⒒娴ｇ儤鍤€闁搞倖鐗犻獮蹇涙晸閿燂拷

濠电姷鏁告慨鐑藉极閸涘﹥鍙忔い鎾卞灩缁狀垶鏌涢幇闈涙灈鐎瑰憡绻冮妵鍕箻鐎靛摜鐣奸梺纭咁潐濞茬喎顫忕紒妯肩懝闁逞屽墮宀ｈ儻顦查悡銈夋煏閸繃鍋繛宸簻鎯熼梺瀹犳〃閼冲爼宕濋敃鈧—鍐Χ閸℃鐟愰梺鐓庡暱閻栧ジ宕烘繝鍥у嵆闁靛骏绱曢崢顏堟⒑閹肩偛鍔楅柡鍛⊕缁傛帟顦寸紒杈ㄥ笚濞煎繘鍩℃担閿嬵潟闂備浇妗ㄩ悞锕傚箲閸ヮ剙鏋侀柟鍓х帛閺呮悂鏌ㄩ悤鍌涘闂傚倸鍊搁崐鎼佸磹妞嬪孩顐芥慨姗嗗厳缂傛氨鎲稿鍫罕闂備礁婀遍搹搴ㄥ窗閺嶎偆涓嶆い鏍仦閻撱儵鏌ｉ弴鐐测偓鍦偓姘炬嫹　　闂傚倸鍊搁崐鎼佸磹閻戣姤鍤勯柤鍝ユ暩娴犳氨绱撻崒娆掑厡缂侇噮鍨堕妴鍐川閺夋垹鍘洪悗骞垮劚椤︻垶宕￠幎鑺ョ厪闊洦娲栨牎闂佽瀵掗崜鐔奉潖閾忓湱纾兼俊顖氭惈椤矂姊虹拠鑼婵ǜ鍔戦崺鈧い鎺嶇閸ゎ剟鏌涢幘璺烘瀻妞ゎ偄绻愮叅妞ゅ繐瀚悗顓烆渻閵堝棙绀€闁瑰啿閰ｅ畷婊勫鐎涙ǚ鎷洪梻渚囧亞閸嬫盯鎳熼娑欐珷妞ゆ柨澧界壕鐓庮熆鐠虹尨鍔熺紒澶庢閳ь剚顔栭崰鏍€﹂柨瀣╃箚婵繂鐭堝Σ鐑芥⒑缁嬫鍎愰柟鐟版搐铻為柛鎰╁妷濡插牊绻涢崱妤冪婵炲牊锕㈠缁樻媴妞嬪簼瑕嗙紓鍌氱М閸嬫挻绻涚€涙ḿ鐭ら柛鎾跺枛瀹曟椽鍩€椤掍降浜滈柟鐑樺灥閳ь剙缍婂鎶筋敆閸曨剛鍘遍柣搴秵娴滅兘鐓鍌楀亾鐟欏嫭纾婚柛妤€鍟块锝夊磹閻曚焦鞋闂備礁鎼Λ瀵哥不閹捐钃熼柕濞炬櫆閸嬪棝鏌涚仦鍓р槈妞ゅ骏鎷�

核心提示：工程名flysoft 类模块image.clsOption EXPlicit'*'CSDN VB版 online(龙卷风3.0 笑傲江湖)'2005-6-30日修改部分代码'名称:缩略水印组件'时间:2005-02-11'功能:增加了文字水印功能'时间:2005-

工程名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即可