Option Explicit

Dim Nr As Integer
Dim D As String, P As String, T As String

Private Sub Dir1_Change()
  File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
  On Error Resume Next
  Dir1.Path = Drive1.Drive
  Drive1.Drive = Dir1.Path
End Sub

Private Sub File1_Click()
  Dim Wdth As Long, Hght As Long

  Label1.Caption = ""
  D$ = File1.FileName
  P$ = File1.Path
  If Right$(P$, 1) <> "\" Then P$ = P$ & "\"
  If Not IsBitmap(P$ & D$) Then Exit Sub

  T$ = BitmapType(P$ & D$)
  If InStr(T$, "keine") = 0 Then
    BMPSize P$ & D$, Wdth&, Hght&
    T$ = T$ & vbCrLf & "Bildgrösse:" & Str(Wdth&) & " x" & _
         Str(Hght&) & " Pixel" & vbCrLf & "Dateigrösse: " & _
         Format$(FileLen(P$ & D$), "###,###") & " Bytes"
  End If
  Label1.Caption = T$
End Sub

Function BitmapType(D As String) As String
  Dim Dmmy As String * 28
  Dim Bits As Integer

  Nr = FreeFile
  Open D$ For Binary As #Nr
    Get #Nr, , Dmmy
    Get #Nr, , Bits
  Close #Nr

  Select Case Bits
    Case 1
      T$ = "Monochrome "
    Case 4
      T$ = "16-Farben-"
    Case 8
      T$ = "256-Farben-"
    Case 16
      T$ = "High Color-"
    Case 24
      T$ = "True Color-"
    Case Else
      T$ = "keine "
  End Select
  BitmapType = T$ & "Bitmap"
End Function

Sub BMPSize(D As String, Wdth As Long, Hght As Long)
  Dim Dmmy As String * 18

  Nr = FreeFile
  Open D$ For Binary As #Nr
    Get #Nr, , Dmmy
    Get #Nr, , Wdth
    Get #Nr, , Hght
  Close #Nr
End Sub

Function IsBitmap(D As String)
  Dim Kenn As String

  Nr = FreeFile
  Kenn$ = Space(2)
  Open D$ For Binary As #Nr
    Get #Nr, , Kenn$
  Close #Nr
  IsBitmap = (Kenn$ = "BM")
End Function