flysoft.image 缩略水印组件

原创 2007年09月21日 11:50:00

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

c# 图片处理类(缩略水印等)

c# 图片处理类(缩略水印等)using System; using System.Collections; using System.IO; using System.Drawing; using ...

图像缩略与加水印

//图像处理工具类 import java.awt.Color; import java.awt.Font; import java.awt.Graphics; import java.awt.Gra...

python(pil)图像处理(等比例压缩、裁剪压缩) 缩略(水印)图

我在这里就不多说了,直接上代码: #coding:utf-8 ''' python图片处理 @author:fc_lamp @blog:http://fc-lamp....
  • c2a2o2
  • c2a2o2
  • 2017年06月01日 13:51
  • 743

图片处理类 只有简单的水印缩略功能 手累

调试花时间/* 想操作图片 先得到图片大小 类型信息 水印:就是把指定的水印复制到目标上 并加透明效果 imagecopymerge — 拷贝并合并图像的一部分 最后的参数是透明读 缩略...

C#缩略、水印图片

  • 2012年02月14日 16:25
  • 8KB
  • 下载

ASP.NET(C#)缩略图片,添加文字水印和图片水印

本小项目注释清楚,分别用的文件是Default.aspx、PFile.cs和Images(最终结果的文件)、Temporary(临时文件)、WtermarkPic(水印的附加)这3个文件夹; 如有发...

HTML5按比例缩略图片并上传的实例

本文将介绍使用HTML5实现在客户端按比例缩略图片,并异步上传到服务器的实例。上传图片并生成缩略图,一般是先把图片上传到服务器,然后服务端再对图片进行缩略处理,生成缩略图片。 这样做有两个缺点: 1....
  • fdipzone
  • fdipzone
  • 2017年03月19日 19:23
  • 15485

Java 自动生成缩略图片

一、自动生成缩略图方法: package writeimg; import java.awt.geom.AffineTransform; import java.awt.image.AffineT...

图片相关操作(截取,缩略,翻转。。。。)

在ios开发中,肯定会碰到需要截取部分图片的情况。 最终的效果类似这样: 先看最原始的示例,显示完整的图片 写了个最简单的读取图片并显示的代码,打算以此为开始,逐渐实现截取部分图片的功能。 ...
  • iunion
  • iunion
  • 2012年05月03日 17:46
  • 5981
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:flysoft.image 缩略水印组件
举报原因:
原因补充:

(最多只允许输入30个字)