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