Attribute VB_Name = "modImage"
' API
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Sub CopyMemory Lib "KERNEL32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (lpPictDesc As PictDesc, RIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPictureDisp) As Long
Public Declare Function CreateDIBitmap Lib "gdi32.dll" (ByVal hdc As Long, lpbmih As BITMAPINFOHEADER, ByVal fdwInit As Long, lpbInit As Any, lpbmi As BITMAPINFO, ByVal fuUsage As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Declare Sub RtlMoveMemory Lib "KERNEL32.dll" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Public Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Public Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Public Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Public Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(255) As RGBQUAD
End Type

Public Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type

Public Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Public Const CBM_INIT = &H4     '  initialize bitmap
Public Const DIB_RGB_COLORS = 0 '  color table in RGBs



'-----------------------------------------------------------------------------
' @(f)
'
' 関数名    : GetPicture
'
' 機能      : Pictureオブジェクトを返す
'
' 引き数    : ARG1 - bmp : DIB構造体のバイト配列
'
'
' 戻り値    : Pictureオブジェクトを返す
'
' 機能説明  :
'
' 備考      :　エラーの時にはNothingをかえす
'-----------------------------------------------------------------------------
Public Function GetPicture(ByRef bmp() As Byte, ByRef hBitmap As Long) As IPicture
    On Error GoTo ErrHandler

    Dim hdc As Long
'    Dim hBitmap As Long
    Dim bmpFileHd As BITMAPFILEHEADER
    Dim bmpInfo As BITMAPINFO
    
    CopyMemory bmpFileHd.bfType, bmp(0), 2    ' ｱﾗｲﾒﾝﾄ4の境界をまたぐため
    CopyMemory bmpFileHd.bfSize, bmp(2), 12   ' ｱﾗｲﾒﾝﾄ4の境界をまたぐため
    
    CopyMemory bmpInfo, bmp(14), Len(bmpInfo)        ' BitmapInfo
    hdc = GetDC(0)
    hBitmap = CreateDIBitmap(hdc, bmpInfo.bmiHeader, CBM_INIT, bmp(bmpFileHd.bfOffBits), bmpInfo, DIB_RGB_COLORS)
    Call ReleaseDC(0, hdc)
    
    Set GetPicture = BmpToPicture(hBitmap)
    
EndProc:
'    Call DeleteObject(hBitmap)
    Exit Function

ErrHandler:
    Set GetPicture = Nothing
    GoTo EndProc
    
End Function

' Pictureオブジェクトをbitmapハンドルから生成
Private Function BmpToPicture(ByVal hBmp As Long) As IPicture
    On Error GoTo ErrorProc
    
    If hBmp = 0 Then Exit Function
    
    Dim oNewPic As Picture
    Dim tPicConv As PictDesc
    Dim IGuid As Guid
    
    With tPicConv
        .picType = vbPicTypeBitmap
        .hImage = hBmp
    End With
    
    ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
    With IGuid
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
    
    Set BmpToPicture = oNewPic
    Exit Function
ErrorProc:
    Set BmpToPicture = Nothing
    
End Function

Public Function GetSize(ByRef bmp() As Byte, ByRef lWidth As Long, ByRef lHeight As Long) As Boolean
    On Error GoTo ErroProc
    
    Dim lSize As Long
    
    ' サイズチェック
    lSize = UBound(bmp)
    If (lSize < 26) Then GoTo ErroProc
    
    RtlMoveMemory lWidth, bmp(18), 4
    RtlMoveMemory lHeight, bmp(22), 4
    GetSize = True
    Exit Function
    
ErroProc:
    GetSize = False
End Function