pic.bas

把图片缩小压缩成jpg格式并保存到sql数据库

Attribute VB_Name = "加载并缩小显示图片"
'在网上找到这个源代码，贴出来，
'不过多次缩放不同尺寸图片时会贴图错误，稍后再研究下，呵呵

'----------------------------------------------------------------------
'----------------------------------------------------------------------
'----------------使用者请保留作者版权----------------------------------
'--  作者:BEAR-BEN  ---------------------------------------------------
'--  QQ:453628001  ----------------------------------------------------
'--  天才动力 --- GENIUS POWER  ---------------------------------------
'--  WebSite:www.tcdongli.com  ----------------------------------------
'----------------------------------------------------------------------
'----------------------------------------------------------------------
Option Explicit
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long


Public Type ImageInfo
  Height As Long
  Width As Long
  FilePath As String
  ImageName As String
  type As String
  FileSize As Long  'KB
End Type

Private Type GdiplusStartupInput
  GdiplusVersion As Long
  DebugEventCallback As Long
  SuppressBackgroundThread As Long
  SuppressExternalCodecs As Long
End Type
Private Enum GpStatus  'Status
  Ok = 0
  GenericError = 1
  InvalidParameter = 2
  OutOfMemory = 3
  ObjectBusy = 4
  InsufficientBuffer = 5
  NotImplemented = 6
  Win32Error = 7
  WrongState = 8
  Aborted = 9
  FileNotFound = 10
  ValueOverflow = 11
  AccessDenied = 12
  UnknownImageFormat = 13
  FontFamilyNotFound = 14
  FontStyleNotFound = 15
  NotTrueTypeFont = 16
  UnsupportedGdiplusVersion = 17
  GdiplusNotInitialized = 18
  PropertyNotFound = 19
  PropertyNotSupported = 20
End Enum

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As GpStatus
Private Declare Function GdipDrawImage Lib "GDIPlus" (ByVal graphics As Long, ByVal Image As Long, ByVal X As Single, ByVal Y As Single) As GpStatus
Private Declare Function GdipDrawImageRect Lib "GDIPlus" (ByVal graphics As Long, ByVal Image As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
Private Declare Function GdipCreateFromHDC Lib "GDIPlus" (ByVal hDC As Long, graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "GDIPlus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "GDIPlus" (ByVal FileName As String, Image As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As GpStatus
Private Declare Function GdipGetImageWidth Lib "GDIPlus" (ByVal Image As Long, Width As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "GDIPlus" (ByVal Image As Long, Height As Long) As GpStatus

Private Declare Function GdipDrawImageRectI Lib "GDIPlus" (ByVal graphics As Long, ByVal Image As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As GpStatus

Dim gdip_Token As Long
Dim gdip_Image As Long
Dim gdip_Graphics As Long
Public wid As Long
Public hgt As Long
Public wid2 As Long
Public hgt2 As Long


Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type EncoderParameter
  GUID As GUID
  NumberOfValues As Long
  type As Long
  Value As Long
End Type

Private Type EncoderParameters
  count As Long
  Parameter As EncoderParameter
End Type


Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" ( _
  ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long


Private Declare Function GdipSaveImageToFile Lib "GDIPlus" ( _
  ByVal Image As Long, ByVal FileName As Long, _
  clsidEncoder As GUID, encoderParams As Any) As Long

Private Declare Function CLSIDFromString Lib "ole32" ( _
  ByVal Str As Long, id As GUID) As Long


Private Sub LoadGDIP()
    Dim GpInput As GdiplusStartupInput
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(gdip_Token, GpInput) <> 0 Then
        MsgBox "加载GDI+失败！", vbCritical, "加载错误"
        End
    End If
End Sub

Private Sub DisposeGDIP()
    GdipDisposeImage gdip_Image
    GdipDeleteGraphics gdip_Graphics
    GdiplusShutdown gdip_Token
End Sub
Public Sub ShowTNImg(PBox As Object, ImagePath As String, WidthMax As Long, HeightMax As Long)
    LoadGDIP
    If GdipCreateFromHDC(PBox.hDC, gdip_Graphics) <> 0 Then
        MsgBox "出现错误！", vbCritical, "错误"
        GdiplusShutdown gdip_Token
        End
    End If

    '载入图片到内存中
    GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image

    '使用GDI+直接从内存中缩略并绘图，GDI+有很好的反锯齿能力
    If GdipDrawImageRect(gdip_Graphics, gdip_Image, 0, 0, WidthMax, HeightMax) <> Ok Then Debug.Print "显示失败。。。"

    DisposeGDIP
End Sub


'下面是另一个程序中复制过来的保存JPEG格式的SUB
Public Sub SaveJPG(ByVal pict As StdPicture, ByVal FileName As String, _
          Optional ByVal Quality As Byte = 80)
  Dim tSI As GdiplusStartupInput
  Dim lRes As Long
  Dim lGDIP As Long
  Dim lBitmap As Long
  Dim tJpgEncoder As GUID
  Dim tParams As EncoderParameters
 ' Dim aEncParams() As Byte
  '初始化 GDI+
  tSI.GdiplusVersion = 1
  lRes = GdiplusStartup(lGDIP, tSI)
  
  If lRes = 0 Then
  
      '从句柄创建 GDI + 图像
      lRes = GdipCreateBitmapFromHBITMAP(pict.handle, 0, lBitmap)
      If lRes = 0 Then
      
        
        '初始化解码器的GUID标识
        CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
                        tJpgEncoder
      
        '设置解码器参数
        tParams.count = 1
        With tParams.Parameter 'Quality
            '得到Quality参数的GUID标识
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
            .NumberOfValues = 1
            .type = 4
            .Value = VarPtr(Quality)
        End With
      '  ReDim aEncParams(1 To Len(tParams))
       ' Call CopyMemory(aEncParams(1), tParams, Len(tParams))

        
        '保存图像
        
        'lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1)) '保存图像
        lRes = GdipSaveImageToFile( _
                  lBitmap, _
                  StrPtr(FileName), _
                  tJpgEncoder, _
                  tParams)
                            
        '销毁GDI 图像
        GdipDisposeImage lBitmap
        
      End If
      
      '销毁 GDI+
      GdiplusShutdown lGDIP

  End If
  
  If lRes Then
      Err.Raise 5, , "不能保存这个图像：" & lRes
  End If
  
End Sub

'加载显示完整图片
Public Sub ShowFullImg(PBox As PictureBox, ImagePath As String)

LoadGDIP

If GdipCreateFromHDC(PBox.hDC, gdip_Graphics) <> Ok Then
    MsgBox "出现错误！", vbCritical, "错误"
    GdiplusShutdown gdip_Token
    End
End If

GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image

If GdipDrawImage(gdip_Graphics, gdip_Image, 0, 0) <> Ok Then
  Debug.Print "显示失败。。。"
  MsgBox "显示失败。。。"
End If
DisposeGDIP

End Sub