XProfan

English

Andreas Miethe:

'###############################################
'BITMAPS on Speicherbereich mappen and Show
'###############################################
'The problem of very grossen Bitmaps, The with
'Profan not loaded go, becomes so
'umgangen.
'Desweiteren is it so moeglich one Bitmap
'into Memory-Bitmap to drawing. one has
'So one lever !
'###############################################
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$ = "farbe.bmp" way adjust
Dim OfStruct#,136
Dim DataPointer#,4
Dim PixelStartPointer#,4
Dim BMPHeader#,54
Let FileHeaderLenght& = 14
FileMode 0
Assign #1,Filename$
OpenRW #1
Bitmap-Header reading
BlockRead(#1,BmpHeader#,0,54)
Close #1
Let Identifyer& = $4D42 Bitmap-idendity
SetTrueColor 1
window %maxx+1,0-640,480
SetWindowLong(%hwnd,&GWL_STYLE,or(GetWindowLong(%hwnd,&GWL_STYLE),$300000))
setwindowpos %hwnd = 0,0-641,480
'is the File one gültiges Bitmap ???

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

    Let OfBits& = long(bmpheader#,10)here begin The Bilddaten
    Let BmpWidth& = long(bmpheader#,18)Bildbreite
    Let BmpHeight& = long(bmpheader#,22)Bildhoehe
    with OpenFile one File-lever detect
    Let Filehandle& = OpenFile(Addr(Filename$),OfStruct#,&OF_SHARE_DENY_NONE)
    with CreateFileMapping one Map-lever detect
    Let MapHandle& = CreateFileMapping(FileHandle&,0,&PAGE_READONLY,0,0,0)
    with MapViewOfFile one File-Mapping-Object lay out
    Let Data& = MapViewOfFile(MapHandle&,&FILE_MAP_READ,0,0,0)
    Pointer fuer Bitmapdaten
    Let DataPointer# = Int(Data& + FileHeaderLenght&)
    Pointer fuer Pixel-data
    Let PixelStartPointer# = Int(Data& + OfBits&)
    'from the gemappten File on the screen
    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 end%,y%,x%
    Let y%=%wintop
    Let x%=%winleft
    User Messages $0115,$0114

    Whilenot end%

        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

    'Memory-Variables enable
    clear OfStruct#
    clear DataPointer#
    clear PixelStartPointer#
    clear BMPHeader#
    Dispose OfStruct#
    Dispose DataPointer#
    Dispose PixelStartPointer#
    Dispose BMPHeader#
    'Handles enable
    UnmapViewOfFile(Data&)
    CloseHandle(FileHandle&)
    CloseHandle(MapHandle&)
    Print "kein Bitmap"

endif

End

05/14/05 ▲

Vollständiges Quote

Absatzweise Quote Zeilenweise Quote

Jörg
Sellmeyer

Repariert...

XProfan X4
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...

05/28/20 ▲

Vollständiges Quote

Absatzweise Quote Zeilenweise Quote

Michael
W.

sure?
once out copies - [F9] - Error

whom Kommentaren missing the apostrophe

Alle Sprachen
System: Windows 8/10, XProfan X4
Programmieren, das spannendste Detektivspiel der Welt.

05/31/20 ▲

Vollständiges Quote

Absatzweise Quote Zeilenweise Quote

Jörg
Sellmeyer

Hm - I thought, I had. either has The Forumsoftware the again zerschossen, or I Have my comment under a incorrect Thread staid.

however - now runs...

Compile Mark Separation

'###############################################
'BITMAPS on Speicherbereich mappen and Show
'###############################################
'The problem of very grossen Bitmaps, The with
'Profan not loaded go, becomes so
'umgangen.
'Desweiteren is it so moeglich one Bitmap
'into Memory-Bitmap to drawing. one has
'So one lever !
'###############################################
 $I profalt.inc
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$ = "farbe.bmp"'way adjust
'with a Image, explicit larger as 8000 x 8000 (215mb), functions it
Dim OfStruct#,136
Dim DataPointer#,4
Dim PixelStartPointer#,4
Dim BMPHeader#,54
Let FileHeaderLenght& = 14
FileMode 0
Assign #1,Filename$
OpenRW #1
'Bitmap-Header reading
BlockRead(#1,BmpHeader#,0,54)
Close #1
Let Identifyer& = $4D42'Bitmap-idendity
SetTrueColor 1
window %maxx+1,0-640,480
SetWindowLong(%hwnd,&GWL_STYLE,or(GetWindowLong(%hwnd,&GWL_STYLE),$300000))
setwindowpos %hwnd = 0,0-2041,1400
'is the File one gültiges Bitmap ???

If word(bmpheader#,0) = identifyer&'in the Original was here Hex$(word(bmpheader#,0)) with identifiyer& compared been, what naturally not goes

    Let OfBits& = long(bmpheader#,10)'here begin The Bilddaten
    Let BmpWidth& = long(bmpheader#,18)'Bildbreite
    Let BmpHeight& = long(bmpheader#,22)'Bildhoehe
    'with OpenFile one File-lever detect
    Let Filehandle& = OpenFile(Addr(Filename$),OfStruct#,&OF_SHARE_DENY_NONE)
    'with CreateFileMapping one Map-lever detect
    Let MapHandle& = CreateFileMapping(FileHandle&,0,&PAGE_READONLY,0,0,0)
    'with MapViewOfFile one File-Mapping-Object lay out
    Let Data& = MapViewOfFile(MapHandle&,&FILE_MAP_READ,0,0,0)
    'Pointer fuer Bitmapdaten
    Let DataPointer# = Int(Data& + FileHeaderLenght&)
    'Pointer fuer Pixel-data
    Let PixelStartPointer# = Int(Data& + OfBits&)
    'from the gemappten File on the screen
    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 end%,y%,x%
    Let y%=%wintop
    Let x%=%winleft
    User Messages $0115,$0114

    Whilenot end%

        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

    'Memory-Variables enable
    clear OfStruct#
    clear DataPointer#
    clear PixelStartPointer#
    clear BMPHeader#
    Dispose OfStruct#
    Dispose DataPointer#
    Dispose PixelStartPointer#
    Dispose BMPHeader#
    'Handles enable
    UnmapViewOfFile(Data&)
    CloseHandle(FileHandle&)
    CloseHandle(MapHandle&)
    Print "kein Bitmap"

endif

waitinput
End