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