Attribute VB_Name = "PicBMP" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = True ' PicInfo bitmap file information class ' ©2006 Aivosto Oy (www.aivosto.com) ' ' This file is part of a sample project for Project Analyzer. ' Distribution of this file is only allowed along with Project Analyzer ' according to the Project Analyzer license terms. Option Explicit Implements IPicInfo Private Enum EBMPType bmpUnknown bmpInfoHeader bmpCoreHeader End Enum Private BMPType As EBMPType Private Type BITMAPFILEHEADER bfType As Integer ' Specifies the file type, must be BM. bfSize As Long ' Specifies the size, in bytes, of the bitmap file. bfReserved1 As Integer ' Reserved; must be zero. bfReserved2 As Integer ' Reserved; must be zero. bfOffBits As Long ' Specifies the offset, in bytes, from the beginning of the BITMAPFILEHEADER structure to the bitmap bits. End Type Private 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 Private Type BITMAPCOREHEADER bcSize As Long bcWidth As Integer bcHeight As Integer bcPlanes As Integer bcBitCount As Integer End Type Private InfoHeader As BITMAPINFOHEADER Private CoreHeader As BITMAPCOREHEADER Private Const BI_RGB = 0& Private Const BI_RLE4 = 2& Private Const BI_RLE8 = 1& Private Const BI_bitfields = 3& ' IsRLE indicates whether the bitmap is RLE compressed (True) or not (False) ' This variable is written but not read ' It might well be removed without affecting the functionality of the program Private IsRLE As Boolean ' Filename used in the previous call to ReadFile Private StoredFilename As String Private Function ReadBitmapFile(ByVal Filename As String) As Boolean ' Read picture information from a bitmap file of type BMP/DIB/RLE ' [Filename] Name of picture file ' Return value: ' True - Picture information retrieved ' False - Not a valid bitmap file Dim BMPFileHeader As BITMAPFILEHEADER ' Main BM file header Dim FileNr As Integer ' Number of open file Dim HeaderSize As Long ' Size of header data in bytes IsRLE = False ' Clear the IsRLE flag. We will set it below to True if required. BMPType = bmpUnknown ' Set file type to bmpUnknown until we can verify the real type ' Open the file for binary read access FileNr = FreeFile Open Filename For Binary Access Read Lock Write As #FileNr If LOF(FileNr) > Len(BMPFileHeader) Then ' File length is "enough", read main BM file header header Get #FileNr, 1, BMPFileHeader If BMPFileHeader.bfType = &H4D42 Then ' BM If BMPFileHeader.bfReserved1 = 0 And BMPFileHeader.bfReserved2 = 0 Then ' Signature OK ' Retrieve size of following header Get #FileNr, , HeaderSize Seek #FileNr, Seek(FileNr) - 4 ' Rewind to start of header Select Case HeaderSize Case Len(CoreHeader) Get #FileNr, , CoreHeader BMPType = bmpCoreHeader ReadBitmapFile = True ' File valid Case Len(InfoHeader) Get #FileNr, , InfoHeader BMPType = bmpInfoHeader ' Determine bitmap compression Select Case InfoHeader.biCompression Case BI_RLE8, BI_RLE4 ' The bitmap is RLE compressed IsRLE = True End Select ReadBitmapFile = True ' File valid Case Else ReadBitmapFile = False ' Invalid/unsupported file type End Select End If End If End If Close FileNr End Function Private Property Get IPicInfo_Filename() As String ' Returns the filename used in the previous call to ReadFile IPicInfo_Filename = StoredFilename End Property Private Property Get IPicInfo_MaxColors() As Variant Select Case BMPType Case bmpCoreHeader IPicInfo_MaxColors = 2 ^ CoreHeader.bcBitCount Case bmpInfoHeader IPicInfo_MaxColors = 2 ^ InfoHeader.biBitCount End Select End Property Private Function IPicInfo_ReadFile(ByVal Filename As String) As Boolean ' Read a picture file to retrieve picture information ' [Filename] File to read ' Return value: ' True - Picture information retrieved ' False - Error, information not retrieved IPicInfo_ReadFile = ReadBitmapFile(Filename) End Function Private Property Get IPicInfo_Size() As TPicSize ' Returns picture width and height in pixels Select Case BMPType Case bmpCoreHeader IPicInfo_Size.Width = CoreHeader.bcWidth IPicInfo_Size.Height = CoreHeader.bcHeight Case bmpInfoHeader IPicInfo_Size.Width = InfoHeader.biWidth IPicInfo_Size.Height = InfoHeader.biHeight End Select End Property
Hide code	Visustin flow chart for VB