Asp組件進階入門與精通系列之二

來源:互聯網
上載者:User
進階  

工程名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     &n



相關文章

E-Commerce Solutions

Leverage the same tools powering the Alibaba Ecosystem

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。