VB's screwy way is called Twips.
Microsoft decided to use twips because, um, well, because... Nobody knows but Jesus.
Anyway, I whipped up some code which sorta kinda lets you view the header of a BMP.
The error checking is minimal, but any more and it would have to be a BMP editor.
Try!
Then you could use something like...Code:Option Explicit Enum eColors clrInvalid = 0 ' Unknown clrBlackWhite = 1 ' 1-bit, 2^1 = 2 colors (black and white) clr16Colors = 4 ' 4-bit, 2^4 = 16 colors clr256Colors = 8 ' 8-bit, 2^8 = 256 colors clr16BitColor = 16 ' 16-bit, 65536 colors clr24BitColor = 24 ' 24-bit, 16777216 colors clr32BitColor = 32 ' 32-bit, many colors :rolleyes: End Enum Private Const MINIMUM_BMP_SIZE = 66 ' Believe it or not, 66 bytes Private Const BMPID_WINDOWS = "BM" Private Const BMPID_OS2BMP = "BA" Private Const BMPID_OS2COLORICON = "CI" Private Const BMPID_OS2COLORPOINTER = "CP" Private Const BMPID_OS2ICON = "IC" Private Const BMPID_OS2POINTER = "PT" Private Const BMPHEADER_ID_POSITION = 1 ' The ID variable is at byte 1 of the file Private Const BMPHEADER_WIDTH_POSITION = 19 ' The Width variable is at byte 19 of the file Private Const BMPHEADER_HEIGHT_POSITION = 23 ' The Height variable is at byte 23 of the file Private Const BMPHEADER_COLORS_POSITION = 29 ' The Colors variable is at byte 29 of the file Function GetBitmapData(ByVal sFileName As String, lWidth As Long, lHeight As Long, BmpColors As eColors) As Boolean Dim btFileNum As Byte, sID As String, iColors As Integer On Error Resume Next btFileNum = FreeFile Open sFileName For Binary Access Read As btFileNum ' Could open file? Exit Sub If Not Err.Number = 0 Then Exit Function ' Minimal error checking: ' 1) Must be a valid file size If LOF(btFileNum) < MINIMUM_BMP_SIZE Then Exit Function ' 2) Must be a valid 2-byte ID sID = vbNullChar & vbNullChar ' Allocate 2 bytes Get btFileNum, BMPHEADER_ID_POSITION, sID ' Retrieve 2 bytes from file ' Check if the 2 bytes are valid If Not ((sID = BMPID_WINDOWS) Or (sID = BMPID_OS2BMP) Or (sID = BMPID_OS2COLORICON) Or _ (sID = BMPID_OS2COLORPOINTER) Or (sID = BMPID_OS2ICON) Or (sID = BMPID_OS2POINTER)) _ Then Exit Function ' Get Width and Height variables Get btFileNum, BMPHEADER_WIDTH_POSITION, lWidth Get btFileNum, BMPHEADER_HEIGHT_POSITION, lHeight ' Get Colors variable Get btFileNum, BMPHEADER_COLORS_POSITION, iColors ' Check if the color is valid, looks ugly but works! BmpColors = IIf((iColors = clrBlackWhite) Or (iColors = clr16Colors) Or _ (iColors = clr256Colors) Or (iColors = clr16BitColor) Or (iColors = clr24BitColor) _ Or (iColors = clr32BitColor), iColors, clrInvalid) Close btFileNum GetBitmapData = True ' Success End Function
Code:Private Sub Form_Load() Dim lWidth As Long, lHeight As Long, BmpColors As eColors, bResult As Boolean Const sFileName = "C:\Windows\Clouds.bmp" bResult = GetBitmapData(sFileName, lWidth, lHeight, BmpColors) If bResult Then Call MsgBox(sFileName & vbCrLf & "Width: " & lWidth & " pixels." & vbCrLf & _ "Height: " & lHeight & " pixels." & vbCrLf & "Colors: " & BmpColors & " bits.", _ vbInformation) Else Call MsgBox(sFileName & vbCrLf & "Could not get file information." & vbCrLf & _ "Either there was a problem opening the file, or its format is invalid.", _ vbCritical) End If End Sub






Reply With Quote