vb或VBA進行StdPicture、IStream、Byte() 互轉 - Excel VBA開髮

模塊代碼：
Option Explicit

'*********************************************************************************
'StdPicture、IStream、Byte() 互轉
'作者：TZWSOHO
'
'蔘考瞭魏滔序的《VB6 結閤 GDI+ 實現內存（Stream）壓縮/解壓縮 JPG 圖像》
'非常感謝魏滔序的代碼！！！

'*********************************************************************************

Private Const GMEM_MOVEABLE As Long = &H2

'常量聲明
Private Const ClsidJPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const EncoderParameterValueTypeLong As Long = 4&
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const GdiPlusVersion As Long = 1&

'結構聲明
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

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

Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hgdiObj As Long
hPalOrXYExt As Long
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(15) As EncoderParameter
End Type

Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThreadAs Long
SuppressExternalCodecs As Long
End Type

Private Type GdiplusStartupOutput
NotificationHook As Long
NotificationUnhook As Long
End Type

'枚舉聲明
Private Enum 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
ProfileNotFound = 21
End Enum

'API聲明
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As Status
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, ByRef hbmReturn As Long, ByVal Background As Long) As Status
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Status
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As IStream, ByRef image As Long) As Status
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Status
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, ByRef lpOutput As GdiplusStartupOutput) As Status
Private Declare Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As Long, ByVal Stream As IStream, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Status
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, ByRef id As GUID) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PICTDESC, ByRef riid As IID, ByVal fOwn As Boolean, ByRef lplpvObj As Object)

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
'Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
'Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal pstm As IStream, ByRef phglobal As Long) As Long

'By Modest
'根據版本初始化GDI+
Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Long
Dim GdipToken As Long
Dim GdipStartupInput As GDIPlusStartupInput
Dim GdipStartupOutput As GdiplusStartupOutput
GdipStartupInput.GdiPlusVersion = GdipVersion
If GdiplusStartup(GdipToken, GdipStartupInput, GdipStartupOutput) = OK Then
StartUpGDIPlus = GdipToken
End If
End Function

'By Modest
'從圖像轉換爲流
Public Function PictureToStream(ByVal Picture As StdPicture, Optional ByVal JpegQuality As Long = 85) As IStream
Dim picStream As IStream
Dim lBitmap As Long
Dim tGUID As GUID
Dim bytBuff() As Byte
Dim tParams As EncoderParameters
Dim lngGdipToken As Long

lngGdipToken = StartUpGDIPlus(GdiPlusVersion)

'檢查JPG壓縮比率
If JpegQuality > 100 Then JpegQuality = 100
If JpegQuality < 0 Then JpegQuality = 0

'創建Bitmap
If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then
'創建Stream
If CreateStreamOnHGlobal(ByVal 0&, False, picStream) = 0 Then
'轉換GUID
If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then
'設置JPG相關蔘數值
tParams.Count = 1
With tParams.Parameter(0)
CLSIDFromString StrPtr(EncoderQuality), .GUID
.NumberOfValues = 1
.Type = EncoderParameterValueTypeLong
.Value = VarPtr(JpegQuality)
End With
'將Bitmap數據保存到流(JPG格式)
If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then
Set PictureToStream = picStream
End If
End If
Set picStream = Nothing
End If
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function

'By Modest
'從流轉換爲圖像
Public Function StreamToPicture(ByVal Stream As IStream) As StdPicture
Dim picStream As IStream
Dim lBitmap As Long
Dim hBitmap As Long
Dim lngGdipToken As Long
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture

lngGdipToken = StartUpGDIPlus(GdiPlusVersion)

Set picStream = Stream
'從Stream加載Bitmap
If GdipLoadImageFromStream(picStream, lBitmap) = OK Then
'根據Bitmap創建hBitbmp
If GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0) = OK Then
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = vbPicTypeBitmap
.hgdiObj = hBitmap
.hPalOrXYExt = 0
End With

' 初始化IPicture
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With

Call OleCreatePictureIndirect(tPictDesc, IID_IPicture, True, oPicture)
Set StreamToPicture = oPicture
End If
End If

Set picStream = Nothing
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function

