asp 產生圖片縮圖代碼

<%
'======================================================
' 檔案名稱 : Inc/ClsJpeg.asp
' 檔案作用 : 浮水印+縮減類
' 最後更新 : 2008.08.02
'======================================================

Dim PhotoObject,Thumb_DefaultWidth,Thumb_DefaultHeight,Thumb_Arithmetic,Thumb_BackgroundColor,PhotoQuanlity
Dim Watermark_Type,Watermark_Text,Watermark_Text_FontName,Watermark_Text_FontSize,Watermark_Text_FontColor
Dim Watermark_Text_Bold,Watermark_Images_FileName,Watermark_Images_Transparence,Watermark_Images_BackgroundColor
Dim Watermark_Position_X,Watermark_Position_Y,Watermark_Position

PhotoObject                      = Int(ClsCommon.FlowerSetting("PhotoObject"))
Thumb_DefaultWidth               = ClsCommon.FlowerSetting("Thumb_DefaultWidth")
Thumb_DefaultHeight              = ClsCommon.FlowerSetting("Thumb_DefaultHeight")
Thumb_Arithmetic                 = ClsCommon.FlowerSetting("Thumb_Arithmetic")
Thumb_BackgroundColor            = ClsCommon.FlowerSetting("Thumb_BackgroundColor")
PhotoQuanlity                    = ClsCommon.FlowerSetting("PhotoQuanlity")
Watermark_Type                   = Int(ClsCommon.FlowerSetting("Watermark_Type"))
Watermark_Text                   = ClsCommon.FlowerSetting("Watermark_Text")
Watermark_Text_FontName          = ClsCommon.FlowerSetting("Watermark_Text_FontName")
Watermark_Text_FontSize          = ClsCommon.FlowerSetting("Watermark_Text_FontSize")
Watermark_Text_FontColor         = ClsCommon.FlowerSetting("Watermark_Text_FontColor")
Watermark_Text_Bold              = ClsCommon.FlowerSetting("Watermark_Text_Bold")
Watermark_Images_FileName        = ClsCommon.FlowerSetting("Watermark_Images_FileName")
Watermark_Images_Transparence    = ClsCommon.FlowerSetting("Watermark_Images_Transparence")
Watermark_Images_BackgroundColor = ClsCommon.FlowerSetting("Watermark_Images_BackgroundColor")
Watermark_Position_X             = ClsCommon.FlowerSetting("Watermark_Position_X")
Watermark_Position_Y             = ClsCommon.FlowerSetting("Watermark_Position_Y")
Watermark_Position               = ClsCommon.FlowerSetting("Watermark_Position")

If Watermark_Position = "" Then Watermark_Position = "1"
If PhotoQuality < 50 Then PhotoQuality = 90
If PhotoQuality > 100 Then PhotoQuality = 90
If Thumb_BackgroundColor = "" Then Thumb_BackgroundColor = "#CCCCCC"
Watermark_Images_Transparence = Watermark_Images_Transparence / 100
Watermark_Text_FontColor = "&H" & Replace(Right(Watermark_Text_FontColor, 6), "#", "")
Watermark_Images_BackgroundColor = "&H" & Replace(Right(Watermark_Images_BackgroundColor, 6), "#", "")
Thumb_BackgroundColor = "&H" & Replace(Right(Thumb_BackgroundColor, 6), "#", "")

