XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Datei: Breite und Höhe aus Datei lesen für Grafiken: GIF, PCX, WMF, EMF, BMP, JPG, PNG, TGA, ICO
Dieser Quelltext ist eine Gemeinschaftsarbeit von:
Thomas Hölzer, Andreas Miethe, Hans-Jürgen Trog
Breite und Höhe aus Datei lesen für Grafiken folgender Formate:
GIF, PCX, WMF, EMF, BMP, JPG, PNG, TGA, ICO
Declare size#

Proc GetGIFDimension

    Parameters file$
    Dim size#,4
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,6
    BlockRead(#1,size#,0,4)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite:,Word(size#,0),Höhe:,Word(size#,2)
    Print
    Dispose size#

EndProc

Proc GetBMPDimension

    Parameters file$
    Dim size#,8
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,18
    BlockRead(#1,size#,0,8)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite:,Word(size#,0),Höhe:,Word(size#,4)
    Print
    Dispose size#

EndProc

Proc GetPCXDimension

    Parameters file$
    Dim size#,4
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,8
    BlockRead(#1,size#,0,4)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite:,Add(Word(size#,0),1),Höhe:,Add(Word(size#,2),1)
    Print
    Dispose size#

EndProc

Proc GetTGADimension

    Parameters file$
    Dim size#,4
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,12
    BlockRead(#1,size#,0,4)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
    Print
    Dispose size#

EndProc

Proc GetWMFDimension

    Parameters file$
    Dim size#,4
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,10
    BlockRead(#1,size#,0,4)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
    Print
    Dispose size#

EndProc

Proc GetPNGDimension

    Parameters file$
    Dim size#,4
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,18
    BlockRead(#1,size#,1,1)
    Seek #1,19
    BlockRead(#1,size#,0,1)
    Seek #1,22
    BlockRead(#1,size#,3,1)
    Seek #1,23
    BlockRead(#1,size#,2,1)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
    Print
    Dispose size#

EndProc

Proc GetIconDimensions

    Declare Icons&,x%
    Parameters file$
    Dim Size#,16
    FileMode 0
    Let x% = 0
    Assign #1,file$
    OpenRW #1
    Seek #1,4
    wieviele Icons sind im File ?
    BlockRead(#1,Size#,0,2)
    Print file$;:,
    Print Icons gesamt,@Word(Size#,0)
    Print
    Let Icons& = @Word(Size#,0)

    whilenot equ(x%,Icons&)

        zum Einstiegspunkt der einzelnen Icons
        Seek #1,add(6,(mul(x%,16)))
        BlockRead(#1,Size#,0,16)
        Print Icon:,Str$(add(x%,1)), - ,
        Print Breite,@Byte(size#,0),Pixel, - ,
        Print Höhe,@Byte(size#,1),Pixel, - ,
        Print Farben,@Byte(size#,2)  0 wenn >= 8-BitPerPixel
        Print BitPerPixel,@Word(size#,6),  - ,
        Print
        Inc x%

    EndWhile

    CloseRW #1
    FileMode 2
    Dispose Size#

EndProc

Proc GetEMFDimension

    Parameters file$
    Dim size#,8
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,16
    BlockRead(#1,size#,0,8)
    CloseRW #1
    FileMode 2
    Print file$;:
    Print Breite,@Word(size#,0),Höhe,@Word(size#,4)
    Print
    Dispose size#

EndProc

*********************************************
ab hier Groesse von JPG-Files ermitteln
###############################
Declare breite%,höhe%,size1#

Proc GetJPGDimensions

    Parameters File$

    Proc GetJPGDimension

        Groessenangaben auslesen
        ########################
        Declare Back$
        Parameters file$,Match%
        Dim size1#,4
        FileMode 0
        Assign #1,file$
        OpenRW #1
        Seek #1,Match%
        BlockRead(#1,size1#,1,1)
        Seek #1,Match%+1
        BlockRead(#1,size1#,0,1)
        Seek #1,Match%+2
        BlockRead(#1,size1#,3,1)
        Seek #1,Match%+3
        BlockRead(#1,size1#,2,1)
        CloseRW #1
        FileMode 2
        Let Back$ = add$(str$(@Word(size1#,2))
        ,ADD$(,,str$(@Word(size1#,0))))
        dispose size1#
        Return back$

    EndProc

    Proc GetJPGMatch

        Segmentmarker fuer Start of Frame-Marker suchen
        5 Bytes danach kann man die Grossenangaben auslesen.
        Start of Frama-Marker ist immer $FFC0 oder $FFC2.
        ###################################################
        Def MakeWord(2) Or(%(1),Mul(%(2),$100))
        Declare x%,fs%,y%,back$
        Parameters file$,x%
        FileMode 0
        Assign #1,file$
        OpenRW #1
        fs% = @GetFileSize(#1)
        Dim size#,fs%
        BlockRead(#1,size#,0,fs%)
        CloseRW #1

        Whilenot equ(x%,fs%)

            if or(equ(MakeWord(Byte(size#,x%+1),

                Byte(size#,x%)),65472),
                equ(MakeWord(Byte(size#,x%+1),
                Byte(size#,x%)),65474))
                Let y%=x%+5 5 bytes dazu
                GetJPGDimension File$,y%  Groessenangaben lesen
                Let back$=@$(0)
                Let x%=fs%-1

            endif

            inc x%

        EndWhile

        Dispose size#
        breite%=val(Substr$(@$(0),1,,))
        höhe%=val(Substr$(@$(0),2,,))
        Print file$;:
        Print Breite:,breite%,Höhe:,höhe%
        Print
        Return back$

    EndProc

    Proc GetJPGDIM

        Segment-Laenge des 1. Segmentes suchen
        und ueberspringen.
        #######################################
        Def MakeWord(2) Or(%(1),Mul(%(2),$100))
        Declare aaa%,back$
        Parameters file$
        FileMode 0
        Assign #1,file$
        OpenRW #1
        Dim size#,65535  Maximale Segmentgroesse
        BlockRead(#1,size#,0,65535)
        CloseRW #1
        Segmentlaenge 2 Byte + 4 = Segmentende
        Let aaa% = add(Makeword(Byte(size#,5),Byte(size#,4)),4)
        dispose size#
        GetJPGMatch file$,aaa% Position ab Segmentende suchen
        Let back$=@$(0)
        Return back$

    endproc

    GetJPGDIM File$

EndProc

Ende des JPG-Abschnittes
********************************************
Bei den Beispielen bitte die Pfade entsprechend anpassen:
Window 0,0-600,600
Cls
Decimals 0
GetGIFDimension C:TESTA.GIF
GetBMPDimension C:TESTA.BMP
GetPCXDimension C:TESTA.PCX
GetTGADimension C:TESTA.TGA
GetWMFDimension C:TESTA.WMF
GetEMFDimension C:TESTA.EMF
GetJPGDim C:TESTA.JPG
GetPNGDimension C:TESTA.PNG
GetIconDimensions C:WINDOWSWINUPD.ICO
WaitInput