XProfan

Español

Andreas Miethe:

'###############################################
'BITMAPS en Speicherbereich mappen y Mostrar
'###############################################
'Das Problema de muy grossen Bitmaps, el con
'Profano no geladen voluntad, se así
'umgangen.
'Desweiteren es así moeglich una Mapa de bits
'en una Memory-Mapa de bits para dibujar. Man ha
'Así que una 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"
Declarar OfStruct#
Declarar DataPointer#
Declarar PixelStartPointer#
Declarar BMPHeader#
Declarar FileHeaderLenght&
Declarar OfBits&
Declarar BmpWidth&
Declarar BmpHeight&
Declarar 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
Declarar FileName$,FileHandle&,MapHandle&,Data&
Declarar OfBits&,BmpWidth&,BmpHeight&
Let FileName$ = "farbe.bmp" Pfad adaptar
Dim OfStruct#,136
Dim DataPointer#,4
Dim PixelStartPointer#,4
Dim BMPHeader#,54
Let FileHeaderLenght& = 14
FileMode 0
Asignar #1,Filename$
OpenRW #1
Mapa de bits-Encabezamiento einlesen
BlockRead(#1,BmpHeader#,0,54)
Cerrar #1
Let Identifyer& = $4D42 Mapa de bits-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 el File una gültiges Mapa de bits ???

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

    Let OfBits& = long(bmpheader#,10)Hier beginnen el Bilddaten
    Let BmpWidth& = long(bmpheader#,18)Ancho de imagen
    Let BmpHeight& = long(bmpheader#,22)Bildhoehe
    Mit OpenFile una File-Handle ermitteln
    Let Filehandle& = OpenFile(Addr(Filename$),OfStruct#,&OF_SHARE_DENY_NONE)
    Mit CreateFileMapping una Map-Handle ermitteln
    Let MapHandle& = CreateFileMapping(FileHandle&,0,&PAGE_READONLY,0,0,0)
    Mit MapViewOfFile una File-Mapping-Object invertir
    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&)
    'de el gemappten File en el 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)
    Declarar ende%,y%,x%
    Let y%=%wintop
    Let x%=%winleft
    Usermessages $0115,$0114

    Sinestar encargado 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

más

    'Bereichsvariablen liberación
    clear OfStruct#
    clear DataPointer#
    clear PixelStartPointer#
    clear BMPHeader#
    Disponer OfStruct#
    Disponer DataPointer#
    Disponer PixelStartPointer#
    Disponer BMPHeader#
    'Handles liberación
    UnmapViewOfFile(Data&)
    CloseHandle(FileHandle&)
    CloseHandle(MapHandle&)
    Imprimir "kein Bitmap"

endif

End

14.05.2005 ▲

Vollständiges Zitat

Absatzweise Cita Zeilenweise Cita

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 Cita Zeilenweise Cita

Michael
W.

sicher?
Einmal heraus kopiert - [F9] - Fehler

Den Kommentaren fehlt el Apostroph

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

31.05.2020 ▲

Vollständiges Zitat

Absatzweise Cita Zeilenweise Cita

Jörg
Sellmeyer

Hm - Yo pensamiento, Yo hätte. Entweder ha el Forumsoftware el ya otra vez zerschossen, oder Yo tener media Kommentar bajo una falschen Hilo gesetzt.

Como De todos modos - ahora läufts...

Kompilieren Marca Separación

'###############################################
'BITMAPS en Speicherbereich mappen y Mostrar
'###############################################
'Das Problema de muy grossen Bitmaps, el con
'Profano no geladen voluntad, se así
'umgangen.
'Desweiteren es así moeglich una Mapa de bits
'en una Memory-Mapa de bits para dibujar. Man ha
'Así que una 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"
Declarar OfStruct#
Declarar DataPointer#
Declarar PixelStartPointer#
Declarar BMPHeader#
Declarar FileHeaderLenght&
Declarar OfBits&
Declarar BmpWidth&
Declarar BmpHeight&
Declarar 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
Declarar FileName$,FileHandle&,MapHandle&,Data&
'Declarar OfBits&,BmpWidth&,BmpHeight&
Let FileName$ = "farbe.bmp"'Pfad adaptar
'con un Bild, deutlich größer como 8000 x 8000 (215mb), funktioniert lo
Dim OfStruct#,136
Dim DataPointer#,4
Dim PixelStartPointer#,4
Dim BMPHeader#,54
Let FileHeaderLenght& = 14
FileMode 0
Asignar #1,Filename$
OpenRW #1
'Mapa de bits-Encabezamiento einlesen
BlockRead(#1,BmpHeader#,0,54)
Cerrar #1
Let Identifyer& = $4D42'Mapa de bits-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 el File una gültiges Mapa de bits ???

If word(bmpheader#,0) = identifyer&'en el Original war hier Hex$(word(bmpheader#,0)) con identifiyer& verglichen worden, qué natürlich no va

    Let OfBits& = long(bmpheader#,10)'Hier beginnen el Bilddaten
    Let BmpWidth& = long(bmpheader#,18)'Ancho de imagen
    Let BmpHeight& = long(bmpheader#,22)'Bildhoehe
    'Mit OpenFile una File-Handle ermitteln
    Let Filehandle& = OpenFile(Addr(Filename$),OfStruct#,&OF_SHARE_DENY_NONE)
    'Mit CreateFileMapping una Map-Handle ermitteln
    Let MapHandle& = CreateFileMapping(FileHandle&,0,&PAGE_READONLY,0,0,0)
    'Mit MapViewOfFile una File-Mapping-Object invertir
    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&)
    'de el gemappten File en el 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)
    Declarar ende%,y%,x%
    Let y%=%wintop
    Let x%=%winleft
    Usermessages $0115,$0114

    Sinestar encargado 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

más

    'Bereichsvariablen liberación
    clear OfStruct#
    clear DataPointer#
    clear PixelStartPointer#
    clear BMPHeader#
    Disponer OfStruct#
    Disponer DataPointer#
    Disponer PixelStartPointer#
    Disponer BMPHeader#
    'Handles liberación
    UnmapViewOfFile(Data&)
    CloseHandle(FileHandle&)
    CloseHandle(MapHandle&)
    Imprimir "kein Bitmap"

endif

waitinput
End