office交流网--QQ交流群号及微信交流群
更多

Access培训群：792054000         Excel免费交流群群：686050929          Outlook交流群：221378704    

Word交流群：218156588             PPT交流群：324131555

微信交流群（请用微信扫码)

        

vb或VBA进行StdPicture、IStream、Byte() 互转

2020-04-30 08:00:00
TZWSOHO
转贴
4142
模块代码：
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

分享
Access查询技巧
更多
文章分类
联系我们
联系人： 王先生
Email： 18449932@qq.com
QQ： 18449932
微博： officecn01