'By TZWSOHO
'從圖像轉換爲流再轉爲字節數組
Public Function PictureToByteArray(ByVal Picture As StdPicture, Optional ByVal JpegQuality As Long = 85) As Byte()
Dim picStream As IStream
Dim lBitmap As Long
Dim tGUID As GUID
Dim bytBuff() As Byte
Dim tParams As EncoderParameters
Dim lngGdipToken As Long

Dim hGlobal As Long, lpBuffer As Long, dwSize As Long, Buff() As Byte

lngGdipToken = StartUpGDIPlus(GdiPlusVersion)

'檢查JPG壓縮比率
If JpegQuality > 100 Then JpegQuality = 100
If JpegQuality < 0 Then JpegQuality = 0

'創建Bitmap
If GdipCreateBitmapFromHBITMAP(Picture.Handle, 0, lBitmap) = OK Then
hGlobal = GlobalAlloc(GMEM_MOVEABLE, Picture.Width * Picture.Height 256) '創建緩衝區
'創建Stream
If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then
'轉換GUID
If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then
'設置JPG相關蔘數值
tParams.Count = 1
With tParams.Parameter(0)
CLSIDFromString StrPtr(EncoderQuality), .GUID
.NumberOfValues = 1
.Type = EncoderParameterValueTypeLong
.Value = VarPtr(JpegQuality)
End With
'將Bitmap數據保存到流(JPG格式)
If GdipSaveImageToStream(lBitmap, picStream, tGUID, tParams) = OK Then
'GetHGlobalFromStream picStream, hGlobal

picStream.Seek 0, STREAM_SEEK_CUR, dwSize '穫取圖像大小
lpBuffer = GlobalLock(hGlobal) '穫取緩衝區讀寫指針
ReDim Buff(dwSize - 1): CopyMemory Buff(0), ByVal lpBuffer, dwSize '讀取圖像
GlobalUnlock hGlobal: GlobalFree hGlobal '釋放分配的緩衝區空間
PictureToByteArray = Buff
End If
End If
Set picStream = Nothing
End If
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function

'By TZWSOHO
'從字節數組轉換爲流再轉換爲圖像
Public Function ByteArrayToPicture(sBuf() As Byte) As StdPicture
Dim picStream As IStream
Dim lBitmap As Long
Dim hBitmap As Long
Dim lngGdipToken As Long
Dim tPictDesc As PICTDESC
Dim IID_IPicture As IID
Dim oPicture As IPicture
Dim hGlobal As Long, lpBuffer As Long

lngGdipToken = StartUpGDIPlus(GdiPlusVersion)

hGlobal = GlobalAlloc(GMEM_MOVEABLE, UBound(sBuf) + 1) '創建緩衝區
lpBuffer = GlobalLock(hGlobal) '穫取緩衝區讀寫指針
CopyMemory ByVal lpBuffer, sBuf(0), UBound(sBuf) + 1 '複製字節數組內容到緩衝區
'創建Stream
If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then
'從Stream加載Bitmap
If GdipLoadImageFromStream(picStream, lBitmap) = OK Then
'根據Bitmap創建hBitbmp
If GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0) = OK Then
With tPictDesc
.cbSizeOfStruct = Len(tPictDesc)
.picType = vbPicTypeBitmap
.hgdiObj = hBitmap
.hPalOrXYExt = 0
End With

' 初始化IPicture
With IID_IPicture
.Data1 = &H7BF80981
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With

Call OleCreatePictureIndirect(tPictDesc, IID_IPicture, True, oPicture)
Set ByteArrayToPicture = StreamToPicture(picStream)
End If
End If
GlobalUnlock hGlobal: GlobalFree hGlobal '釋放分配的緩衝區空間
Set picStream = Nothing
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
End Function

窗體代碼：
Option Explicit
'StdPicture、IStream、Byte() 互轉示例
Private Sub Command1_Click()

'By Modest
'Dim s As IStream
'Set s = PictureToStream(Picture1.Picture, 5)
'Set Picture2.Picture = StreamToPicture(s)

'By TZWSOHO
Dim Buf() As Byte
Buf = PictureToByteArray(Picture1.Picture, 5)
Set Picture2.Picture = ByteArrayToPicture(Buf)
End Sub

聯繫人：	王先生
Email：	18449932@qq.com
QQ：	18449932
微博：	officecn01