XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Bitmaps auf Speicherbereich mappen und anzeigen
###############################################
BITMAPS auf Speicherbereich mappen und anzeigen
###############################################
Das Problem von sehr grossen Bitmaps, die mit
Profan nicht geladen werden, wird damit
umgangen.
Desweiteren ist es so moeglich ein Bitmap
in ein Memory-Bitmap zu zeichnen. Man hat
also ein Handle !
###############################################
DEF OpenFile(3) ! Kernel32,OpenFile
DEF CreateFileMapping(6) ! Kernel32,CreateFileMappingA
DEF MapViewOfFile(5) ! Kernel32,MapViewOfFile
DEF UnmapViewOfFile(1) ! Kernel32,UnmapViewOfFile
DEF StretchDIBits(13) ! GDI32,StretchDIBits
DEF CloseHandle(1) ! Kernel32,CloseHandle
DEF GetWindowLong(2) !USER32, GetWindowLongA
DEF SetWindowLong(3) !USER32, SetWindowLongA
DEF ScrollWindow(5) User32,ScrollWindow
DEF ScrollWindowEx(8) User32,ScrollWindowEx
DEF SetScrollRange(5) ! USER32,SetScrollRange
DEF UpdateWindow(1) ! USER32,UpdateWindow
DEF GetDC(1) ! USER32,GetDC
DEF ScrollDC(7) User32,ScrollDC
Declare OfStruct#
Declare DataPointer#
Declare PixelStartPointer#
Declare BMPHeader#
Declare FileHeaderLenght&
Declare OfBits&
Declare BmpWidth&
Declare BmpHeight&
Declare Identifyer&
Def &OF_SHARE_DENY_NONE $040
Def &PAGE_READONLY $02
Def &FILE_MAP_READ $04
Def &DIB_RGB_COLORS  0
Def &SRCCOPY $0CC0020
Def &GWL_STYLE  -16
Def &SBM_SETRANGE $0E2
Def &SB_BOTH $03
Declare FileName$,FileHandle&,MapHandle&,Data&
Declare OfBits&,BmpWidth&,BmpHeight&
Let FileName$ = BIG.BMP Pfad anpassen
Dim OfStruct#,136
Dim DataPointer#,4
Dim PixelStartPointer#,4
Dim BMPHeader#,54
Let FileHeaderLenght& = 14
FileMode 0
Assign #1,Filename$
OpenRW #1
Bitmap-Header einlesen
BlockRead(#1,BmpHeader#,0,54)
Close #1
Let Identifyer& = $4D42 Bitmap-Identität
SetTrueColor 1
window %maxx+1,0-640,480
SetWindowLong(%hwnd,&GWL_STYLE,or(GetWindowLong(%hwnd,&GWL_STYLE),$300000))
setwindowpos %hwnd = 0,0-641,480
Ist der File ein gültiges Bitmap ???

If Hex$(word(bmpheader#,0)) = identifyer&

    Let OfBits& = long(bmpheader#,10)Hier beginnen die Bilddaten
    Let BmpWidth& = long(bmpheader#,18)Bildbreite
    Let BmpHeight& = long(bmpheader#,22)Bildhoehe
    Mit OpenFile ein File-Handle ermitteln
    Let Filehandle& = OpenFile(Addr(Filename$),OfStruct#,&OF_SHARE_DENY_NONE)
    Mit CreateFileMapping ein Map-Handle ermitteln
    Let MapHandle& = CreateFileMapping(FileHandle&,0,&PAGE_READONLY,0,0,0)
    Mit MapViewOfFile ein File-Mapping-Object anlegen
    Let Data& = MapViewOfFile(MapHandle&,&FILE_MAP_READ,0,0,0)
    Pointer fuer Bitmapdaten
    Let DataPointer# = Int(Data& + FileHeaderLenght&)
    Pointer fuer Pixel-Daten
    Let PixelStartPointer# = Int(Data& + OfBits&)
    aus dem gemappten File auf den Bildschirm
    StretchDIBits(%hdc,0,0,BmpWidth&,BmpHeight&,0,0,BmpWidth&,BmpHeight&,PixelStartPointer#,DataPointer#,&DIB_RGB_COLORS,&SRCCOPY)
    StretchDIBits(%hdc,0,0,BmpWidth&,BmpHeight&,0,0,BmpWidth&,BmpHeight&,PixelStartPointer#,DataPointer#,&DIB_RGB_COLORS,&SRCCOPY)
    Declare ende%,y%,x%
    Let y%=%wintop
    Let x%=%winleft
    Usermessages $0115,$0114

    Whilenot ende%

        Waitinput

        If %umessage = $0115

            StretchDIBits(%hdc,x%,y%,BmpWidth&,BmpHeight&,0,0,BmpWidth&,BmpHeight&,PixelStartPointer#,DataPointer#,&DIB_RGB_COLORS,&SRCCOPY)
            sub y%,10

        elseif %umessage = $0114

            StretchDIBits(%hdc,x%,y%,BmpWidth&,BmpHeight&,0,0,BmpWidth&,BmpHeight&,PixelStartPointer#,DataPointer#,&DIB_RGB_COLORS,&SRCCOPY)
            sub x%,10

        endif

    wend

else

    Bereichsvariablen freigeben
    clear OfStruct#
    clear DataPointer#
    clear PixelStartPointer#
    clear BMPHeader#
    Dispose OfStruct#
    Dispose DataPointer#
    Dispose PixelStartPointer#
    Dispose BMPHeader#
    Handles freigeben
    UnmapViewOfFile(Data&)
    CloseHandle(FileHandle&)
    CloseHandle(MapHandle&)
    Print kein Bitmap

endif

End