XProfan

Deutsch

GDL

Hallöle,

ich muß ca. 50 Vorschaubilder von 100X100 Pixel aus Bilddateien erzeugen.
Dabei haben die einzelnen Bilder immer > 4 Mb.

Habe jetzt rumgespielt. Dabei ist Dieter sein GDI-Plus Quelltext am schnellsten. Nur leider stimmt das Seitenverhältnis nicht.

Gibt es eine Möglichkeit Dieters Code so abzuändern dass das Seitenverhältnis stimmt? Ich bekomme es nicht hin.

Kompilieren Markieren Separieren

'Bilddateigröße war beim Test 4,19mb groß
declare h&,b&,c&,d&,za&,ze&,pfad$
cls
b&=create("picbutton",%hwnd,0,10,10,105,105)
c&=create("picbutton",%hwnd,0,300,10,105,105)
d&=create("picbutton",%hwnd,0,10,230,105,105)

proc testen

    '==============================================
    'Wie telefonisch besprochen (David)
    'XProfan1
    h&=create("hnewpic",100,100,0)
    za&=&GetTickCount
    startpaint h&
    drawsizedpic pfad$,0,0-100,100;0
    endpaint
    Sendmessage(b&,$00F7,0,h&)
    ze&=&GetTickCount
    drawtext 10,120,str$(ze&-za&)+" Millisekunden XProfan Version1"
    drawtext 10,150," Seitenverhältnis stimmt nicht"
    'Bild wird verzerrt
    '================================================================
    'Nach XProfan2
    za&=&GetTickCount
    h&=Create("hSizedPic",-1,pfad$,100,100,1)
    Sendmessage(c&,$00F7,0,h&)
    ze&=&GetTickCount
    drawtext 300,120,str$(ze&-za&)+" Millisekunden XProfan Version2"
    'Bild wird nicht verzerrt
    '==================================================================

endproc

'######################################
' von Dieter Zornow

