程序代码：
Option Explicit
'*********************************************************************************
'StdPicture、IStream、Byte() 互转
'作者：TZWSOHO
'
'参考了魏滔序的《VB6 结合 GDI+ 实现内存（Stream）压缩/解压缩 JPG 图像》
'http://blog.
'非常感谢魏滔序的代码！！！
'
'欢迎访问我的博客：http://blog.
'*********************************************************************************
' 第一步：(重要、重要、重要)首先在项目中引入'IStream.tlb'
Private Const GMEM_MOVEABLE As Long = &H2
Private Const ImageEncoderSuffix As String = "-1A04-11D3-9A73-0000F81EF32E}"
'常量声明
Private Const ClsidJPEG As String = "{557CF401" & ImageEncoderSuffix
Private Const ClsidBMP As String = "{557CF400" & ImageEncoderSuffix
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
SuppressBackgroundThread As 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
'将位图指针转换为流再转为字节数组
Public Function BitmapToByteArray(ByVal bitmap As Long, _
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
lBitmap = bitmap
lngGdipToken = StartUpGDIPlus(GdiPlusVersion)
'检查JPG压缩比率
If JpegQuality > 100 Then JpegQuality = 100
If JpegQuality < 0 Then JpegQuality = 0
Dim rc As RECTL
GdipGetImageWidth bmp, rc.Right
GdipGetImageHeight bmp, rc.Bottom
'创建Bitmap
hGlobal = GlobalAlloc(GMEM_MOVEABLE, rc.Bottom * rc.Right / 256) '创建缓冲区
'创建Stream
If CreateStreamOnHGlobal(ByVal hGlobal, False, picStream) = 0 Then
'转换GUID,每种图片的tGUID不同。
'If CLSIDFromString(StrPtr(ClsidJPEG), tGUID) = 0 Then
If CLSIDFromString(StrPtr(ClsidBMP), 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
If GdipSaveImageToStream(lBitmap, picStream, tGUID, ByVal 0) = 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 '释放分配的缓冲区空间
BitmapToByteArray = Buff
End If
End If
Set picStream = Nothing
End If
GdipDisposeImage lBitmap
GdiplusShutdown lngGdipToken
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
