XProfan

'Vorschaubild de großen Bilddateien
'Bilddateigröße war beim Test 4,19mb groß
 {$CLQ}
Declarar 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

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

Proc InitGDIPlus

    Declarar gdpsi#,gdiplusToken&
    STRUCT GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Dim gdpsi#,GdiplusStartupInput
    gdpsi#.GdiplusVersion& = 1
    gdpsi#.DebugEventCallback& = 0
    gdpsi#.SuppressBackgroundThread& = 0
    gdpsi#.SuppressExternalCodecs& = 0
    Externo("GDIPLUS.DLL","GdiplusStartup",ADDR(gdiplusToken&),gdpsi#,0)
    Disponer gdpsi#
    Volver gdiplusToken&

ENDPROC

Proc ExitGDIPlus

    Parámetros gdiplusToken&
    Externo("GDIPLUS.DLL","GdiplusShutdown",gdiplusToken&)

ENDPROC

Proc CatchImage

    Parámetros MemPointer& ,Size&
    Struct GdiplusStartupInput = GdiplusVersion&,DebugEventCallback&,SuppressBackgroundThread&,SuppressExternalCodecs&
    Declarar 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)
    Disponer 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& = Largo(pStream&,0)
    call(Largo(Command&,8),pStream&)'IStream.Release
    GlobalFree(m_hBuffer&)
    GdipDisposeImage(ImageObject&)
    GdipDeleteGraphics(GraphicObject&)
    GdiplusShutdown(gdiplusToken&)
    Volver RetVal&

ENDPROC

proc test1

    declarar 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#))
    Disponer mem#
    declarar Image&,Thumb&,hBitmap&
    var hadl& = InitGDIPlus()
    Externo("GDIPLUS.DLL","GdipCreateBitmapFromHBITMAP",hbild&,0,addr(Image&))
    Externo("GDIPLUS.DLL","GdipGetImageWidth",Image&,ADDR(ImageWidth&))'Breite ermitteln
    Externo("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

    Externo("GDIPLUS.DLL","GdipGetImageThumbnail",Image&,ThumbWidth%,ThumbHeight%,addr(Thumb&),0,0)'Thumb size
    Externo("GDIPLUS.DLL","GdipCreateHBITMAPFromBitmap",Thumb&,addr(hBitmap&),0)
    SendMessage(d&,$00F7,0,hBitmap&)
    ExitGDIPlus(hadl&)
    'Bild se verzerrt, es pero no así verpixelt

ENDPROC

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

whilenot i% > 1000

    za&=&GetTickCount
    caso 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