Class Cls_Thumb
 '=================================================
 'AddWatermark
 '作  用：根據選擇的外部組件調用影像處理功能給圖片加上浮水印
 '參  數：ImgFileName     ---- 圖片路徑
 '=================================================
 Public Function AddWatermark(ImgFileName)

  Dim objFont, FileExt
  Dim iLeft, iTop
  Dim LogoWidth, LogoHeight

  AddWatermark = False

  If PhotoObject <= 0 Then Exit Function

  FileExt = GetPhotoExt(ImgFileName)
  If FileExt <> "jpg" And FileExt <> "jpeg" And FileExt <> "jpe" And FileExt <> "bmp" And FileExt <> "gif" Then Exit Function
  
  'On Error Resume Next
  
  Select Case PhotoObject
  Case 1       'AspJpegV1.5

 

   If ClsMain.IsObjInstalled("Persits.Jpeg") = False Then Exit Function

 
   Dim AspJpeg
   Set AspJpeg = Server.CreateObject("Persits.Jpeg")
   AspJpeg.Open Trim(Server.MapPath(ImgFileName))
   If AspJpeg.OriginalWidth > Watermark_Position_X * 2 Then
    If Watermark_Type = 0 Then
     If Watermark_Text <> "" And Watermark_Text_FontColor <> "" Then
      LogoWidth = (Watermark_Text_FontSize + 1) * ClsMain.GetStrLen(Watermark_Text) / 2
      LogoHeight = Watermark_Text_FontSize + 1

      iLeft = GetPosition_X(AspJpeg.OriginalWidth, LogoWidth, Watermark_Position_X)
      iTop = GetPosition_Y(AspJpeg.OriginalHeight, LogoHeight, Watermark_Position_Y)

      AspJpeg.Canvas.Font.COLOR = Watermark_Text_FontColor         ' 文字的顏色
      AspJpeg.Canvas.Font.Family = Watermark_Text_FontName         ' 文字的字型
      AspJpeg.Canvas.Font.size = Watermark_Text_FontSize           ' 文字的大小
      AspJpeg.Canvas.Font.Bold = Watermark_Text_Bold               ' 文字是否粗體
      AspJpeg.Canvas.Font.Quality = 4                              ' Antialiased
      AspJpeg.Canvas.PrintText iLeft, iTop, Watermark_Text         ' 加入文字的位置座標
      AspJpeg.Canvas.Pen.COLOR = &H0               ' 邊框的顏色
      AspJpeg.Canvas.Pen.Width = 1                 ' 邊框的粗細
      AspJpeg.Canvas.Brush.Solid = False           ' 圖片邊框內是否填充顏色
      AspJpeg.Quality = PhotoQuality
      AspJpeg.save Server.MapPath(ImgFileName)     ' 組建檔案

     End If
    Else

        Set fso = Server.CreateObject("Scripting.FileSystemObject")

     If Not fso.FileExists(Server.MapPath(".."&Watermark_Images_FileName)) Then
      Exit Function
     End If

     Dim AspJpeg2
     Set AspJpeg2 = Server.CreateObject("Persits.Jpeg")
     AspJpeg2.Open Server.MapPath(".."&Watermark_Images_FileName)  '開啟浮水印圖片

     iLeft = GetPosition_X(AspJpeg.OriginalWidth, AspJpeg2.Width, Watermark_Position_X)
     iTop  = GetPosition_Y(AspJpeg.OriginalHeight, AspJpeg2.Height, Watermark_Position_Y)
     AspJpeg.DrawImage iLeft, iTop, AspJpeg2, Watermark_Images_Transparence, Watermark_Images_BackgroundColor, 90 '在原圖上添加浮水印圖片
     AspJpeg.Quality = PhotoQuality
     AspJpeg.save Server.MapPath(ImgFileName)
     Set AspJpeg2 = Nothing
    End If
   End If
   Set AspJpeg = Nothing
  Case 2

  Case 3

  End Select

  AddWatermark = True
  'If Err Then
  ' Err.Clear
  ' CreateThumb = False
  'End if
 End Function

 '=================================================
 '過程名：CreateThumb
 '作  用：根據選擇的外部組件調用影像處理功能（縮圖，浮水印）
 '參  數：ImgFileName     ----原始圖片路徑
 '        ThumbFileName  ----建立縮圖儲存的路徑
 '        ImageWidth  ----縮圖寬度
 '        ImageHeight ----縮圖高度
 '=================================================
 Public Function CreateThumb(ImgFileName, ThumbFileName, ImageWidth, ImageHeight)
  Dim FileExt, bl_w, bl_h
  Dim iLeft, iTop

  CreateThumb = False

  If PhotoObject <= 0 Then Exit Function
  If ImageWidth = 0 And ImageHeight = 0 Then
   ImageWidth = Thumb_DefaultWidth
   ImageHeight = Thumb_DefaultHeight
  End If

  FileExt = GetPhotoExt(ImgFileName)

  If FileExt <> "jpg" And FileExt <> "jpeg" And FileExt <> "jpe" And FileExt <> "bmp" And FileExt <> "gif" Then Exit Function
  
  'On Error Resume Next
  
  Select Case PhotoObject
  Case 1       'AspJpegV1.5

   If ClsMain.IsObjInstalled("Persits.Jpeg") = False Then Exit Function
   
   Dim AspJpeg, AspJpeg2

   Set AspJpeg = Server.CreateObject("Persits.Jpeg")
   Set AspJpeg2 = Server.CreateObject("Persits.Jpeg")
   AspJpeg.Open Trim(Server.MapPath(ImgFileName))
   AspJpeg2.Open Trim(Server.MapPath(ImgFileName))
   
   bl_w = ImageWidth / AspJpeg.OriginalWidth
   bl_h = ImageHeight / AspJpeg.OriginalHeight
   
   If ImageWidth > 0 Then
    If ImageHeight > 0 Then
     Select Case Thumb_Arithmetic
     Case 0   '常規演算法：寬度和高度都大於0時，直接縮小成指定大小，其中一個為0時，按比例縮小
      If bl_w < 1 Or bl_h < 1 Then
       AspJpeg.Width = ImageWidth
       AspJpeg.Height = ImageHeight
       AspJpeg.Quality = PhotoQuality
       AspJpeg.save Server.MapPath(ThumbFileName)
       CreateThumb = True
      End If
     Case 1    '裁剪法：寬度和高度都大於0時，先按最佳比例縮小再裁剪成指定大小，其中一個為0時，按比例縮小
      If bl_w < 1 Or bl_h < 1 Then
       If bl_w < bl_h Then
        AspJpeg.Height = ImageHeight
        AspJpeg.Width = Round(AspJpeg.OriginalWidth * bl_h)   '按縮小成大比例者
       Else
        AspJpeg.Width = ImageWidth
        AspJpeg.Height = Round(AspJpeg.OriginalHeight * bl_w)
       End If
       AspJpeg.Crop 0, 0, ImageWidth, ImageHeight
       AspJpeg.Quality = PhotoQuality
       AspJpeg.save Server.MapPath(ThumbFileName)
       CreateThumb = True
      End If
     Case 2  '補充法：在指定大小的背景圖上附加上按最佳比例縮小的圖片
      
      '建立一個指定大小的背景圖
      AspJpeg2.Width = ImageWidth
      AspJpeg2.Height = ImageHeight
      AspJpeg2.Canvas.Brush.Solid = True            ' 圖片邊框內是否填充顏色
      AspJpeg2.Canvas.Brush.COLOR = Thumb_BackgroundColor  '設定背景顏色
      AspJpeg2.Canvas.Bar -1, -1, AspJpeg2.Width + 1, AspJpeg2.Height + 1 '填充

      '按最佳比例縮小圖片
      If bl_w > bl_h Then
       If bl_h < 1 Then
        AspJpeg.Height = ImageHeight
        AspJpeg.Width = Round(AspJpeg.OriginalWidth * bl_h)   '按縮小成小比例者
       End If
      Else
       If bl_w < 1 Then
        AspJpeg.Width = ImageWidth
        AspJpeg.Height = Round(AspJpeg.OriginalHeight * bl_w)
       End If
      End If

      '得到縮圖的座標
      iLeft = (AspJpeg2.Width - AspJpeg.Width) / 2
      iTop = (AspJpeg2.Height - AspJpeg.Height) / 2

      AspJpeg2.DrawImage iLeft, iTop, AspJpeg   '將縮圖附加到背景上
      AspJpeg2.Quality = PhotoQuality
      AspJpeg2.save Server.MapPath(ThumbFileName)
      CreateThumb = True
     End Select

    Else
     If bl_w < 1 Then
      AspJpeg.Width = ImageWidth
      AspJpeg.Height = Round(AspJpeg.OriginalHeight * bl_w)
      AspJpeg.Quality = PhotoQuality
      AspJpeg.save Server.MapPath(ThumbFileName)
      CreateThumb = True
     End If
    End If

   Else
    If ImageHeight > 0 And bl_h < 1 Then
     AspJpeg.Height = ImageHeight
     AspJpeg.Width = Round(AspJpeg.OriginalWidth * bl_h)
     AspJpeg.Quality = PhotoQuality
     AspJpeg.save Server.MapPath(ThumbFileName)
     CreateThumb = True
    Else
     '寬度和高度都為0時，不做任何處理
    End If
   End If
   Set AspJpeg = Nothing
   Set AspJpeg2 = Nothing

  Case "2"

  Case "3"

  End Select

  If Err Then
   Err.Clear
   CreateThumb = False
  End if
 End Function

 Private Function GetPosition_X(xImage_W, xLogo_W, SpaceVal)
  Select Case Watermark_Position
  Case 0 '左上
   GetPosition_X = SpaceVal
  Case 1 '左下
   GetPosition_X = SpaceVal
  Case 2 '置中
   GetPosition_X = (xImage_W - xLogo_W) / 2
  Case 3 '右上
   GetPosition_X = xImage_W - xLogo_W - SpaceVal
  Case 4 '右下
   GetPosition_X = xImage_W - xLogo_W - SpaceVal
  Case Else '不顯示
   GetPosition_X = 0
 End Select

 End Function

 Private Function GetPosition_Y(yImage_H, yLogo_H, SpaceVal)
  Select Case Watermark_Position
  Case 0 '左上
   GetPosition_Y = SpaceVal
  Case 1 '左下
   GetPosition_Y = yImage_H - yLogo_H - SpaceVal
  Case 2 '置中
   GetPosition_Y = (yImage_H - yLogo_H) / 2
  Case 3 '右上
   GetPosition_Y = SpaceVal
  Case 4 '右下
   GetPosition_Y = yImage_H - yLogo_H - SpaceVal
  Case Else '不顯示
   GetPosition_Y = 0
  End Select

 End Function

 '取得檔案的尾碼名
 Private Function GetPhotoExt(FullPath)
  Dim strFileExt

  If FullPath <> "" Then
   strFileExt = ClsMain.ReplaceBadChar(Trim(LCase(Mid(FullPath, InStrRev(FullPath, ".") + 1))))

   If Len(strFileExt) > 10 Then
    GetPhotoExt = Left(strFileExt, 3)
   Else
    GetPhotoExt = strFileExt
   End If

  Else
   GetPhotoExt = ""
  End If

 End Function

End Class
%>