XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Grafikformate auslesen (Höhe und Breite)
Lauffähig ab Profan-Version 5.0
PRFellow-Vorlage (08/2000)
Autoren:
Dieser Quelltext ist eine Gemeinschaftsarbeit von:
Thomas Hölzer, Andreas Miethe, Hans-Jürgen Trog - Alle Rechte vorbehalten
Breite und Höhe aus Datei lesen für Grafiken folgender Formate:
GIF, PCX, WMF, EMF, BMP, JPG, PNG, TGA, ICO
Der Quelltext und das hier dargelegte Verfahren sind FREEWARE unter der
Bedingung, dass bei Verwendung die Autoren erwähnt werden!
aktualisiert am 15.09.00
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
    PRINT file$;:
    PRINT Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
    PRINT
    FileMode 2
    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
    PRINT file$;:
    PRINT Breite:,@Word(size#,0),Höhe:,@Word(size#,4)
    PRINT
    FileMode 2
    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
    PRINT file$;:
    PRINT Breite:,Add(@Word(size#,0),1),Höhe:,Add(@Word(size#,2),1)
    PRINT
    FileMode 2
    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
    PRINT file$;:
    PRINT Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
    PRINT
    FileMode 2
    DISPOSE size#

EndProc

PROC GetWMFDimension

    Parameters file$
    DIM size#,8
    FileMode 0
    Assign #1,file$
    OpenRW #1
    Seek #1,10
    BlockRead(#1,size#,0,4)
    CloseRW #1
    FileMode 2
    es kann vorkommen, dass die Größenangaben an anderer Stelle stehen!

    if @Or(@equ(@Word(size#,0),0),@equ(@Word(size#,2),0))

        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

    else

        PRINT file$;:
        PRINT Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
        PRINT

    endif

    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
    PRINT file$;:
    PRINT Breite:,@Word(size#,0),Höhe:,@Word(size#,2)
    PRINT
    FileMode 2
    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
        let x%=x%+1

    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
    PRINT file$;:
    PRINT Breite,@Word(size#,0),Höhe,@Word(size#,4)
    PRINT
    FileMode 2
    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
        LET Back$ = add$(str$(@Word(size1#,2))
        ,ADD$(,,str$(@Word(size1#,0))))
        DISPOSE size1#
        FileMode 2
        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
        let 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

            let x%=x%+1

        EndWhile

        DISPOSE size#
        let breite%=val(Substr$(@$(0),1,,))
        let höhe%=val(Substr$(@$(0),2,,))
        PRINT file$;:
        PRINT Breite:,breite%,Höhe:,höhe%
        PRINT
        FileMode 2
        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#
        FileMode 2
        GetJPGMatch file$,aaa% Position ab Segmentende suchen
        LET back$=@$(0)
        RETURN back$

    endproc

    GetJPGDIM File$

EndProc

Ende des JPG-Abschnittes
********************************************
declare file$, wählen%, ende%, weg%

PROC BILDLADEN

    let file$=@LoadFile$(Verzeichnis wählen, auf eine Datei klicken, auf Öffnen klicken,
    alle Bilder|*.BMP;*.JPG;*.PCX;*.TGA;*.GIF;*.WMF;*.EMF;*.ICO;*.PNG)

ENDPROC

Hauptprogramm
Def IsFileExt(2) Equ$(Right$(Upper$($(1)),3),$(2))
Decimals 0
Window 0,0-600,300
Cls
let wählen%=@createbutton(%hwnd,Bild wählen,350,190,170,24)
let weg%=@createbutton(%hwnd,Ende,350,220,170,24)
let ende% = 0

WHILENOT ende%

    waitinput

    IF @getfocus(weg%)

        let ende% = 1

    ELSEIF @getfocus(wählen%)

        cls
        BILDLADEN

        IF @neq$(file$,)

            If IsFileExt(file$,BMP)

                GetBMPDimension file$

            ELSEIf IsFileExt(file$,GIF)

                GetGIFDimension file$

            ELSEIf IsFileExt(file$,PCX)

                GetPCXDimension file$

            ELSEIf IsFileExt(file$,TGA)

                GetTGADimension file$

            ELSEIf IsFileExt(file$,WMF)

                GetWMFDimension file$

            ELSEIf IsFileExt(file$,EMF)

                GetEMFDimension file$

            ELSEIf IsFileExt(file$,JPG)

                GetJPGDim file$

            ELSEIf IsFileExt(file$,PNG)

                GetPNGDimension file$

            ELSEIf IsFileExt(file$,ICO)

                GetICODimension file$

            endif

        endif

    endif

wend

end