ASP Component advanced entry and master series II

Project name: flysoft module image. CLs

Option explicit

'*************************************** **************
'Csdn vb version online (Xtep 3.0)
'2014-6-30

'Name: thumbnail watermark component
'Time:
'Function: added the text watermark function.
'Time:
'Function: added the image watermark function.
'Time:
'Added jpg and GIF image import
'*************************************** **************

'Define the input file name
Private sourcefilename as string
'Define the scaling rate
Private irate as single
'Define the text watermark output string
Private smasktext as string * 256
'Define text font
Private smasktextfontname as string
'Define text skew
Private imarkrotate as single
'Image of the watermark to be pasted
Private maskfilename as string

'Load watermark image
Public property get loadfrommaskimgfile () as Variant
Loadfrommaskimgfile = maskfilename
End Property

Public property let loadfrommaskimgfile (byval vnewvalue as variant)
Maskfilename = vnewvalue
End Property

'Set watermark text Rotation
'Set write attributes
Public property let markrotate (byval vnewvalue as variant)
If vnewvalue = "" then
Imarkrotate = 0
Else
Imarkrotate = vnewvalue * 10
End if
End Property

'Set the watermark font name
'Set write attributes
Public property let masktextfontname (byval vnewvalue as variant)
Smasktextfontname = vnewvalue
End Property

'Define attributes to get the entered watermark text
'Set write attributes
Public property let masktext (byval vnewvalue as variant)
If vnewvalue = "" then
Smasktext = "Tornado Production"
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

'Output thumbnails
Public sub outputimgfile (byval filename as string)

Dim picture1 as new stdpicture

'Check whether the file exists and does not exist. An error is thrown.
If Dir (sourcefilename) <> "" then
Set picture1 = loadpicture (sourcefilename)
Else
Err. Raise vbobjecterror + 513, Err. Description + "An error occurred while loading the file. Please check"
Exit sub
End if

Dim h_as long
Dim VW as long
Dim BM as bitmap
GetObject picture1.handle, Len (BM), BM

Vw = BM. bmwidth
Vl = BM. bmheight

'Create a memory device scenario
Dim hdcsrc as long
Dim hdcdest as long

Hdcsrc = createcompatibledc (0)
Hdcdest = createcompatibledc (0)

'Select the created bitmap into the device scenario.
SelectObject hdcsrc, picture1.handle
'Create a device-related Bitmap Based on the specified size
Dim HMD as long
HMD = createcompatiblebitmap (hdcsrc, VW * irate, h_* irate)
SelectObject hdcdest, HMD

'Processing scaling Mode
Dim lorigmode as long
Dim LRET as long
Lorigmode = setstretchbltmode (hdcdest, stretch_halftone)
'Proportional Scaling
Stretchblt hdcdest, 0, 0, VW * irate, h_* irate, hdcsrc, 0, 0, VW, h_, srccopy

'Restore previous settings
LRET = setstretchbltmode (hdcdest, lorigmode)

'Generate JPEG file
Savejpg HMD, filename

'Delete a device scene
Deletedc hdcsrc
Deletedc hdcdest
'Delete a bitmap object
Deleteobject HMD

End sub

'Text watermark
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

'Check whether the file exists and does not exist. An error is thrown.
If Dir (sourcefilename) <> "" then
Set picture1 = loadpicture (sourcefilename)
Else
Err. Raise vbobjecterror + 513, Err. Description + "An error occurred while loading the file. Please check"
Exit sub
End if

Dim h_as long
Dim VW as long
Dim BM as bitmap
GetObject picture1.handle, Len (BM), BM

Vw = BM. bmwidth
Vl = BM. bmheight

''Creates a memory device.
Dim hdcsrc as long
Dim hdcdest as long

Hdcsrc = createcompatibledc (0)
Hdcdest = createcompatibledc (0)

'Select the created bitmap into the device scenario.
SelectObject hdcsrc, picture1.handle

