VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRGBInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'       RGB info version 1.01
'  Written by Mike D Sutton of EDais
'     Microsoft Visual Basic MVP
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 25/07/2002
' Last edited: 29/07/2003

'Version history:
'----------------
' Version 1.01 (29/07/2003):
'   Minor non-impact code changes
'
' Version 1.0 (25/07/2002):
'   Added Width, Height, BitDepth, MapType, RLECompressed, MinPix,
'   MaxPix, ImageName, BCP, FileName and FileSize properties
'
'   ReadFile()   - Reads a RLE file from disk and attempts to extract information from it
'   TrimNull()   - Trims a null-terminated string to a standard Vb string
'   FlipWord()   - Converts a big-endian Word to a litten-endian Word and visa-versa
'   FlipDWord()  - Converts a big-endian DWord to a litten-endian DWord and visa-versa
'   ValInRange() - Simple helper function to ascertain wether a value is with a given range
'-----------------

Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Type typRGBHeader       ' 512 bytes
    rgbMagic As Integer         ' IRIS image file magic number
    rgbStorage As Byte          ' Storage format
    rgbBPC As Byte              ' Number of bytes per pixel channel
    rgbDimension As Integer     ' Number of dimensions
    rgbXSize As Integer         ' X size in pixels
    rgbYSize As Integer         ' Y size in pixels
    rgbZSize As Integer         ' Number of channels
    rgbPixMin As Long           ' Minimum pixel value
    rgbPixMax As Long           ' Maximum pixel value
    rgbDummyA As Long           ' Ignored
    rgbImageName As String * 80 ' Image name
    rgbColourMap As Long        ' Colormap ID
    rgbDummyB As String * 404   ' Ignored
End Type

Public Enum enMapType
    mtNormal = &H0
    mtDithered = &H1
    mtScreen = &H2
    mtColourMap = &H3
End Enum

Dim m_Width As Long
Dim m_Height As Long
Dim m_Depth As Long
Dim m_MapType As enMapType
Dim m_RLECompressed As Boolean
Dim m_MinPix As Long
Dim m_MaxPix As Long
Dim m_ImageName As String
Dim m_BPC As Byte
Dim m_FileName As String
Dim m_FileSize As Long

Private Const MagicNumber As Integer = 474

Public Property Get Width() As Long
    Width = m_Width
End Property

Public Property Get Height() As Long
    Height = m_Height
End Property

Public Property Get BitDepth() As Long
    BitDepth = m_Depth
End Property

Public Property Get MapType() As enMapType
    MapType = m_MapType
End Property

Public Property Get RLECompressed() As Boolean
    RLECompressed = m_RLECompressed
End Property

Public Property Get MinPix() As Long
    MinPix = m_MinPix
End Property

Public Property Get MaxPix() As Long
    MaxPix = m_MaxPix
End Property

Public Property Get ImageName() As String
    ImageName = m_ImageName
End Property

Public Property Get BPC() As String
    BPC = m_BPC
End Property

Public Property Get FileName() As String
    FileName = m_FileName
End Property

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

Public Function ReadFile(ByRef inFile As String) As Boolean
    Dim FileSize As Long
    Dim TempHeader As typRGBHeader
    Dim FNum As Integer
    Dim ValidHeader As Boolean
    
    On Error Resume Next
    FileSize = FileLen(inFile)
    On Error GoTo 0
    
    ' RGB value have a fixed 512-byte header
    If (FileSize < 512) Then Exit Function
    
    FNum = FreeFile()
    Open inFile For Binary Access Read Lock Write As #FNum
        Get #FNum, , TempHeader
        
        With TempHeader
            .rgbDimension = FlipWord(.rgbDimension)
            .rgbColourMap = FlipDWord(.rgbColourMap)
            
            ' Validate header
            ValidHeader = (FlipWord(.rgbMagic) = MagicNumber) And _
                ValInRange(CLng(.rgbStorage), 0, 1) And _
                ValInRange(CLng(.rgbBPC), 1, 2) And _
                ValInRange(CLng(.rgbDimension), 1, 3) And _
                ValInRange(.rgbColourMap, 0, 3)
        End With
        
        If (Not ValidHeader) Then
            Close #FNum
            Exit Function
        End If
        
        With TempHeader ' Store image information
            m_Width = FlipWord(.rgbXSize)
            m_Height = FlipWord(.rgbYSize)
            m_Depth = FlipWord(.rgbZSize) * 8
            m_MinPix = FlipDWord(.rgbPixMin)
            m_MaxPix = FlipDWord(.rgbPixMax)
            m_MapType = .rgbColourMap
            m_RLECompressed = (.rgbStorage = 1)
            m_ImageName = TrimNull(.rgbImageName)
            m_BPC = .rgbBPC
            m_FileName = inFile
            m_FileSize = FileSize
        End With
    Close #FNum
    
    ReadFile = True
End Function

Private Function TrimNull(ByRef inString As String) As String
    Dim NullPos As Long
    
    NullPos = InStr(1, inString, vbNullChar)
    If (NullPos) Then TrimNull = Left$(inString, NullPos - 1) Else TrimNull = inString
End Function

Public Function FlipWord(ByVal inWord As Integer) As Integer
    Dim SrcPtr As Long, DstPtr As Long
    
    SrcPtr = VarPtr(inWord)
    DstPtr = VarPtr(FlipWord)
    
    Call RtlMoveMemory(ByVal DstPtr, ByVal (SrcPtr + 1), &H1)
    Call RtlMoveMemory(ByVal (DstPtr + 1), ByVal SrcPtr, &H1)
End Function

Public Function FlipDWord(ByVal inDWord As Long) As Long
    Dim SrcPtr As Long, DstPtr As Long
    
    SrcPtr = VarPtr(inDWord)
    DstPtr = VarPtr(FlipDWord)
    
    Call RtlMoveMemory(ByVal DstPtr, ByVal (SrcPtr + 3), &H1)
    Call RtlMoveMemory(ByVal (DstPtr + 1), ByVal (SrcPtr + 2), &H1)
    Call RtlMoveMemory(ByVal (DstPtr + 2), ByVal (SrcPtr + 1), &H1)
    Call RtlMoveMemory(ByVal (DstPtr + 3), ByVal SrcPtr, &H1)
End Function

Private Function ValInRange(ByVal inVal As Long, ByVal inLow As Long, ByVal inHigh As Long) As Boolean
    ValInRange = ((inVal >= inLow) And (inVal <= inHigh))
End Function