模块1 Option Explicit '有部分代码不需要,以后可能会用到Public Const LR_LOADFROMFILE = &H10 Public Const IMAGE_BITMAP = 0 Public Const IMAGE_ICON = 1 Public Const IMAGE_CURSOR = 2 Public Const IMAGE_ENHMETAFILE = 3Public Const SRCCOPY As Long = &HCC0020 Public Const BI_RGB = 0& Public Const DIB_RGB_COLORS = 0 '结构BITMAPINFO中包含了RGB值的数组RGBQUAD Public Const STRETCH_HALFTONE As Long = &H4&Public Type BITMAPINFOHEADER '40 字节位图文件头 biSize As Long '结构所需字节数 biWidth As Long '图像宽度 biHeight As Long '图像高度 biPlanes As Integer '必须为1,不用考虑 biBitCount As Integer '颜色位数 biCompression As Long '指定是否压缩,一般取BI_RGB biSizeImage As Long '实际的位图占据的字节数,=biWidth'(必须是4的整数〕*biHeight biXPelsPerMeter As Long '水平分辨率 biYPelsPerMeter As Long '垂直分辨率 biClrUsed As Long '本图像用到的实际实际颜色数 biClrImportant As Long '本图像中重要的颜色数,为0,则认为所有的图像都是重要的 End TypePublic Type RGBQUAD rgbBlue As Byte '该颜色的蓝色分量 rgbGreen As Byte '该颜色的绿色分量 rgbRed As Byte '该颜色的红色分量 rgbReserved As Byte '保留值 End TypePublic Type Bitmap bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End TypePublic Type BitmapInfo bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End TypePublic Type BITMAPFILEHEADER bfType(1 To 2) As Byte bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BitmapInfo, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitmapInfo, ByVal wUsage As Long) As Long Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitmapInfo, ByVal wUsage As Long) As Long Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
模块2 Option Explicit'以下是输出文字水印的api Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPublic Const LF_FACESIZE = 32 Public Const TRANSPARENT = 1 '逻辑字体结构 Public Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * LF_FACESIZE End Type'图片水印透明处理 Public Declare Function AlphaBlend Lib "MSIMG32.dll" ( _ ByVal hdcDest As Long, _ ByVal nXOriginDest As Long, _ ByVal nYOriginDest As Long, _ ByVal nWidthDest As Long, _ ByVal nHeightDest As Long, _ ByVal hdcSrc As Long, _ ByVal nXOriginSrc As Long, _ ByVal nYOriginSrc As Long, _ ByVal nWidthSrc As Long, _ ByVal nHeightSrc As Long, _ ByVal lBlendFunction As Long _ ) As LongPublic Type BLENDFUNCTION BlendOp As Byte BlendFlags As Byte SourceConstantAlpha As Byte AlphaFormat As Byte End Type ' BlendOp: Public Const AC_SRC_OVER = &H0 ' AlphaFormat: Public Const AC_SRC_ALPHA = &H1
模块3 Option Explicit'以下是GDI+的声明 Public Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End TypePublic Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End TypePublic Type EncoderParameter GUID As GUID NumberOfValues As Long type As Long Value As Long End TypePublic Type EncoderParameters Count As Long Parameter As EncoderParameter End TypePublic Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long Public Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long Public Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long Public Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long Public Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long Public Declare Function GdipSaveImageToStream Lib "GDIPlus" (ByVal Image As Long, ByVal stream As Long, clsidEncoder As GUID, encoderParams As Any) As Long Public Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long'保存成jpeg格式 Public Sub SaveJPG(ByVal pict As Long, ByVal filename As String, Optional ByVal quality As Byte = 100) Dim tSI As GdiplusStartupInput Dim lRes As Long Dim lGDIP As Long Dim lBitmap As Long ' Initialize GDI+ tSI.GdiplusVersion = 1 lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then
' Create the GDI+ bitmap ' from the image handle lRes = GdipCreateBitmapFromHBITMAP(pict, 0, lBitmap)
If lRes = 0 Then Dim tJpgEncoder As GUID Dim tParams As EncoderParameters
' Initialize the encoder GUID CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _ tJpgEncoder
' Initialize the encoder parameters tParams.Count = 1 With tParams.Parameter ' Quality ' Set the Quality GUID CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB3505E7EB}"), .GUID .NumberOfValues = 1 .type = 1 .Value = VarPtr(quality) End With
' Save the image lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
' Destroy the bitmap GdipDisposeImage lBitmap
End If
' Shutdown GDI+ GdiplusShutdown lGDIP End If
If lRes Then Err.Raise vbObjectError + 515, , "保存图像发生了错误,错误号:" & lRes End If
End Sub
类模块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 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 SubPublic 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 vh As Long Dim vw As Long Dim bmm As Bitmap GetObject picture2.handle, Len(bmm), bmmvw = bmm.bmWidth vh = 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, vw, vh, hdcSrcMark, 0, 0, vw, vh, 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
www.applevb.com/flysoft.rar下载,不过没有源码
>_< B4老大又占沙发,偶只能板凳,5555~~
www.applevb.com/flysoft.rar下载有asp的示例页面,可以对照组件看
您好,我看了你的水印的实例有点问题想请教一下: 我的这个图片是动态生成的,其代码如下: <% '用一个临时变量名保存当前文件,这个文件名是唯一的 set m_fso = CreateObject("Scripting.FileSystemObject") sFullFileName = Server.MapPath(".") & "\" & m_fso.GetTempName() m_cspace.ExportPicture sFullFileName, "GIF", 500, 400 '使用 On Error Resume Next语句是为了确保我们删除了临时文件,即使一些函数调用失败 on error resume next 'GIF文件已经输出,我们可以通过COM组件把它的内容发送到客户端 set m_objBinaryFile = server.CreateObject("BinFileWrite.GetFileStream") 'Response.BinaryWrite m_objBinaryFile.GetFileBytes(CStr(sFullFileName)) m_objBinaryFile.SendBinFile CStr(sFullFileName),"image/GIF",TRUE,FALSE,TRUE,TRUE,TRUE 'GIF文件已经不需要了可以删除了 m_objBinaryFile.DeleteFile CStr(sFullFileName) %>您的代码里是这样的: <% '生成图片水印 On Error resume next set obj=server.CreateObject("flysoft.image") obj.Rate = 0.5 '缩放比率 其中<1为缩小,>1为放大 obj.LoadFromFile = server.MapPath("./love.JPG") '原始图片 obj.LoadFromMaskImgFile = server.MapPath("./rose_.bmp") '水印图片 obj.OutputMarkImgFile server.MapPath("./love.jpg"), 350, 350, 100 '生成结果图片 500,500为水印图片相对于原始图片左上角的坐标位置 最后的100是透明度 (0最透明,100不透明) if err.number<>0 then response.write Err.Description end if %> 都是固定图片,所以我不知道怎么把他们相互结合起来, 请指点指点啊!!! 谢谢!!
Option Explicit
'有部分代码不需要,以后可能会用到Public Const LR_LOADFROMFILE = &H10
Public Const IMAGE_BITMAP = 0
Public Const IMAGE_ICON = 1
Public Const IMAGE_CURSOR = 2
Public Const IMAGE_ENHMETAFILE = 3Public Const SRCCOPY As Long = &HCC0020
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0 '结构BITMAPINFO中包含了RGB值的数组RGBQUAD
Public Const STRETCH_HALFTONE As Long = &H4&Public Type BITMAPINFOHEADER '40 字节位图文件头
biSize As Long '结构所需字节数
biWidth As Long '图像宽度
biHeight As Long '图像高度
biPlanes As Integer '必须为1,不用考虑
biBitCount As Integer '颜色位数
biCompression As Long '指定是否压缩,一般取BI_RGB
biSizeImage As Long '实际的位图占据的字节数,=biWidth'(必须是4的整数〕*biHeight
biXPelsPerMeter As Long '水平分辨率
biYPelsPerMeter As Long '垂直分辨率
biClrUsed As Long '本图像用到的实际实际颜色数
biClrImportant As Long '本图像中重要的颜色数,为0,则认为所有的图像都是重要的
End TypePublic Type RGBQUAD
rgbBlue As Byte '该颜色的蓝色分量
rgbGreen As Byte '该颜色的绿色分量
rgbRed As Byte '该颜色的红色分量
rgbReserved As Byte '保留值
End TypePublic Type Bitmap
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End TypePublic Type BitmapInfo
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End TypePublic Type BITMAPFILEHEADER
bfType(1 To 2) As Byte
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BitmapInfo, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitmapInfo, ByVal wUsage As Long) As Long
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitmapInfo, ByVal wUsage As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Option Explicit'以下是输出文字水印的api
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPublic Const LF_FACESIZE = 32
Public Const TRANSPARENT = 1
'逻辑字体结构
Public Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type'图片水印透明处理
Public Declare Function AlphaBlend Lib "MSIMG32.dll" ( _
ByVal hdcDest As Long, _
ByVal nXOriginDest As Long, _
ByVal nYOriginDest As Long, _
ByVal nWidthDest As Long, _
ByVal nHeightDest As Long, _
ByVal hdcSrc As Long, _
ByVal nXOriginSrc As Long, _
ByVal nYOriginSrc As Long, _
ByVal nWidthSrc As Long, _
ByVal nHeightSrc As Long, _
ByVal lBlendFunction As Long _
) As LongPublic Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
' BlendOp:
Public Const AC_SRC_OVER = &H0
' AlphaFormat:
Public Const AC_SRC_ALPHA = &H1
Option Explicit'以下是GDI+的声明
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End TypePublic Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End TypePublic Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End TypePublic Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End TypePublic Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Public Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Public Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Public Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Public Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Public Declare Function GdipSaveImageToStream Lib "GDIPlus" (ByVal Image As Long, ByVal stream As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Public Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long'保存成jpeg格式
Public Sub SaveJPG(ByVal pict As Long, ByVal filename As String, Optional ByVal quality As Byte = 100)
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long ' Initialize GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then
' Create the GDI+ bitmap
' from the image handle
lRes = GdipCreateBitmapFromHBITMAP(pict, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
' Initialize the encoder GUID
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
tJpgEncoder
' Initialize the encoder parameters
tParams.Count = 1
With tParams.Parameter ' Quality
' Set the Quality GUID
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB3505E7EB}"), .GUID
.NumberOfValues = 1
.type = 1
.Value = VarPtr(quality)
End With
' Save the image
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
' Destroy the bitmap
GdipDisposeImage lBitmap
End If
' Shutdown GDI+
GdiplusShutdown lGDIP End If
If lRes Then
Err.Raise vbObjectError + 515, , "保存图像发生了错误,错误号:" & lRes
End If
End Sub
'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 SubPublic 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 vh As Long
Dim vw As Long
Dim bmm As Bitmap
GetObject picture2.handle, Len(bmm), bmmvw = bmm.bmWidth
vh = 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, vw, vh, hdcSrcMark, 0, 0, vw, vh, 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
我的这个图片是动态生成的,其代码如下:
<%
'用一个临时变量名保存当前文件,这个文件名是唯一的
set m_fso = CreateObject("Scripting.FileSystemObject")
sFullFileName = Server.MapPath(".") & "\" & m_fso.GetTempName()
m_cspace.ExportPicture sFullFileName, "GIF", 500, 400
'使用 On Error Resume Next语句是为了确保我们删除了临时文件,即使一些函数调用失败
on error resume next
'GIF文件已经输出,我们可以通过COM组件把它的内容发送到客户端
set m_objBinaryFile = server.CreateObject("BinFileWrite.GetFileStream")
'Response.BinaryWrite m_objBinaryFile.GetFileBytes(CStr(sFullFileName))
m_objBinaryFile.SendBinFile CStr(sFullFileName),"image/GIF",TRUE,FALSE,TRUE,TRUE,TRUE
'GIF文件已经不需要了可以删除了
m_objBinaryFile.DeleteFile CStr(sFullFileName)
%>您的代码里是这样的:
<%
'生成图片水印
On Error resume next
set obj=server.CreateObject("flysoft.image")
obj.Rate = 0.5 '缩放比率 其中<1为缩小,>1为放大
obj.LoadFromFile = server.MapPath("./love.JPG") '原始图片
obj.LoadFromMaskImgFile = server.MapPath("./rose_.bmp") '水印图片
obj.OutputMarkImgFile server.MapPath("./love.jpg"), 350, 350, 100 '生成结果图片 500,500为水印图片相对于原始图片左上角的坐标位置 最后的100是透明度 (0最透明,100不透明)
if err.number<>0 then
response.write Err.Description
end if
%>
都是固定图片,所以我不知道怎么把他们相互结合起来, 请指点指点啊!!!
谢谢!!
也帮我看看这个吧
谢谢````````````
ONLINE太COOL闭了
set m_fso = CreateObject("Scripting.FileSystemObject")
sFullFileName = Server.MapPath(".") & "\" & m_fso.GetTempName()
m_cspace.ExportPicture sFullFileName, "GIF", 500, 400'生成图片水印
On Error resume next
set obj=server.CreateObject(".image")
obj.Rate = 0.5 '缩放比率 其中<1为缩小,>1为放大
obj.LoadFromFile = sFullFileName '原始图片
obj.LoadFromMaskImgFile = server.MapPath("zm.jpg") '水印图片
obj.OutputMarkImgFile sFullFileName, 100, 100, 100 '生成结果图片 500,500为水印图片相对于原始图片左上角的坐标位置 最后的100是透明度 (0最透明,100不透明)
if err.number<>0 then
response.write Err.Description
end if'使用 On Error Resume Next语句是为了确保我们删除了临时文件,即使一些函数调用失败
on error resume next
'GIF文件已经输出,我们可以通过COM组件把它的内容发送到客户端
set m_objBinaryFile = server.CreateObject("BinFileWrite.GetFileStream")
'Response.BinaryWrite m_objBinaryFile.GetFileBytes(CStr(sFullFileName))
m_objBinaryFile.SendBinFile CStr(sFullFileName),"image/GIF",TRUE,FALSE,TRUE,TRUE,TRUE
'GIF文件已经不需要了可以删除了
m_objBinaryFile.DeleteFile CStr(sFullFileName)
%>怎么改啊?