XProfan

'code to investigation the Maße of Bilddateien, without these To loading.
'yet go following Formate automatically recognized and the Maße read:
'.bmp, .jpg, .gif, .png, .ico
'The expenses for the .ico-stature go yet extended.
'Also should The Color Depth for Images yet read go
'further follow.
'the code beruht on of/ one Presentation of
'Thomas Hölzer, Andreas Miethe, Hans-Jürgen Trog from the year 2000
'$H StringsPfade.ph
'~StrFormat
'~HexFormatX

Proc MakeWord'with optionalem Parameter. If the staid is, go The Bytes vertauscht, the power it plainer Bytes a area (GetByte) umzuwandeln.

    If %pcount = 3

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

    Else

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

    EndIf

ENDPROC

Class BitmapInfo = name$(256),x&,y&,amount%,type$(3),BitmapInfo@
Class IconInfo = x%,y%,col&,bpp&,IconInfo@'bpp% = Bits by 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"

        .type$ = "ico"
        .amount% = Word(Header#,4)

        If .amount% > 0

            Declare Icon#[.amount%]

            WhileLoop 0, .amount% - 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) = "ÿØÿ"'the are as Hexwerte: FFD8FF + E0 or E1

        Select Char$(Header#,3,1)'viertes characters search

            CaseOf "\xE0","\xE1"' "Ã","Ã	","â","ã","ä","Ã¥","æ","ç","è","é","ê","ë","ì","í","î","ï" yet are me only the two first Opportunities untergekommen

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

            WhileLoop 0, 15

                'Search to FFC0 - behind it stand The Maße
                'here can evtl further values stand. possibly are well FF + C0 To CF.
                'therefore the investigation in a Loop
                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"

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

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

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

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

        .type$ = "emf"

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

        .type$ = "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)

        .type$ = "wmf"

    EndIf

    Ifnot .type$ = "ico"

        .amount% = .x& And .y&

    EndIf

ENDPROC

Proc Test

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

    If FileExists(Image$)

        Image# = New(BitmapInfo,Image$)

        With Image#

            Print "Bildname   = ",.name$
            Print "Bildtyp    = ",.type$
            Print "BildBreite = ",.x&
            Print "BildHöhe   = ",.y&
            Print "Bildanzahl = ",.amount%

        EndWith

        Dispose Image#

    Else

        Print "Fehler",Image$

    EndIf

    WaitInput

ENDPROC

Test()

CHR_CODE.asm(74) : Error A2121: symbol hardship defined : __CF0