XProfan

'Code zur Ermittlung der Maße von Bilddateien, ohne diese zu laden.
'bisher werden folgende Formate automatisch erkannt und die Maße ausgelesen:
'.bmp, .jpg, .gif, .png, .ico
'Die Ausgaben für das .ico-Format werden noch erweitert.
'Außerdem soll die Farbtiefe für Bilder noch ausgelesen werden
'weitere folgen.
'der Code beruht auf einer Vorlage von
'Thomas Hölzer, Andreas Miethe, Hans-Jürgen Trog aus dem Jahr 2000
'$H StringsPfade.ph
'~StrFormat
'~HexFormatX

Proc MakeWord'mit optionalem Parameter. Wenn der gesetzt ist, werden die Bytes vertauscht, das macht es einfacher Bytes aus einem Bereich (GetByte) umzuwandeln.

    If %pcount = 3

        Parameters lbyte%, hbyte%'modus%
        Return (hbyte% & $FF) | ((lbyte% & $FF) << 8)

    Else

        Parameters lbyte%, hbyte%
        Return (lbyte% & $FF) | ((hbyte% & $FF) << 8)

    EndIf

EndProc

Class BitmapInfo = Name$(256),x&,y&,Anzahl%,Typ$(3),BitmapInfo@
Class IconInfo = x%,y%,col&,bpp&,IconInfo@'bpp% = Bits per Pixel

Proc IconInfo.IconInfo

    Parameters x%,y%,col&,bpp&
    .x% = x%
    .y% = y%
    .col& = col&
    .bpp& = bpp&

EndProc

Proc BitmapInfo.BitmapInfo

    Parameters File$
    Declare b#,Header#
    Dim Header#,45
    Declare Pos%
    .Name$ = File$
    BlockRead(File$,Header#,0,45)

    If Right$(Upper$(File$),4) = ".ICO"

        .Typ$ = "ico"
        .Anzahl% = Word(Header#,4)

        If .Anzahl% > 0

            Declare Icon#[.Anzahl%]

            WhileLoop 0, .Anzahl% - 1',16

                Seek i%,6 + &Loop * 16
                Icon#[&Loop] = New(IconInfo,GetByte(i%),GetByte(i%),GetByte(i%),GetWord(i%))

            Wend

        EndIf

    ElseIf Char$(Header#,0,3) = "ÿØÿ"'das sind als Hexwerte: FFD8FF + E0 oder E1

        Select Char$(Header#,3,1)'viertes Zeichen suchen

            CaseOf "\xE0","\xE1"' "Ã","Ã	","â","ã","ä","Ã¥","æ","ç","è","é","ê","ë","ì","í","î","ï" bisher sind mir nur die beiden ersten Möglichkeiten untergekommen

            .Typ$ = "jpg"
            Dim b#,10000
            Clear b#
            BlockRead(File$,b#,0,10000)

            WhileLoop 0, 15

                'Suche nach FFC0 - dahinter stehen die Maße
                'auch hier können evtl weitere Werte stehen. Möglich sind wohl FF + C0 bis CF.
                'darum die Ermittlung in einer Schleife
                Pos% = MemPos(b#,0,Chr$($FF) + Chr$($C0 + &Loop) + Chr$($00) + Chr$($11))
                Case Pos% > -1: Break

            Wend

            Inc Pos%,5
            .y& = MakeWord(Byte(b#,Pos%),Byte(b#,Pos% + 1),1)
            .x& = MakeWord(Byte(b#,Pos% + 2),Byte(b#,Pos% + 3),1)
            DisPose b#

        EndSelect

    ElseIf Char$(Header#,0,2) = "BM"

        .Typ$ = "bmp"
        .x& = Long(Header#,18)
        .y& = Long(Header#,22)

    ElseIf Char$(Header#,0,3) = "GIF"

        .Typ$ = "gif"
        .x& = Word(Header#,6)
        .y& = Word(Header#,8)

    ElseIf String$(Header#,3) = "EMF"

        .Typ$ = "emf"

    ElseIf Char$(Header#,0,4) = Chr$($89) + "PNG"

        .Typ$ = "png"
        .x& = MakeWord(Byte(Header#,18),Byte(Header#,19),1)
        .y& = MakeWord(Byte(Header#,22),Byte(Header#,23),1)

    ElseIf Char$(Header#,0,4) = Chr$($D7) + Chr$($CD) + chr$($C6) + Chr$($9A)

        .Typ$ = "wmf"

    EndIf

    IfNot .Typ$ = "ico"

        .Anzahl% = .x& And .y&

    EndIf

EndProc

Proc Test

    Parameters Bild$
    Declare Bild#
    Case Bild$ = "":Bild$ = "Africa_satellite_plane.jpg"

    If FileExists(Bild$)

        Bild# = New(BitmapInfo,Bild$)

        With Bild#

            Print "Bildname   = ",.Name$
            Print "Bildtyp    = ",.Typ$
            Print "BildBreite = ",.x&
            Print "BildHöhe   = ",.y&
            Print "Bildanzahl = ",.Anzahl%

        EndWith

        Dispose Bild#

    Else

        Print "Fehler",Bild$

    EndIf

    WaitInput

EndProc

Test()

CHR_CODE.asm(74) : Error A2121: Symbol not defined : __CF0