XProfan

'############################################
'Bilder mit OLE laden und Mostra
'############################################
'Andreas Miethe * Juli 2002
'############################################
'ab Profan 7.X
'############################################
'getestet mit Win98, WinME und WinXP
'soll aber auch schon mit Win95
'funktionieren.
'############################################
'unterstützte Formate :
'BMP,RLE,DIB,JPG,JPE,JPEG,GIF,EMF,WMF,CUR,ICO
'keine animierten Gif's
'############################################
'Definitionen
DEF CreateStreamOnHGlobal(3) ! "OLE32","CreateStreamOnHGlobal"
DEF OleLoadPicture(5) ! "OLEPRO32","OleLoadPicture"
DEF OleInitialize(1) ! "OLE32","OleInitialize"
DEF OleUnInitialize(0) ! "OLE32","OleUninitialize"
DEF GlobalAlloc(2)  ! "KERNEL32","GlobalAlloc"
DEF GlobalLock(1)  ! "KERNEL32","GlobalLock"
DEF GlobalUnlock(1)  ! "KERNEL32","GlobalUnlock"
DEF GlobalFree(1)  ! "KERNEL32","GlobalFree"
DEF CopyMemory(3)  ! "KERNEL32","RtlMoveMemory"
DEF SelectObject(2) ! "gdi32","SelectObject"
DEF GetDeviceCaps(2) ! "gdi32","GetDeviceCaps"
DEF GetDC(1) ! "User32","GetDC"
DEF ReleaseDC(2) ! "User32","ReleaseDC"
DEF FindResource(3) ! "KERNEL32","FindResourceA"
DEF LoadResource(2) ! "KERNEL32","LoadResource"
DEF SizeOfResource(2) ! "KERNEL32","SizeofResource"
'Konstanten
DEF &Picture_Release     8
DEF &Picture_GetHandle  12
DEF &Picture_GetType    20
DEF &Picture_Get_Width  24
DEF &Picture_Get_Height 28
DEF &Picture_Render     32
DEF &Picture_Select     44
'Globale Variablen
DECLARE OLE32&,OLEPRO32&
DECLARE IID_IPicture#
DECLARE PData#
DECLARE HMEM&
'Prozeduren

Proc Ole_Init'Ole-Schnittstelle initialisieren und Variablen fuellen

    OLE32& = UseDll("OLE32")
    OLEPRO32& = UseDll("OLEPRO32")
    OleInitialize(0)
    Dim IID_IPicture#,16
    Long IID_IPicture#,0 = $7BF80980
    Word IID_IPicture#,4 = $BF32
    Word IID_IPicture#,6 = $101A
    Byte IID_IPicture#,8 = $8B
    Byte IID_IPicture#,9 = $BB
    Byte IID_IPicture#,10 = $00
    Byte IID_IPicture#,11 = $AA
    Byte IID_IPicture#,12 = $00
    Byte IID_IPicture#,13 = $30
    Byte IID_IPicture#,14 = $0C
    Byte IID_IPicture#,15 = $AB

EndProc

Proc Ole_Free'Ole-Schnittstelle Speicherbereiche freigeben

    GlobalFree(Hmem&)
    OleUnInitialize()
    FreeDll OLE32&
    FreeDll OLEPRO32&
    DISPOSE IID_IPicture#

EndProc

