从Byte数组里读出图像

前两天上网发现一篇文章，觉得很有用，发给大家。

'模块

Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

 

'打图像开文件到Byte数组

Public Function LoadFile(ByVal FileName As String) As Byte()
    Dim FileNo As Integer, b() As Byte
    On Error GoTo Err_Init
    If Dir(FileName, vbNormal Or vbArchive) = "" Then
        Exit Function
    End If
    FileNo = FreeFile
    Open FileName For Binary Access Read As #FileNo
    ReDim b(0 To LOF(FileNo) - 1)
    Get #FileNo, , b
    Close #FileNo
    LoadFile = b
    Exit Function
Err_Init:
    MsgBox Err.Number & " - " & Err.Description
End Function

 

'Byte数组转换为图像

Public Function PictureFromByteStream(b() As Byte) As IPicture
    Dim LowerBound As Long
    Dim ByteCount  As Long
    Dim hMem  As Long
    Dim lpMem  As Long
    Dim IID_IPicture(15)
    Dim istm As stdole.IUnknown

    On Error GoTo Err_Init
    If UBound(b, 1) < 0 Then
        Exit Function
    End If
   
    LowerBound = LBound(b)
    ByteCount = (UBound(b) - LowerBound) + 1
    hMem = GlobalAlloc(&H2, ByteCount)
    If hMem <> 0 Then
        lpMem = GlobalLock(hMem)
        If lpMem <> 0 Then
            MoveMemory ByVal lpMem, b(LowerBound), ByteCount
            Call GlobalUnlock(hMem)
            If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
                If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
                  Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
                End If
            End If
        End If
    End If

    Exit Function

Err_Init:
    If Err.Number = 9 Then
        'Uninitialized array
        MsgBox "You must pass a non-empty byte array to this function!"
    Else
        MsgBox Err.Number & " - " & Err.Description
    End If
End Function

 

'Form窗口

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type

 

Private Sub Form_Load()
    Dim b() As Byte, pic As StdPicture, DrawDirectlyOnForm As Boolean

    AutoRedraw = True
    DrawDirectlyOnForm = False
    '打开图像文件到数组
    b = LoadFile(App.Path & "/full color.jpg")
    '转换数组为图像并赋值给Pic
    Set pic = PictureFromByteStream(b)
    If pic Is Nothing Then

             Exit Sub
    End If
     If DrawDirectlyOnForm = True Then

             Set Me.Picture = pic
    Else

             DoItTheHardWay pic
    End If

    Set pic = Nothing
   
End Sub

Private Sub DoItTheHardWay(ByRef pic As StdPicture)
    Dim TempDC As Long, hBmp As Long, w As Long, h As Long, bmpInfo As BITMAP

    GetObject pic.Handle, Len(bmpInfo), bmpInfo
    w = bmpInfo.bmWidth
    h = bmpInfo.bmHeight
    
    '创建一个新的设备场景
    TempDC = CreateCompatibleDC(0)
   
    '使用该设备场景
    hBmp = SelectObject(TempDC, pic.Handle)
   
    '绘制图像
    BitBlt Me.hdc, 0, 0, w, h, TempDC, 0, 0, vbSrcCopy
   
    '删除设备场景
    hBmp = SelectObject(TempDC, hBmp)
    DeleteDC TempDC

End Sub