Dim lf as logfont
Dim hfont as long
Dim NN as long

Lf. lfheight = iheight 'character height
Lf. lfwidth = iwidth' character width
Lf. lfescapement = imarkrotate 'text skew. The clockwise direction is positive, and the total angle of a circle is 3600.
Lf. lforientation = 0' character Skew Angle
Lf. lfweight = 0' font weight
Lf. lfunderline = 0' underlined?
Lf. lfstrikeout = 0' whether to add strikethrough lines
Lf. lfcharset = 1' specifies the character set
Lf. lfoutprecision = 0' output and input precision
Lf. lfclipprecision = 0' cutting precision
Lf. lfquality = 0' set the output quality
Lf. lfpitchandfamily = 0 'font spacing
Lf. lffacename = smasktextfontname + CHR (0) 'font name

'Create logical font
Hfont = createfontindirect (LF)
Setbkmode hdcsrc, transparent

Nn = SelectObject (hdcsrc, hfont)
'Output
'Set text foreground
Settextcolor hdcsrc, icolor

Textout hdcsrc, ileft, iTOP, smasktext, Len (smasktext) * 2

'Create a device-related Bitmap Based on the specified size
Dim HMD as long
HMD = createcompatiblebitmap (hdcsrc, VW * irate, h_* irate)
SelectObject hdcdest, HMD

'Processing scaling Mode
Dim lorigmode as long
Dim LRET as long
Lorigmode = setstretchbltmode (hdcdest, stretch_halftone)
'Proportional Scaling
Stretchblt hdcdest, 0, 0, VW * irate, h_* irate, hdcsrc, 0, 0, VW, h_, srccopy

'Restore previous settings
LRET = setstretchbltmode (hdcdest, lorigmode)

'Generate JPEG file
Savejpg HMD, filename

'Delete a device scene
Deletedc hdcdest
Deletedc hdcsrc
'Delete a bitmap object
Deleteobject NN
Deleteobject hfont
Deleteobject HMD

End sub

'Image watermark
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

'Check whether the file exists and does not exist. An error is thrown.
If Dir (sourcefilename) <> "" then
Set picture1 = loadpicture (sourcefilename)
Else
Err. Raise vbobjecterror + 513, Err. Description + "An error occurred while loading the file. Please check"
Exit sub
End if

If Dir (maskfilename) <> "" then
Set picture2 = loadpicture (maskfilename)
Else
Err. Raise vbobjecterror + 514, Err. Description + "An error occurred while loading the watermark image file. Please check"
Exit sub
End if

Dim h_as long
Dim VW as long
Dim BM as bitmap
GetObject picture1.handle, Len (BM), BM

Vw = BM. bmwidth
Vl = 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

'Create a memory device scenario
Dim hdcsrc as long
Dim hdcsrcmark as long
Dim hdcdest as long

Hdcsrc = createcompatibledc (0)
Hdcsrcmark = createcompatibledc (0)
Hdcdest = createcompatibledc (0)

'Select the created bitmap into the device scenario.
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

'Create a device-related Bitmap Based on the specified size
Dim HMD as long
HMD = createcompatiblebitmap (hdcsrc, VW * irate, h_* irate)
SelectObject hdcdest, HMD

'Processing scaling Mode
Dim lorigmode as long
Dim LRET as long
Lorigmode = setstretchbltmode (hdcdest, stretch_halftone)
'Proportional Scaling
Stretchblt hdcdest, 0, 0, VW * irate, h_* irate, hdcsrc, 0, 0, VW, h_, srccopy

'Restore previous settings
LRET = setstretchbltmode (hdcdest, lorigmode)

'Generate JPEG file
Savejpg HMD, filename
'Delete a device scene
Deletedc hdcdest
Deletedc hdcsrcmark
Deletedc hdcsrc
'Delete a bitmap object
Deleteobject HMD

End sub

Compile it into flysoft. dll.