English
Source / code snippets

Bitmaps Uebergosse process

 
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  
 




Jörg
Sellmeyer
Repariert...
 
XProfan X4
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...
05/28/20  
 




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  
 




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...
'###############################################
'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
 
Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...
05/31/20  
 



Zum Quelltext


Topictitle, max. 100 characters.
 

Systemprofile:

no Systemprofil laid out. [anlegen]

XProfan:

 Posting  Font  Smilies  ▼ 

Please register circa a Posting To verfassen.
 

Topic-Options

3.792 Views

Untitledvor 0 min.
N.Art11/18/20
iF09/24/20
Stephan Sonneborn09/22/20
Ernst09/07/20
More...

Themeninformationen



Admins  |  AGB  |  Applications  |  Authors  |  Chat  |  Privacy Policy  |  Download  |  Entrance  |  Help  |  Merchantportal  |  Imprint  |  Mart  |  Interfaces  |  SDK  |  Services  |  Games  |  Search  |  Support

One proposition all XProfan, The there's!


My XProfan
Private Messages
Own Storage Forum
Topics-Remember-List
Own Posts
Own Topics
Clipboard
Log off
 Deutsch English Français Español Italia
Translations

Privacy Policy


we use Cookies only as Session-Cookies because of the technical necessity and with us there no Cookies of Drittanbietern.

If you here on our Website click or navigate, stimmst You ours registration of Information in our Cookies on XProfan.Net To.

further Information To our Cookies and moreover, How You The control above keep, find You in ours nachfolgenden Datenschutzerklärung.


all rightDatenschutzerklärung
i want none Cookie