 |
|
|
 首页 |
名片设计 CorelDRAW Illustrator AuotoCAD Painter 其他软件 Photoshop Fireworks Flash |
|
工程名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即可 返回类别: 教程 上一教程: ASP 3.0高级编程(七) 下一教程: 利用J2ME与ASP建立数据库连接 您可以阅读与"ASP组件高级入门与精通系列之二"相关的教程: · ASP组件高级入门与精通系列之一 · ASP组件高级入门与精通系列之三 · Asp组件初级入门与精通系列之二 · ASP组件初级入门与精通系列之四 · ASP组件初级入门与精通系列之六 |
  |
| 快精灵印艺坊 版权所有 |
首页 会员中心在线印刷在线编辑付款方式索取样品设计指南连锁门店
|
||
