Attribute VB_Name = "加載并縮小顯示圖片"
'在網(wǎng)上找到這個(gè)源代碼，貼出來(lái)，
'不過(guò)多次縮放不同尺寸圖片時(shí)會(huì)貼圖錯(cuò)誤，稍后再研究下，呵呵

'----------------------------------------------------------------------
'----------------------------------------------------------------------
'----------------使用者請(qǐng)保留作者版權(quán)----------------------------------
'--  作者:BEAR-BEN  ---------------------------------------------------
'--  QQ:453628001  ----------------------------------------------------
'--  天才動(dòng)力 --- 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, "加載錯(cuò)誤"
        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 "出現(xiàn)錯(cuò)誤！", vbCritical, "錯(cuò)誤"
        GdiplusShutdown gdip_Token
        End
    End If

    '載入圖片到內(nèi)存中
    GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image

    '使用GDI+直接從內(nèi)存中縮略并繪圖，GDI+有很好的反鋸齒能力
    If GdipDrawImageRect(gdip_Graphics, gdip_Image, 0, 0, WidthMax, HeightMax) <> Ok Then Debug.Print "顯示失敗。。。"

    DisposeGDIP
End Sub


'下面是另一個(gè)程序中復(fù)制過(guò)來(lái)的保存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
  
      '從句柄創(chuàng)建 GDI + 圖像
      lRes = GdipCreateBitmapFromHBITMAP(pict.handle, 0, lBitmap)
      If lRes = 0 Then
      
        
        '初始化解碼器的GUID標(biāo)識(shí)
        CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), _
                        tJpgEncoder
      
        '設(shè)置解碼器參數(shù)
        tParams.count = 1
        With tParams.Parameter 'Quality
            '得到Quality參數(shù)的GUID標(biāo)識(shí)
            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, , "不能保存這個(gè)圖像：" & lRes
  End If
  
End Sub

'加載顯示完整圖片
Public Sub ShowFullImg(PBox As PictureBox, ImagePath As String)

LoadGDIP

If GdipCreateFromHDC(PBox.hDC, gdip_Graphics) <> Ok Then
    MsgBox "出現(xiàn)錯(cuò)誤！", vbCritical, "錯(cuò)誤"
    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