Proc Ole_LoadImage'Bild mit OLE laden

    Declare MemPointer&,PStream&,PictureObject&,PSize&
    Parameters Picture$
    '------------------------
    Filemode 0
    PSIZE& = Filesize(Picture$)
    Dim PData#,PSIZE&
    Assign #1,Picture$
    OpenRW #1
    BlockRead(#1,PData#,0,PSIZE&)'Daten in Bereichsvariable einlesen
    CloseRW #1
    '------------------------
    GlobalFree(Hmem&)
    HMem& = GlobalAlloc($022,PSize&)'Speicher reservieren
    Mempointer& = GlobalLock(Hmem&)'Pointer auf Speicher
    CopyMemory(MemPointer&,PData#,PSize&)'Bereichsvariable in Speicher schieben
    DISPOSE PData#'Bereichsvariable freigeben
    GlobalUnlock(HMem&)'Speicher zum Gebrauch freigeben
    CreateStreamOnHGlobal(Hmem&,1,addr(PStream&))'Stream-Pointer erstellen
    OleLoadPicture(PStream&,PSIZE&,0,IID_IPicture#,ADDR(PictureObject&))'Pointer fuer Pictureobject
    '------------------------
    Case PictureObject& > 0 : Return PictureObject&
    Case PictureObject& = 0 : Return 0

EndProc

Proc Ole_LoadResImage'Bild aus Modul mit OLE laden

    Declare MemPointer&,PStream&,PictureObject&,PSize&
    Declare Reshandle&,GlobalMem&
    Parameters Modul&,Resname$,Restype$
    GlobalFree(Hmem&)
    '------------------------
    'Resource laden
    Reshandle& = FindResource(Modul&,addr(Resname$),addr(Restype$))
    Globalmem& = LoadResource(Modul&,ResHandle&)
    PSize& = SizeOfResource(Modul&,Reshandle&)
    '------------------------
    HMem& = GlobalAlloc($022,PSize&)'Speicher reservieren
    Mempointer& = GlobalLock(Hmem&)'Pointer auf Speicher
    CopyMemory(MemPointer&,Globalmem&,PSize&)'Bereichsvariable in Speicher schieben
    GlobalUnlock(HMem&)'Speicher zum Gebrauch freigeben
    CreateStreamOnHGlobal(Hmem&,1,addr(PStream&))'Stream-Pointer erstellen
    OleLoadPicture(PStream&,PSIZE&,0,IID_IPicture#,ADDR(PictureObject&))'Pointer fuer Pictureobject
    '------------------------
    Case PictureObject& > 0 : Return PictureObject&
    Case PictureObject& = 0 : Return 0

EndProc

Proc Ole_RenderImage'Bild auf DC rendern

    Parameters DC&,wnd&,PictureObject&,xx&,yy&,ww&,hh&,Center&
    Declare Command&,Aspect!,xpixels&,ypixels&,ImageWidth&,ImageHeight&,w&,h&,ImageX&,ImageY&
    Command& = Long(PictureObject&,0)
    'RENDERN vorbereiten
    'Breite und Hoehe auslesen
    Call(@Long(Command&,&Picture_Get_Width),PictureObject&,addr(w&))
    Call(@Long(Command&,&Picture_Get_Height),PictureObject&,addr(h&))
    'Imagebreite und Hoehe berechnen
    xpixels& = GetDeviceCaps(DC&, 88)
    ypixels& = GetDeviceCaps(DC&, 90)
    ImageWidth&  = (w&*xpixels&)/2540
    ImageHeight& = (h&*ypixels&)/2540
    'Imagebreite und Hoehe an Fenster anpassen falls zu gross
    Aspect! = Imagewidth&/ImageHeight&

    If OR(Imagewidth& > ww&,Imageheight& > hh&)

        ImageHeight& = hh&
        ImageWidth& =  ImageHeight&*aspect!

        If ImageWidth& > ww&

            ImageWidth& = ww&
            ImageHeight& = ImageWidth&/aspect!

        EndIf

    Endif

    'und Einfuegepunkte (Zentrierung) berechnen

    If Center& = 1

        ImageX& = width(%hwnd)/2 - Imagewidth&/2
        ImageY& = height(%hwnd)/2 - Imageheight&/2

    Else

        ImageX& = xx&
        ImageY& = yy&

    Endif

    'auf DC Rendern
    Call(@Long(Command&,&Picture_Render),PictureObject&,DC&,Imagex&,Imagey&,Imagewidth&,ImageHeight&,0,h&,w&,(h&*-1),0)

EndProc

Proc Ole_GetType'Bildtyp ermitteln

    Parameters PictureObject&
    Declare Command&,PicFormat&
    Command& = Long(PictureObject&,0)
    Call(@Long(Command&,&Picture_GetType),PictureObject&,addr(PicFormat&))
    Return PicFormat&

EndProc

Proc Ole_GetHandle'BildHandle ermitteln

    Parameters PictureObject&
    Declare Command&,PicHandle&
    Command& = Long(PictureObject&,0)
    Call(@Long(Command&,&Picture_GetHandle),PictureObject&,addr(PicHandle&))
    Return PicHandle&

EndProc

Proc Ole_FreeImage'Bild freigeben

    Parameters PictureObject&
    Declare Command&
    Command& = Long(PictureObject&,0)
    Call(@Long(Command&,&Picture_Release),PictureObject&)

EndProc

'############################################
'Bilder mit OLE laden und Mostra
'############################################
'Andreas Miethe * Juli 2002
'############################################
'ab Profan 7.X
'############################################
'getestet mit Win98, WinME und WinXP
'Laut Microsoft mit WindowNT ab Version 4.0
'und Windows95 lauffaehig
'############################################
'unterstützte Formate :
'BMP,RLE,DIB,JPG,JPE,JPEG,GIF,EMF,WMF,CUR,ICO
'keine animierten Gif's
'############################################
'
'Anwendungsbeispiel
'
'############################################
'
'Prozeduren der Include
'1. Ole_Init -> initialisiert die Ole_Schnittstelle
'------------------------------------------------------------------------------------
'2. Ole_LoadImage -> Laedt das Bild und gibt einen Zeiger auf das Bildobject zurueck
'   Parameter Filename$
'------------------------------------------------------------------------------------
'3. Ole_RenderImage -> Rendert das Bild auf ein DC
'   Parameter   : DC&
'               : FensterHandle des DC
'               : Zeiger auf Bildobject
'               : Einfuegepunkt X
'               : Einfuegepunkt Y
'               : Breite
'               : Hoehe
'               : Flag fuer Zentrierung
'                       1 = Zentrieren X,Y,W und H koenne Null sein
'                       0 = kein Zentrieren X,Y,W und H mussen angegeben werden
'------------------------------------------------------------------------------------
'4. Ole_GetType -> ermittelt den Bildtypen
'   Parameter Zeiger auf Bildobject
'   Rueckgabe   : 1 fuer BITAP
'               : 2 fuer WMF
'               : 3 fuer ICON Oder CURSOR
'               : 2 fuer EMF
'------------------------------------------------------------------------------------
'5. Ole_FreeImage -> gibt das Bildobject frei
'   Parameter Zeiger auf Bildobject
'------------------------------------------------------------------------------------
'6. Ole_Free -> gibt die Ole_Schnittstelle und Speicherbereich frei
'------------------------------------------------------------------------------------
'7. Ole_LoadResImage -> Laedt das Bild aus einem Modul und
'                       gibt einen Zeiger auf das Bildobject zurueck
'   Parameter   : 1 = ModulHandle
'               : 2 = Resource-Name
'               : 3 = Resource-Typ
'------------------------------------------------------------------------------------
 $I profalt.inc'erspart etliche Reparaturen - fürs schnelle Testen...
 $I Ole_LoadImage.inc
DECLARE PictureObject&,Picture$,Type&
window 0,0-%maxx,%Maxy
cls rgb(192,192,192)
Ole_Init()

If Picture$ = ""

    Picture$ = LoadFile$("ÖFFNE","alle unterstützten Formate|*.dib;*.bmp;*.rle;*.jpe;*.jpeg;*.jpg;*.gif;*.ico;*.cur;*.emf;*.wmf|\
    Bitmap (bmp,rle,dib)|*.bmp;*.rle;*.dib|Jpeg (jpg,jpe,jpeg)|*.jpg;*.jpe;*.jpeg|Gif (gif)|*.gif|\
    Enhanced Metafile (emf)|*.emf|Metafile (wmf)|*.wmf|Icons (Ico)|*.ico|Cursor (cur)|*.cur")

endif

If Picture$ <> ""

    UseCursor 2
    'Ole_LoadResImage 0,"#100","JPEG"
    PictureObject& = Ole_LoadImage(Picture$)

    If PictureObject& > 0

        Ole_RenderImage(%hdc2,%hwnd,PictureObject&,0,0,width(%hwnd),height(%hwnd),1)
        Repaint'Update
        Type& = Ole_GetType(PictureObject&)
        Case Type& = 1: Settext %hwnd,"Bitmap"
        Case Type& = 2: Settext %hwnd,"WMF"
        Case Type& = 3: Settext %hwnd,"Icon / Cursor"
        Case Type& = 4: Settext %hwnd,"EMF"
        UseCursor 0
        Ole_FreeImage(PictureObject&)

    else

        MessageBox("Falsches Grafikformat ! Oder File beschädigt","Meldung",0)

    Endif

endif

waitinput
Ole_Free()
End