VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBMPInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'       BMP info version 1.02
'  Written by Mike D Sutton of EDais
'     Microsoft Visual Basic MVP
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 26/07/2002
' Last edited: 29/07/2003

'Version history:
'----------------

' Version 1.02 (29/07/2003):
'   Minor non-impact code modification

' Version 1.01 (04/05/2003):
'   Cleaned up coding style, added coments
'   Modified ReadFile() to properly validate image header
'   ReSplit DPI property into DPIx and DPIy and modified to be local device based

' Version 1.0 (25/07/2002):
'   Added FileName, FileSize, Width, Height, BitDepth, Compression, Planes and DPI properties
'
'   ReadFile()           - Reads an BMP file off disk and extracts information about it
'   GetPalEntry()        - Returns the RGB value of an entry from the colour palette
'   ClearInfo()          - Clears the public information within the class
'   GetCompressionName() - Converts the compression field of the BMIH to a string
'------------------------'

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Type BitmapFileHeader ' 14 bytes
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Type BitmapInfoHeader ' 40 bytes
    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

Private Type RGBQuad ' 32-bit RGB colour
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BitmapInfo
    bmiHeader As BitmapInfoHeader
    bmiColors() As RGBQuad
End Type

Dim BMInfo As BitmapInfo
Dim PalSize As Long

' Member variables (BMInfo above also used)
Dim m_FileName As String
Dim m_FileSize As Long

Const MagicCookie As Integer = &H4D42

Private Const BI_RGB As Long = 0
Private Const BI_RLE8 As Long = 1
Private Const BI_RLE4 As Long = 2
Private Const BI_BITFIELDS As Long = 3
Private Const BI_JPEG As Long = 4
Private Const BI_PNG As Long = 5

Private Const HORZSIZE As Long = 4    ' Horizontal size in millimeters
Private Const VERTSIZE As Long = 6    ' Vertical size in millimeters
Private Const HORZRES As Long = 8     ' Horizontal width in pixels
Private Const VERTRES As Long = 10    ' Vertical width in pixels
Private Const LOGPIXELSX As Long = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY As Long = 90 ' Logical pixels/inch in Y

' Public interface to member variables
Public Property Get FileName() As String
    FileName = m_FileName
End Property

Public Property Get FileSize() As Long
    FileSize = m_FileSize
End Property

Public Property Get Width() As Long
    Width = BMInfo.bmiHeader.biWidth
End Property

Public Property Get Height() As Long
    Height = BMInfo.bmiHeader.biHeight
End Property

Public Property Get BitDepth() As Byte
    BitDepth = BMInfo.bmiHeader.biBitCount
End Property

Public Property Get Compression() As String
    Compression = GetCompressionName(CInt(BMInfo.bmiHeader.biCompression))
End Property

Public Property Get Planes() As Long
    Planes = BMInfo.bmiHeader.biPlanes
End Property

Public Property Get DPIx() As Long
    Dim DeskWnd As Long, DeskDC As Long
    
    DeskWnd = GetDesktopWindow()
    DeskDC = GetDC(DeskWnd)
    DPIx = ((BMInfo.bmiHeader.biXPelsPerMeter / 1000) / ( _
        GetDeviceCaps(DeskDC, HORZRES) / _
        GetDeviceCaps(DeskDC, HORZSIZE))) * _
        GetDeviceCaps(DeskDC, LOGPIXELSX)
    Call ReleaseDC(DeskWnd, DeskDC)
End Property

Public Property Get DPIy() As Long
    Dim DeskWnd As Long, DeskDC As Long
    
    DeskWnd = GetDesktopWindow()
    DeskDC = GetDC(DeskWnd)
    DPIy = ((BMInfo.bmiHeader.biYPelsPerMeter / 1000) / ( _
        GetDeviceCaps(DeskDC, VERTRES) / _
        GetDeviceCaps(DeskDC, VERTSIZE))) * _
        GetDeviceCaps(DeskDC, LOGPIXELSY)
    Call ReleaseDC(DeskWnd, DeskDC)
End Property

' Public methods
Public Function ReadFile(ByRef inFile As String) As Boolean
    Dim FileSize As Long
    Dim FNum As Integer
    Dim BMFileHead As BitmapFileHeader
    Dim ReadPal As Long
    
    Call ClearInfo
    
    On Error Resume Next
    FileSize = FileLen(inFile)
    On Error GoTo 0
    
    If (FileSize < Len(BMInfo) + 4) Then Exit Function
    
    FNum = FreeFile()
    Open inFile For Binary Access Read Lock Write As #FNum
        Get #FNum, , BMFileHead
        
        If (BMFileHead.bfType <> MagicCookie) Then
            Close #inFile ' Header check failed
            Exit Function
        End If
        
        ' Read Bitmap header
        Get #FNum, , BMInfo.bmiHeader
        
        ' Validate image header size and properties
        If ((BMInfo.bmiHeader.biHeight < 0) Or (BMInfo.bmiHeader.biWidth < 0) Or _
            (BMInfo.bmiHeader.biPlanes <> 1) Or (BMInfo.bmiHeader.biSize <> 40)) Then
            Close #FNum ' Something failed, clear up and quit
            Call ClearInfo
            Exit Function
        End If
        
        Select Case BMInfo.bmiHeader.biBitCount
            Case 1, 4, 8 ' Valid paletted bit-depths
                PalSize = (2 ^ BMInfo.bmiHeader.biBitCount)
                ReDim BMInfo.bmiColors(PalSize - 1) As RGBQuad
                
                For ReadPal = 0 To PalSize - 1
                    Get #FNum, , BMInfo.bmiColors(ReadPal)
                Next ReadPal
            Case 15, 16, 24, 32 ' Valid RGB bit-depths
            Case Else ' Invalid Bitmap bit-depth
                Close #FNum
                Call ClearInfo
                Exit Function
        End Select
        
        ' Set properties
        m_FileName = inFile
        m_FileSize = FileSize
    Close #FNum
    
    ReadFile = True
End Function

Public Function GetPalEntry(ByVal inIndex As Byte) As Long
    If (inIndex < PalSize) Then GetPalEntry = RGB( _
        BMInfo.bmiColors(inIndex).rgbRed, _
        BMInfo.bmiColors(inIndex).rgbGreen, _
        BMInfo.bmiColors(inIndex).rgbBlue) _
    Else GetPalEntry = -1
End Function

' Private methods
Private Sub ClearInfo()
    With BMInfo.bmiHeader
        .biSize = 0
        .biWidth = 0
        .biHeight = 0
        .biPlanes = 0
        .biBitCount = 0
        .biCompression = BI_RGB
        .biSizeImage = 0
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        .biClrUsed = 0
        .biClrImportant = 0
    End With
    
    m_FileName = ""
    m_FileSize = 0
    PalSize = 0
End Sub

Private Function GetCompressionName(ByVal inMode As Integer) As String
    Select Case inMode
        Case BI_RGB:        GetCompressionName = "Raw RGB"
        Case BI_RLE8:       GetCompressionName = "8-Bit RLE"
        Case BI_RLE4:       GetCompressionName = "4-Bit RLE"
        Case BI_BITFIELDS:  GetCompressionName = "Bit fields"
        Case BI_JPEG:       GetCompressionName = "Lossy JPEG"
        Case BI_PNG:        GetCompressionName = "Lossless PNG"
        Case Else:          GetCompressionName = "Unknown"
    End Select
End Function