XProfan

'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%
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&,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()
    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
    ze&=&GetTickCount
    inc i%
    drawtext 10,350,str$(ze&-za&)+" Millisekunden XProfan GDI-Plus"
    drawtext 10,380," Seitenverhältnis stimmt nicht"

wend

ExitGDI()
waitinput