工程名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 = CreateCompatible