XProfan

'############################################
'Images with OLE loading and Show
'############################################
'Andreas Miethe * july 2002
'############################################
'ex Profan 7.X
'############################################
'tested with Win98, WinME and WinXP
'but should already with Win95
'functions.
'############################################
'supported Formate :
'BMP,RLE,DIB,JPG,JPE,JPEG,GIF,EMF,WMF,CUR,ICO
'no 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 variables
DECLARE OLE32&,OLEPRO32&
DECLARE IID_IPicture#
DECLARE PData#
DECLARE HMEM&
'Procedures

Proc Ole_Init'Ole-interface initialisieren and variables 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-interface Speicherbereiche enable

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

ENDPROC

Proc Ole_LoadImage'Image with OLE loading

    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&)'data in Memory-Variable reading
    CloseRW #1
    '------------------------
    GlobalFree(Hmem&)
    HMem& = GlobalAlloc($022,PSize&)'memory reservieren
    Mempointer& = GlobalLock(Hmem&)'Pointer on memory
    CopyMemory(MemPointer&,PData#,PSize&)'Memory-Variable in memory schieben
    DISPOSE PData#'Memory-Variable enable
    GlobalUnlock(HMem&)'memory to that use enable
    CreateStreamOnHGlobal(Hmem&,1,addr(PStream&))'Stream-Pointer create
    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'Image Module with OLE loading

    Declare MemPointer&,PStream&,PictureObject&,PSize&
    Declare Reshandle&,GlobalMem&
    Parameters Modul&,Resname$,Restype$
    GlobalFree(Hmem&)
    '------------------------
    'Resource loading
    Reshandle& = FindResource(Modul&,addr(Resname$),addr(Restype$))
    Globalmem& = LoadResource(Modul&,ResHandle&)
    PSize& = SizeOfResource(Modul&,Reshandle&)
    '------------------------
    HMem& = GlobalAlloc($022,PSize&)'memory reservieren
    Mempointer& = GlobalLock(Hmem&)'Pointer on memory
    CopyMemory(MemPointer&,Globalmem&,PSize&)'Memory-Variable in memory schieben
    GlobalUnlock(HMem&)'memory to that use enable
    CreateStreamOnHGlobal(Hmem&,1,addr(PStream&))'Stream-Pointer create
    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'Image to 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 preparing
    'wide and Hoehe read
    Call(@Long(Command&,&Picture_Get_Width),PictureObject&,addr(w&))
    Call(@Long(Command&,&Picture_Get_Height),PictureObject&,addr(h&))
    'Imagebreite and Hoehe to charge
    xpixels& = GetDeviceCaps(DC&, 88)
    ypixels& = GetDeviceCaps(DC&, 90)
    ImageWidth&  = (w&*xpixels&)/2540
    ImageHeight& = (h&*ypixels&)/2540
    'Imagebreite and Hoehe on Window adjust if To tall
    Aspect! = Imagewidth&/ImageHeight&

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

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

        If ImageWidth& > ww&

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

        EndIf

    Endif

    'and Einfuegepunkte (Zentrierung) to charge

    If Center& = 1

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

    Else

        ImageX& = xx&
        ImageY& = yy&

    Endif

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

ENDPROC

Proc Ole_GetType'Bildtyp detect

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

ENDPROC

Proc Ole_GetHandle'Image Handle detect

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

ENDPROC

Proc Ole_FreeImage'Image enable

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

ENDPROC

'############################################
'Images with OLE loading and Show
'############################################
'Andreas Miethe * july 2002
'############################################
'ex Profan 7.X
'############################################
'tested with Win98, WinME and WinXP
'loudly Microsoft with WindowNT ex Version 4.0
'and Windows95 lauffaehig
'############################################
'supported Formate :
'BMP,RLE,DIB,JPG,JPE,JPEG,GIF,EMF,WMF,CUR,ICO
'no animierten Gif's
'############################################
'
'Anwendungsbeispiel
'
'############################################
'
'Procedures the Include
'1. Ole_Init -> initialized The Ole_Schnittstelle
'------------------------------------------------------------------------------------
'2. Ole_LoadImage -> Laedt the image and gives a Zeiger the Bildobject back
'   Parameter Filename$
'------------------------------------------------------------------------------------
'3. Ole_RenderImage -> Rendert the image on one DC
'   Parameter   : DC&
'               : FensterHandle the DC
'               : Zeiger on Bildobject
'               : Einfuegepunkt X
'               : Einfuegepunkt Y
'               : wide
'               : Hoehe
'               : Flag fuer Zentrierung
'                       1 = Center X,Y,W and H koenne zero his
'                       0 = no Center X,Y,W and H mussen indicated go
'------------------------------------------------------------------------------------
'4. Ole_GetType -> determined whom Bildtypen
'   Parameter Zeiger on Bildobject
'   Rueckgabe   : 1 fuer BITAP
'               : 2 fuer WMF
'               : 3 fuer ICON or CURSOR
'               : 2 fuer EMF
'------------------------------------------------------------------------------------
'5. Ole_FreeImage -> gives the Bildobject spare
'   Parameter Zeiger on Bildobject
'------------------------------------------------------------------------------------
'6. Ole_Free -> gives The Ole_Schnittstelle and Speicherbereich spare
'------------------------------------------------------------------------------------
'7. Ole_LoadResImage -> Laedt the image a Module and
'                       gives a Zeiger the Bildobject back
'   Parameter   : 1 = ModulHandle
'               : 2 = Resource-name
'               : 3 = Resource-type
'------------------------------------------------------------------------------------
 $I profalt.inc'erspart etliche Reparaturen - for speedy testing...
 $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 supported 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 ! or File beschädigt","Meldung",0)

    Endif

endif

waitinput
Ole_Free()
End