|
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
|
|