Proc InitGDIPlus

    Declare gdpsi#,gdiplusToken&
    STRUCT GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    External("GDIPLUS.DLL","GdiplusStartup",ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    Return gdiplusToken&

EndProc

Proc ExitGDIPlus

    Parameters gdiplusToken&
    External("GDIPLUS.DLL","GdiplusShutdown",gdiplusToken&)

Endproc

Proc CatchImage

    Parameters MemPointer& ,Size&
    Struct GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Var GDIP& = ImportDll("Gdiplus.dll","")
    Var OLE& = ImportDll("Ole32.dll","")
    Var Kernel& = ImportDll("Kernel32.dll","")
    Declare gdpsi#,gdiplusToken&,ImageObject&,GraphicObject&,pStream&,RetVal&
    'GDIPlus starten
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    GdiplusStartup(ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    'Speicher bereitstellen
    Var m_hBuffer& = GlobalAlloc(2,Size&)
    Var pBuffer& = GlobalLock(m_hBuffer&)
    RtlMoveMemory(pBuffer&,MemPointer&,Size&)
    GlobalUnlock(m_hBuffer&)
    'Stream erzeugen
    CreateStreamOnHGlobal(m_hBuffer&,1,Addr(pStream&))
    GdipCreateBitmapFromStream(pStream&,Addr(ImageObject&))
    'hBitmap erzeugen
    GdipCreateHBITMAPFromBitmap(ImageObject&,Addr(RetVal&),0)
    'aufräumen
    Var Command& = Long(pStream&,0)
    call(Long(Command&,8),pStream&)'IStream.Release
    GlobalFree(m_hBuffer&)
    GdipDisposeImage(ImageObject&)
    GdipDeleteGraphics(GraphicObject&)
    GdiplusShutdown(gdiplusToken&)
    FreeDll GDIP&
    FreeDll OLE&
    FreeDll Kernel&
    Return RetVal&

EndProc

proc test1

    declare mem#,size&,bild$
    bild$=pfad$
    size& = filesize(bild$)
    dim mem#,size&
    set("Filemode",0)
    Blockread(bild$,mem#,0,size&)
    set("filemode",2)
    var hBild& = CatchImage(mem#,sizeof(mem#))
    Dispose mem#
    declare Image&,Thumb&,hBitmap&
    var hadl& = InitGDIPlus()
    External("GDIPLUS.DLL","GdipCreateBitmapFromHBITMAP",hbild&,0,addr(Image&))
    External("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,100,100,addr(Thumb&),0,0)'picture size
    External("GDIPLUS.DLL","GdipCreateHBITMAPFromBitmap",Thumb&,addr(hBitmap&),0)
    Sendmessage(d&,$00F7,0,hBitmap&)
    ExitGDIPlus(hadl&)
    'Bild wird verzerrt, ist aber nicht so verpixelt

endproc

'#####################################################
chdir "C:\\bueroumgebung\\verzeichnis031\\weihnachten\\"'Pfad zum Testen anpassen
pfad$=upper$(LoadFile$("Lade ein Bild","*.jpg"))
case right$(pfad$,4)=".JPG":testen
za&=&GetTickCount
case right$(pfad$,4)=".JPG":test1
ze&=&GetTickCount
drawtext 10,350,str$(ze&-za&)+" Millisekunden XProfan GDI-Plus"
drawtext 10,380," Seitenverhältnis stimmt nicht"
waitinput
deleteobject h&

Grüßle
Georg

vorschaubild.png	84 kB

Hochgeladen:	03.09.2015

Ladeanzahl:
		Herunterladen

Windows7 Xprofan 8,9,10 [...]

[...]

03.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

« Dieser Beitrag wurde als Lösung gekennzeichnet. »

- Seite 2 -

GDL

@Michael

Das "Testen" war bei den letzten Posts nicht mehr im Versuchsprog.
Sorry, war mein Fehler.

Ausschlaggebend war dies:

Außerdem werden die DLL's ständig wieder aus dem Speicher geworfen. Lass sie doch bis zum Ende drin. Da InitGDIPlus und ExitGDIPlus die DLL's noch brauchen (und sie damit wieder in den Speicher holen) habe ich das mal in InitGDI und ExitGDI ausgelagert.

Der nun gehende Versuchsaufbau:

Kompilieren Markieren Separieren

'Vorschaubild aus großen Bilddateien
'Bilddateigröße war beim Test 4,19mb groß
 {$CLQ}
Declare GDIP&,OLE&,Kernel&
DEF CreateStreamOnHGlobal(3)!"OLE32","CreateStreamOnHGlobal"

Proc InitGDI

    GDIP& = ImportDll("Gdiplus.dll","")
    OLE& = ImportDll("Ole32.dll","")
    Kernel& = ImportDll("Kernel32.dll","")

EndProc

Proc ExitGDI

    FreeDLL Kernel&
    FreeDLL OLE&
    FreeDLL GDIP&

EndProc

declare b&,c&,d&,za&,ze&,pfad$,i%,RetVal&
cls
d&=create("picbutton",%hwnd,0,10,230,105,105)
'######################################
' von Dieter Zornow

Proc InitGDIPlus

    Declare gdpsi#,gdiplusToken&
    STRUCT GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    External("GDIPLUS.DLL","GdiplusStartup",ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    Return gdiplusToken&

EndProc

Proc ExitGDIPlus

    Parameters gdiplusToken&
    External("GDIPLUS.DLL","GdiplusShutdown",gdiplusToken&)

Endproc

Proc CatchImage

    Parameters MemPointer& ,Size&
    Struct GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Declare gdpsi#,gdiplusToken&,ImageObject&,GraphicObject&,pStream&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    GdiplusStartup(ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    'Speicher bereitstellen
    Var m_hBuffer& = GlobalAlloc(2,Size&)
    Var pBuffer& = GlobalLock(m_hBuffer&)
    RtlMoveMemory(pBuffer&,MemPointer&,Size&)
    GlobalUnlock(m_hBuffer&)
    'Stream erzeugen
    CreateStreamOnHGlobal(m_hBuffer&,1,Addr(pStream&))
    GdipCreateBitmapFromStream(pStream&,Addr(ImageObject&))
    'hBitmap erzeugen
    GdipCreateHBITMAPFromBitmap(ImageObject&,Addr(RetVal&),0)
    'aufräumen
    Var Command& = Long(pStream&,0)
    call(Long(Command&,8),pStream&)'IStream.Release
    GlobalFree(m_hBuffer&)
    GdipDisposeImage(ImageObject&)
    GdipDeleteGraphics(GraphicObject&)
    GdiplusShutdown(gdiplusToken&)
    Return RetVal&

EndProc

proc test1

    declare mem#,size&,bild$,ImageWidth&,ImageHeight&,Dreisatz!,ThumbHeight%,ThumbWidth%
    bild$=pfad$
    size& = filesize(bild$)
    dim mem#,size&
    set("Filemode",0)
    Blockread(bild$,mem#,0,size&)
    set("filemode",2)
    var hBild& = CatchImage(mem#,sizeof(mem#))
    Dispose mem#
    declare Image&,Thumb&,hBitmap&
    var hadl& = InitGDIPlus()
    External("GDIPLUS.DLL","GdipCreateBitmapFromHBITMAP",hbild&,0,addr(Image&))
    External("GDIPLUS.DLL","GdipGetImageWidth",Image&,ADDR(ImageWidth&))'Breite ermitteln
    External("GDIPLUS.DLL","GdipGetImageHeight",Image&,ADDR(ImageHeight&))'Hoehe ermitteln

    if ImageWidth& = ImageHeight&' Quadratisch

        ThumbWidth% = 100
        ThumbHeight% = 100

    elseif ImageWidth& > ImageHeight&' Querformat

        Dreisatz! = ImageWidth&/100
        ThumbHeight% = ImageHeight&/Dreisatz!
        ThumbWidth% = 100

    elseif ImageWidth& < ImageHeight&' Hochformat

        Dreisatz! = ImageHeight&/100
        ThumbWidth% = ImageWidth&/Dreisatz!
        ThumbHeight% = 100

    endif

    External("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,ThumbWidth%,ThumbHeight%,addr(Thumb&),0,0)'Thumb size
    External("GDIPLUS.DLL","GdipCreateHBITMAPFromBitmap",Thumb&,addr(hBitmap&),0)
    Sendmessage(d&,$00F7,0,hBitmap&)
    ExitGDIPlus(hadl&)
    'Bild wird verzerrt, ist aber nicht so verpixelt

endproc

'#####################################################
chdir "C:\\bueroumgebung\\verzeichnis031\\weihnachten\\"'Pfad zum Testen anpassen
pfad$=upper$(LoadFile$("Lade ein Bild","*.jpg"))
InitGDI()
i%=1

whilenot i% > 1000

    za&=&GetTickCount
    case right$(pfad$,4)=".JPG" : test1
    deleteobject RetVal&'wichtig
    ze&=&GetTickCount
    inc i%
    drawtext 10,350,str$(ze&-za&)+" Millisekunden XProfan GDI-Plus"
    drawtext 10,380," Seitenverhältnis stimmt nicht"

wend

ExitGDI()
waitinput

Windows7 Xprofan 8,9,10 [...]

[...]

05.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

- Seite 1 -

ByteAttack

Bei

Kompilieren Markieren Separieren

Dreisatz!=ImageWidth&/100
ThumbHeight%=ImageHeight&/Dreisatz!

Vorher abfragen, ob die Werte nicht 0 sind...
Dann hat er vielleicht keine Datei geladen???

Kompilieren Markieren Separieren

Case ImageWidth&=0:Break
Case ImageHeigt&=0:Break
oder
CaseNot ImageWidth&=0:Dreisatz!=ImageWidth&/100
CaseNot ImageHeight&=0:ThumbHeight%=ImageHeight&/Dreisatz!

XProfan X3
Website: [...]

Facebook: [...]

04.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

ByteAttack

Nachtrag... Die Berechnung ist sowieso falsch....

Bei Grafiken die im "Hochformat" sind, funktioniert es natürlich nicht! Das ganze war nur als beispiel gedacht

XProfan X3
Website: [...]

Facebook: [...]

04.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

ByteAttack

Kompilieren Markieren Separieren

Case ImageWidth&=0:Break
Case ImageHeight&=0:Break

if ImageWidth&=ImageHeight&' Quadratisch

    ThumbWidth%=100
    ThumbHeight%=100

elseif ImageWidth&>ImageHeight&' Querformat

    Dreisatz!=ImageWidth&/100
    ThumbHeight%=ImageHeight&/Dreisatz!
    ThumbWidth%=100

elseif ImageWidth&<ImageHeight&' Hochformat

    Dreisatz!=ImageHeight&/100
    ThumbWidth%=ImageWidth&/Dreisatz!
    ThumbHeight%=100

endif

External("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,ThumbWidth%,ThumbHeight%,addr(Thumb&),0,0)'picture size

XProfan X3
Website: [...]

Facebook: [...]

04.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

GDL

Supi Ausrichtung funzt.
=========
Ich habe aber noch kein Ergebnis wegen langsamer werden.

Wenn ich Dieters Codeschnippsel solo nehme, habe ich folgendes Problem wie weiter oben gepostet nur ohne Absturz und ohne Fehlermeldung.

Bei Bilder über 4MB
Es wird ab den 40 Bild dann einfach keine Thumb mehr erstellt und die Erstellzeit wird immer länger.
Von 650ms bis ca. 1800 ms.
Bei 100 Bilder ist dann die Erstellzeit bei ca. 8sec. Aber ohne Thumb.

Bei Bilder unter 1MB kommt der Effekt dann später.

zum Bild:
Bis zum Bild 39 passen ImageHeight& und Imagewidth& und bei Bild 40 springen beide Werte auf 0.
Wenn ich diese 0 Abfange stürzt zwar das Prog. nicht mehr ab, aber es werden auch keine Thumbs mehr erstellt.

fehler.png	43 kB

Hochgeladen:	04.09.2015

Ladeanzahl:
		Herunterladen

Windows7 Xprofan 8,9,10 [...]

[...]

04.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

Jörg
Sellmeyer

Wie ist es denn, wenn du das Bildobjekt löschst, bevor du ein neues erstellst?

Kompilieren Markieren Separieren

proc test1

    declare mem#,size&,bild$
    bild$=pfad$
    size& = filesize(bild$)
    dim mem#,size&
    set("Filemode",0)
    Blockread(bild$,mem#,0,size&)
    set("filemode",2)
    'Hier altes Objekt löschen
    Case hBild& <> 0:DeleteObject hBild&
    var hBild& = CatchImage(mem#,sizeof(mem#))
    Dispose mem#
    declare Image&,Thumb&,hBitmap&
    var hadl& = InitGDIPlus()
    External("GDIPLUS.DLL","GdipCreateBitmapFromHBITMAP",hbild&,0,addr(Image&))
    External("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,100,100,addr(Thumb&),0,0)'picture size
    External("GDIPLUS.DLL","GdipCreateHBITMAPFromBitmap",Thumb&,addr(hBitmap&),0)
    Sendmessage(d&,$00F7,0,hBitmap&)
    'auch hier das Objekt löschen. Wenn es auf dem Static ist, müsste es eigentlich überflüssig sein
    DeleteObject hBitmap&
    ExitGDIPlus(hadl&)
    'Bild wird verzerrt, ist aber nicht so verpixelt

endproc

Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...

05.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

Michael
W.

Müsste das Image nicht auch weg? Finde es so auf die Schnelle nicht bei MS - die haben da ja mächtig umgeräumt (nichts mehr am alten Platz).

XProfan X3
System: Windows 8/10, XProfan X4
Programmieren, das spannendste Detektivspiel der Welt.

05.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

ByteAttack

Michael W. (05.09.15)

Müsste das Image nicht auch weg? Finde es so auf die Schnelle nicht bei MS - die haben da ja mächtig umgeräumt (nichts mehr am alten Platz).

Finde ich auch richtig sch....ade. Durch ihr neues Visual Studio haben sie alle "wichtigen" Informationen der MSDN in das .net-Format gebracht...
Alle Links die ich hatte, sind quasi wertlos...

XProfan X3
Website: [...]

Facebook: [...]

05.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

- Seite 2 -

GDL

Hallo Jörg,

da hab ich auch schon rumprobiert.

Wenn ich deleteobject hBitmap& dort einfüge stürzt XProfan ab.

Nehme ich XPSE her, muss diese Def. nachträglich am Programmanfang eingefügt werden.

DEF CreateStreamOnHGlobal(3)!"OLE32","CreateStreamOnHGlobal"

Sonst bricht XPSE ab.

Nach Einfügen der Def geht mit XPSE dann zwar Deleteobject hBitmap&

aber es wird trotzdem immer langsamer und bricht nach dem 40ten Thumb ab.

Grüßle
Georg

fehler.png	21 kB

Hochgeladen:	05.09.2015

Ladeanzahl:
		Herunterladen

Windows7 Xprofan 8,9,10 [...]

[...]

05.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

Michael
W.

Das eigentliche Speicher-Problem liegt in "Testen".
Dort wird h& für 2 Bilder genutzt.
Ich habe es mal auf h1& und h2& geändert.

Außerdem werden die DLL's ständig wieder aus dem Speicher geworfen. Lass sie doch bis zum Ende drin. Da InitGDIPlus und ExitGDIPlus die DLL's noch brauchen (und sie damit wieder in den Speicher holen) habe ich das mal in InitGDI und ExitGDI ausgelagert.

Kompilieren Markieren Separieren

'Vorschaubild aus großen Bilddateien
'Bilddateigröße war beim Test 4,19mb groß
Declare GDIP&,OLE&,Kernel&

Proc InitGDI

    GDIP& = ImportDll("Gdiplus.dll","")
    OLE& = ImportDll("Ole32.dll","")
    Kernel& = ImportDll("Kernel32.dll","")

EndProc

Proc ExitGDI

    FreeDLL Kernel&
    FreeDLL OLE&
    FreeDLL GDIP&

EndProc

declare h1&,h2&,b&,c&,d&,za&,ze&,pfad$
cls
b&=create("picbutton",%hwnd,0,10,10,105,105)
c&=create("picbutton",%hwnd,0,300,10,105,105)
d&=create("picbutton",%hwnd,0,10,230,105,105)

proc testen

    '==============================================
    'Wie telefonisch besprochen (David)
    'XProfan1
    h1&=create("hnewpic",100,100,0)
    za&=&GetTickCount
    startpaint h1&
    drawsizedpic pfad$,0,0-100,100;0
    endpaint
    Sendmessage(b&,$00F7,0,h1&)
    ze&=&GetTickCount
    drawtext 10,120,str$(ze&-za&)+" Millisekunden XProfan Version1"
    drawtext 10,150," Seitenverhältnis stimmt nicht"
    'Bild wird verzerrt
    '================================================================
    'Nach XProfan2
    za&=&GetTickCount
    h2&=Create("hSizedPic",-1,pfad$,100,100,1)
    Sendmessage(c&,$00F7,0,h2&)
    ze&=&GetTickCount
    drawtext 300,120,str$(ze&-za&)+" Millisekunden XProfan Version2"
    'Bild wird nicht verzerrt
    '==================================================================

endproc

'######################################
' von Dieter Zornow

Proc InitGDIPlus

    Declare gdpsi#,gdiplusToken&
    STRUCT GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    External("GDIPLUS.DLL","GdiplusStartup",ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    Return gdiplusToken&

EndProc

Proc ExitGDIPlus

    Parameters gdiplusToken&
    External("GDIPLUS.DLL","GdiplusShutdown",gdiplusToken&)

Endproc

Proc CatchImage

    Parameters MemPointer& ,Size&
    Struct GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Declare gdpsi#,gdiplusToken&,ImageObject&,GraphicObject&,pStream&,RetVal&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    GdiplusStartup(ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    'Speicher bereitstellen
    Var m_hBuffer& = GlobalAlloc(2,Size&)
    Var pBuffer& = GlobalLock(m_hBuffer&)
    RtlMoveMemory(pBuffer&,MemPointer&,Size&)
    GlobalUnlock(m_hBuffer&)
    'Stream erzeugen
    CreateStreamOnHGlobal(m_hBuffer&,1,Addr(pStream&))
    GdipCreateBitmapFromStream(pStream&,Addr(ImageObject&))
    'hBitmap erzeugen
    GdipCreateHBITMAPFromBitmap(ImageObject&,Addr(RetVal&),0)
    'aufräumen
    Var Command& = Long(pStream&,0)
    call(Long(Command&,8),pStream&)'IStream.Release
    GlobalFree(m_hBuffer&)
    GdipDisposeImage(ImageObject&)
    GdipDeleteGraphics(GraphicObject&)
    GdiplusShutdown(gdiplusToken&)
    Return RetVal&

EndProc

proc test1

    declare mem#,size&,bild$,ImageWidth&,ImageHeight&,Dreisatz!,ThumbHeight%,ThumbWidth%
    bild$=pfad$
    size& = filesize(bild$)
    dim mem#,size&
    set("Filemode",0)
    Blockread(bild$,mem#,0,size&)
    set("filemode",2)
    var hBild& = CatchImage(mem#,sizeof(mem#))
    Dispose mem#
    declare Image&,Thumb&,hBitmap&
    var hadl& = InitGDIPlus()

    While 1

        External("GDIPLUS.DLL","GdipCreateBitmapFromHBITMAP",hbild&,0,addr(Image&))
        External("GDIPLUS.DLL","GdipGetImageWidth",Image&,ADDR(ImageWidth&))'Breite ermitteln
        External("GDIPLUS.DLL","GdipGetImageHeight",Image&,ADDR(ImageHeight&))'Hoehe ermitteln
        Case ImageWidth& = 0 : Break
        Case ImageHeight& = 0 : Break

        if ImageWidth& = ImageHeight&' Quadratisch

            ThumbWidth% = 100
            ThumbHeight% = 100

        elseif ImageWidth& > ImageHeight&' Querformat

            Dreisatz! = ImageWidth&/100
            ThumbHeight% = ImageHeight&/Dreisatz!
            ThumbWidth% = 100

        elseif ImageWidth& < ImageHeight&' Hochformat

            Dreisatz! = ImageHeight&/100
            ThumbWidth% = ImageWidth&/Dreisatz!
            ThumbHeight% = 100

        endif

        External("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,ThumbWidth%,ThumbHeight%,addr(Thumb&),0,0)'Thumb size
        External("GDIPLUS.DLL","GdipCreateHBITMAPFromBitmap",Thumb&,addr(hBitmap&),0)
        Sendmessage(d&,$00F7,0,hBitmap&)
        BREAK

    EndWhile

    ExitGDIPlus(hadl&)
    'Bild wird verzerrt, ist aber nicht so verpixelt

endproc

'#####################################################
chdir "C:\\bueroumgebung\\verzeichnis031\\weihnachten\\"'Pfad zum Testen anpassen
pfad$=upper$(LoadFile$("Lade ein Bild","*.jpg"))
case right$(pfad$,4)=".JPG" : testen
InitGDI()
za&=&GetTickCount
case right$(pfad$,4)=".JPG" : test1
ze&=&GetTickCount
ExitGDI()
drawtext 10,350,str$(ze&-za&)+" Millisekunden XProfan GDI-Plus"
drawtext 10,380," Seitenverhältnis stimmt nicht"
waitinput
deleteobject h1&,h2&

XProfan X3
System: Windows 8/10, XProfan X4
Programmieren, das spannendste Detektivspiel der Welt.

05.09.2015 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

GDL

@Michael

Das "Testen" war bei den letzten Posts nicht mehr im Versuchsprog.
Sorry, war mein Fehler.

Ausschlaggebend war dies:

Der nun gehende Versuchsaufbau:

Kompilieren Markieren Separieren

'Vorschaubild aus großen Bilddateien
'Bilddateigröße war beim Test 4,19mb groß
 {$CLQ}
Declare GDIP&,OLE&,Kernel&
DEF CreateStreamOnHGlobal(3)!"OLE32","CreateStreamOnHGlobal"

Proc InitGDI

    GDIP& = ImportDll("Gdiplus.dll","")
    OLE& = ImportDll("Ole32.dll","")
    Kernel& = ImportDll("Kernel32.dll","")

EndProc

Proc ExitGDI

    FreeDLL Kernel&
    FreeDLL OLE&
    FreeDLL GDIP&

EndProc

declare b&,c&,d&,za&,ze&,pfad$,i%,RetVal&
cls
d&=create("picbutton",%hwnd,0,10,230,105,105)
'######################################
' von Dieter Zornow

Proc InitGDIPlus

    Declare gdpsi#,gdiplusToken&
    STRUCT GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    External("GDIPLUS.DLL","GdiplusStartup",ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    Return gdiplusToken&

EndProc

Proc ExitGDIPlus

    Parameters gdiplusToken&
    External("GDIPLUS.DLL","GdiplusShutdown",gdiplusToken&)

Endproc

Proc CatchImage

    Parameters MemPointer& ,Size&
    Struct GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Declare gdpsi#,gdiplusToken&,ImageObject&,GraphicObject&,pStream&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    GdiplusStartup(ADDR(gdiplusToken&),gdpsi#,0)
    Dispose gdpsi#
    'Speicher bereitstellen
    Var m_hBuffer& = GlobalAlloc(2,Size&)
    Var pBuffer& = GlobalLock(m_hBuffer&)
    RtlMoveMemory(pBuffer&,MemPointer&,Size&)
    GlobalUnlock(m_hBuffer&)
    'Stream erzeugen
    CreateStreamOnHGlobal(m_hBuffer&,1,Addr(pStream&))
    GdipCreateBitmapFromStream(pStream&,Addr(ImageObject&))
    'hBitmap erzeugen
    GdipCreateHBITMAPFromBitmap(ImageObject&,Addr(RetVal&),0)
    'aufräumen
    Var Command& = Long(pStream&,0)
    call(Long(Command&,8),pStream&)'IStream.Release
    GlobalFree(m_hBuffer&)
    GdipDisposeImage(ImageObject&)
    GdipDeleteGraphics(GraphicObject&)
    GdiplusShutdown(gdiplusToken&)
    Return RetVal&

EndProc

proc test1

    declare mem#,size&,bild$,ImageWidth&,ImageHeight&,Dreisatz!,ThumbHeight%,ThumbWidth%
    bild$=pfad$
    size& = filesize(bild$)
    dim mem#,size&
    set("Filemode",0)
    Blockread(bild$,mem#,0,size&)
    set("filemode",2)
    var hBild& = CatchImage(mem#,sizeof(mem#))
    Dispose mem#
    declare Image&,Thumb&,hBitmap&
    var hadl& = InitGDIPlus()
    External("GDIPLUS.DLL","GdipCreateBitmapFromHBITMAP",hbild&,0,addr(Image&))
    External("GDIPLUS.DLL","GdipGetImageWidth",Image&,ADDR(ImageWidth&))'Breite ermitteln
    External("GDIPLUS.DLL","GdipGetImageHeight",Image&,ADDR(ImageHeight&))'Hoehe ermitteln

    if ImageWidth& = ImageHeight&' Quadratisch

        ThumbWidth% = 100
        ThumbHeight% = 100

    elseif ImageWidth& > ImageHeight&' Querformat

        Dreisatz! = ImageWidth&/100
        ThumbHeight% = ImageHeight&/Dreisatz!
        ThumbWidth% = 100

    elseif ImageWidth& < ImageHeight&' Hochformat

        Dreisatz! = ImageHeight&/100
        ThumbWidth% = ImageWidth&/Dreisatz!
        ThumbHeight% = 100

    endif

    External("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,ThumbWidth%,ThumbHeight%,addr(Thumb&),0,0)'Thumb size
    External("GDIPLUS.DLL","GdipCreateHBITMAPFromBitmap",Thumb&,addr(hBitmap&),0)
    Sendmessage(d&,$00F7,0,hBitmap&)
    ExitGDIPlus(hadl&)
    'Bild wird verzerrt, ist aber nicht so verpixelt

endproc

'#####################################################
chdir "C:\\bueroumgebung\\verzeichnis031\\weihnachten\\"'Pfad zum Testen anpassen
pfad$=upper$(LoadFile$("Lade ein Bild","*.jpg"))
InitGDI()
i%=1

whilenot i% > 1000

    za&=&GetTickCount
    case right$(pfad$,4)=".JPG" : test1
    deleteobject RetVal&'wichtig
    ze&=&GetTickCount
    inc i%
    drawtext 10,350,str$(ze&-za&)+" Millisekunden XProfan GDI-Plus"
    drawtext 10,380," Seitenverhältnis stimmt nicht"

wend

ExitGDI()
waitinput