classjpeg.asp

依蓝旅游网站管理系统Elan2008.SP2

<%
Class ClassJpeg
   
   Private Jpeg
   Private Object_Pictrue, Watermark_Text, Watermark_Text_FontName, Watermark_Text_FontSize
   Private Watermark_Text_FontColor, Watermark_Text_FontBold, Watermark_BgColor, Watermark_Position, ThumbSizes
   Public ThumbFileName, ErrorCode
   
   Private Sub Class_Initialize
      On Error Resume Next
	  ThumbFileName = ""
	  ErrorCode = 0
      Dim JpegCmd
	  Set JpegCmd = Server.CreateObject("ADODB.COMMAND")
	  With JpegCmd
	     .ActiveConnection = Conn
		 .CommandText = "EL_SP_Jpeg"
		 .CommandType = 4
		 .Prepared = True
		 .Parameters.Append .CreateParameter("@Object_Pictrue", 200, 2, 50)
		 .Parameters.Append .CreateParameter("@Watermark_Text", 200, 2, 50)
		 .Parameters.Append .CreateParameter("@Watermark_Text_FontName", 200, 2, 30)
		 .Parameters.Append .CreateParameter("@Watermark_Text_FontSize", 3, 2, 4)
		 .Parameters.Append .CreateParameter("@Watermark_Text_FontColor", 200, 2, 10)
		 .Parameters.Append .CreateParameter("@Watermark_Text_FontBold", 11, 2, 1)
		 .Parameters.Append .CreateParameter("@Watermark_BgColor", 200, 2, 10)
		 .Parameters.Append .CreateParameter("@Watermark_Position", 3, 2, 4)
		 .Parameters.Append .CreateParameter("@ThumbSizes", 200, 2, 20)
		 .Execute()
      End With
	  Object_Pictrue = JpegCmd(0)
	  Watermark_Text = JpegCmd(1)
	  Watermark_Text_FontName = JpegCmd(2)
	  Watermark_Text_FontSize = JpegCmd(3)
	  Watermark_Text_FontColor = JpegCmd(4)
	  Watermark_Text_FontBold = JpegCmd(5)
	  Watermark_BgColor = JpegCmd(6)
	  Watermark_Position = JpegCmd(7)
	  ThumbSizes = JpegCmd(8)
	  Set JpegCmd = Nothing
	  If Err Then
	     Err.Clear
	  End If
	  If ObjectTest(Object_Pictrue) = False Then
	     'Response.Write "<scr" & "ipt>alert('系统无法创建图片处理对象，请检查网站基本配置中的图片处理组件设置是否正确')</scr" & "ipt>"
		 ErrorCode = 1
	     Exit Sub
	  End If
	  Set Jpeg = Server.CreateObject(Object_Pictrue)
	  If Err Then
         Err.Clear
	     Jpeg.Close
	     Set Jpeg = Nothing
		 ErrorCode = 1
		 'Response.Write "<scr" & "ipt>alert('系统无法创建图片处理对象，请检查网站基本配置中的图片处理组件设置是否正确')</scr" & "ipt>"
	     Exit Sub
      End If
	  If Trim(ThumbSizes) = "" Or Instr(ThumbSizes, "*")<2 Or Instr(ThumbSizes, "*")>=Len(ThumbSizes) Then
	     ThumbSizes = "130*90"
	  End If
   End Sub
   
   Private Sub Class_Terminate
      On Error Resume Next
	  If IsObject(Jpeg) Then
	     Jpeg.Close()
		 Set Jpeg = Nothing
	  End If
   End Sub
   
   Public Sub CreateWatermark(ByVal PictruePath)
      On Error Resume Next
	  Dim PictrueWidth, PictrueHeight
      Jpeg.Open PictruePath
	  PictrueWidth = Jpeg.Width
	  PictrueHeight = Jpeg.Height
	  
	  Jpeg.Canvas.Pen.Color = "&H" & Replace(Watermark_BgColor, "#", "")
	  Jpeg.Canvas.Pen.Width = 1
	  Jpeg.Canvas.Brush.Solid = True	  
	  Select Case Watermark_Position
	     Case 0: Jpeg.Canvas.DrawBar 0, (PictrueHeight/2 - 10), PictrueWidth, PictrueHeight/2+10
		 Case 1: Jpeg.Canvas.DrawBar 0, 0, PictrueWidth, 20
		 Case 2: Jpeg.Canvas.DrawBar 0, (PictrueHeight - 20), PictrueWidth, PictrueHeight
	  End Select	  
	  
	  Jpeg.Canvas.Font.Color = "&H" & Replace(Watermark_Text_FontColor, "#", "")
	  Jpeg.Canvas.Font.Family = Watermark_Text_FontName
	  Jpeg.Canvas.Font.Bold = Watermark_Text_FontBold
	  Jpeg.Canvas.Font.Size = Watermark_Text_FontSize
	  Jpeg.Canvas.Font.Quality = 4
	  Select Case Watermark_Position
	     Case 0: Jpeg.Canvas.Print PictrueWidth - (6 * StrLength(Watermark_Text)) - 10, PictrueHeight/2-8, Watermark_Text
		 Case 1: Jpeg.Canvas.Print PictrueWidth - (6 * StrLength(Watermark_Text)) - 10, 4, Watermark_Text
		 Case 2: Jpeg.Canvas.Print PictrueWidth - (6 * StrLength(Watermark_Text)) - 10, PictrueHeight - 16, Watermark_Text
	  End Select
	  Jpeg.Save PictruePath
	  
	  If Err Then
	     Err.Clear
	     'Response.Write "<scr" & "ipt>alert('系统无法正确添加图片水印，请检查网站基本配置中的图片水印设置是否正确')</scr" & "ipt>"
	  End If
   End Sub
   
   Public Sub CreateThumb(ByVal PictruePath, CreateType)
      On Error Resume Next
	  Dim PictrueWidth, PictrueHeight
	  Dim ThumbWith, ThumbHeight
      Jpeg.Open PictruePath
	  PictrueWidth = Jpeg.Width
	  PictrueHeight = Jpeg.Height
	  If ThumbSizes = "" Or IsNUll(ThumbSizes) Then
	     ThumbWith = 140
		 ThumbHeight = 100
	  Else
	     Dim arr
		 arr = Split(ThumbSizes, "*")
		 If Ubound(arr)<1 Then
		    ThumbWith = 140
			ThumbHeight = 100
		 Else
		    If arr(0) = "" Or arr(0) = 0 Then
			   ThumbWith = 140
			Else
			   ThumbWith = Clng(arr(0))
			End If
			If arr(1) = "" Or arr(1) = 0 Then
			   ThumbHeight = 90
			Else
			   ThumbHeight = Clng(arr(1))
			End If
		 End If
	  End If
	  Select Case CreateType
	    Case 0:'普通缩小
		    Jpeg.Width = ThumbWith
			Jpeg.Height = ThumbHeight
		Case 1:'按比例缩小后切割
		    Dim PScale
			PScale = PictrueWidth / PictrueHeight
			If Clng(ThumbHeight * PScale)<ThumbWith Then
			   Jpeg.Width = ThumbWith
			   Jpeg.Height = Clng(ThumbWith / PScale)
			Else
			   Jpeg.Height = ThumbHeight
			   Jpeg.Width = Clng(ThumbHeight * PScale)
			End If			
			Jpeg.Crop 0, 0, ThumbWith, ThumbHeight 
	  End Select
	  Dim arrNewName
	  arrNewName = Split(PictruePath, ".")
	  ThumbFileName = Right(arrNewName(0), Len(arrNewName(0)) - InstrRev(arrNewName(0), "\")) &"_S."& arrNewName(1)
	  Jpeg.Save arrNewName(0) &"_S."& arrNewName(1)
	  If Err Then
	     Err.Clear
		 ErrorCode = 2
	     'Response.Write "<scr" & "ipt>alert('系统无法正确产生缩略图，请检查网站基本配置中的图片缩略图设置是否正确')</scr" & "ipt>"
	  End If
   End Sub
   
   Private Function ObjectTest(strObj)
	  On Error Resume Next	
	  Dim TestObj, IsObj
	  IsObj = False
	  Set TestObj = Server.CreateObject(strObj)
	  If -2147221005 <> Err then
		IsObj = True
	  Else
	    IsObj = False
	    Err.Clear
	  End If
	  Set TestObj = Nothing
	  ObjectTest = IsObj
   End Function
   
   Private Function StrLength(str)
      On Error Resume Next
      Dim WINNT_CHINESE
      WINNT_CHINESE = (Len("中文") = 2)
      If WINNT_CHINESE Then
         Dim l, t, c
         Dim i
         l = Len(str)
         t = l
         For i = 1 To l
           c = Asc(Mid(str, i, 1))
           If c < 0 Then c = c + 65536
           If c > 255 Then
               t = t + 1
           End If
         Next
         strLength = t
      Else
         strLength = Len(str)
      End If
      If Err.Number <> 0 Then Err.Clear
   End Function
   
End Class
%>