XProfan

Italia

Andreas Miethe:

'###############################################
'BITMAPS auf Speicherbereich mappen und Mostra
'###############################################
'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$ = "farbe.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-Testata 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

14.05.2005 ▲

Vollständiges Zitat

Absatzweise Citazione Zeilenweise Citazione

Jörg
Sellmeyer

Repariert...

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

28.05.2020 ▲

Vollständiges Zitat

Absatzweise Citazione Zeilenweise Citazione

Michael
W.

sicher?
Einmal heraus kopiert - [F9] - Fehler

Den Kommentaren fehlt das Apostroph

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

31.05.2020 ▲

Vollständiges Zitat

Absatzweise Citazione Zeilenweise Citazione

Jörg
Sellmeyer

Hm - ich dachte, ich hätte. Entweder hat die Forumsoftware das schon wieder zerschossen, oder ich hab meinen Kommentar unter einen falschen Thread gesetzt.

Wie auch immer - jetzt läufts...

Kompilieren Markieren Separieren

'###############################################
'BITMAPS auf Speicherbereich mappen und Mostra
'###############################################
'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 !
'###############################################
 $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"'Pfad anpassen
'mit einem Bild, deutlich größer als 8000 x 8000 (215mb), funktioniert es
Dim OfStruct#,136
Dim DataPointer#,4
Dim PixelStartPointer#,4
Dim BMPHeader#,54
Let FileHeaderLenght& = 14
FileMode 0
Assign #1,Filename$
OpenRW #1
'Bitmap-Testata 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-2041,1400
'Ist der File ein gültiges Bitmap ???

If word(bmpheader#,0) = identifyer&'im Original war hier Hex$(word(bmpheader#,0)) mit identifiyer& verglichen worden, was naturalmente nicht geht

    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

waitinput
End