'-- Form1, Picture1, Command1, Command2, 1.bmp (Bitmap-Datei in App.Path)
Option Explicit
 
Private Const DIB_RGB_COLORS      As Long = 0
Private Const OBJ_BITMAP          As Long = 7
 
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
 
Private Type BITMAP
    bmType       As Long
    bmWidth      As Long
    bmHeight     As Long
    bmWidthBytes As Long
    bmPlanes     As Integer
    bmBitsPixel  As Integer
    bmBits       As Long
End Type
 
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
 
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
 
Private Declare Function CreateFile Lib "kernel32.dll" _
    Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    lpSecurityAttributes As Any, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long
 
Private Declare Function CreateFileMapping Lib "kernel32.dll" Alias _
    "CreateFileMappingA" ( _
    ByVal hFile As Long, _
    ByVal lpFileMappigAttributes As Long, _
    ByVal flProtect As Long, _
    ByVal dwMaximumSizeHigh As Long, _
    ByVal dwMaximumSizeLow As Long, _
    ByVal lpName As String) As Long
 
'Private Declare Function OpenFileMapping Lib "kernel32.dll" _
    Alias "OpenFileMappingA" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal lpName As String) As Long
 
 
' Erstellen eines geräte-unabhängigen Bildes (Device Independent Bitmap, DIB)
Private Declare Function CreateDIBSection Lib "gdi32" _
    (ByVal hDC As Long, ByRef pbmi As BITMAPINFO, ByVal iUsage As Long, ByRef _
    ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, _
    ByVal hObject As Long) As Long
 
Private Declare Function BitBlt Lib "gdi32" ( _
    ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
    ByVal dwRop As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" ( _
    lpDst As Any, ByVal Length As Long)
 
'Private Declare Function MapViewOfFile Lib "kernel32" ( _
    ByVal hFileMappingObject As Long, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwFileOffsetHigh As Long, _
    ByVal dwFileOffsetLow As Long, _
    ByVal dwNumberOfBytesToMap As Long) As Long
 
'Private Declare Function UnmapViewOfFile Lib "kernel32" ( _
    lpBaseAddress As Any) As Long
 
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    ByVal pDest As String, _
    ByVal pSrc As Long, _
    ByVal ByteLen As Long)
Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" ( _
       ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
 
'MISC consts
Private Const VT_BY_REF = &H4000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const MOVEFILE_REPLACE_EXISTING = &H1
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_BEGIN = 0
Private Const CREATE_NEW = 1
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const PAGE_READWRITE = 4
Private Const FILE_MAP_WRITE = &H2
Private Const FILE_MAP_READ = &H4
Private Const FADF_FIXEDSIZE = &H10
Private Const INVALID_HANDLE_VALUE = -1
 
'Create -- Set backColor  ********************************************
Private Type RECT2
    X1 As Long
    Y1 As Long
    X2 As Long
    Y2 As Long
End Type
 
Private Declare Function SetRect Lib "user32" (lpRect As RECT2, _
    ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, _
    ByVal Y2 As Long) As Long
 
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
    lpRect As RECT2, ByVal hBrush As Long) As Long
 
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
    ByVal crColor As Long) As Long
 
Private m_BackColor As OLE_COLOR
 
 
Dim hFile     As Long
Dim hFileMap  As Long
Dim m_hDIb    As Long
Private m_HDC As Long
Dim m_lpBits  As Long
Dim m_hOldDIB As Long
Dim m_uBIH    As BITMAPINFO
Dim m_BytesWidth  As Long
Private MapW     As Long
Private MapH     As Long

 
Private Sub Command1_Click() '-- Schreiben
 
 Dim uBI      As BITMAP
 Dim lhDC     As Long
 Dim lhOldBmp As Long, image As StdPicture
 
 Set image = Picture1.Picture
 
 
 If (Not image Is Nothing) Then
 
        If (GetObjectType(image.Handle) = OBJ_BITMAP) Then
 
            Call GetObject(image.Handle, Len(uBI), uBI)
 
            If (Create(uBI.bmWidth, uBI.bmHeight)) Then
 
                lhDC = CreateCompatibleDC(0)
                If (lhDC <> 0) Then
                    lhOldBmp = SelectObject(lhDC, image.Handle)
 
                    '-- Load uBits
                    Call BitBlt(m_HDC, 0, 0, uBI.bmWidth, uBI.bmHeight, _
                                                    lhDC, 0, 0, vbSrcCopy)
 
                    '-- Destroy temp. DC
                    Call SelectObject(lhDC, lhOldBmp)
                    Call DeleteDC(lhDC)
 
                    Call Destroy
 
                    '-- DIB-TEST ==> m_HDC sollte leer sein
                    Picture1.Picture = LoadPicture("")
                    Call BitBlt(Picture1.hDC, 0, 0, m_uBIH.bmiHeader.biWidth, m_uBIH.bmiHeader.biHeight, _
                                                    m_HDC, 0, 0, vbSrcCopy)
                    Picture1.Refresh
                End If
            End If
        End If
    End If
End Sub

 
Private Sub Command2_Click() '-- Lesen
 
     '-- Prepare header
    With m_uBIH.bmiHeader
        .biSize = Len(m_uBIH.bmiHeader)
        .biPlanes = 1
        .biBitCount = 24
        .biWidth = MapW
        .biHeight = MapH
        m_BytesWidth = (.biWidth * (.biBitCount \ 8) + 3) And -4&
        .biSizeImage = .biHeight * m_BytesWidth
    End With
 
    '-- DIB erstellen und Speicher auslesen
    m_HDC = CreateCompatibleDC(0)
    If m_HDC <> 0 Then
       m_hDIb = CreateDIBSection(m_HDC, m_uBIH, DIB_RGB_COLORS, m_lpBits, hFileMap, 0)
       If m_hDIb <> 0 Then
          '-- Select into a DC device context
          m_hOldDIB = SelectObject(m_HDC, m_hDIb)
       End If
    End If
 
    '-- Bild Laden
    Picture1.Picture = LoadPicture("")
    Call BitBlt(Picture1.hDC, 0, 0, m_uBIH.bmiHeader.biWidth, m_uBIH.bmiHeader.biHeight, _
                                                    m_HDC, 0, 0, vbSrcCopy)
    Picture1.Refresh
 
End Sub

 
Public Function Create(ByVal NewWidth As Long, ByVal NewHeight As Long) As Long ', Optional ByVal NewBPP As dibBPPCts = [32_bpp]) As Long
    Dim uRect  As RECT2
    Dim hBrush As Long
 
    CloseHandle hFile
    CloseHandle hFileMap
    Call Destroy
 '   Kill App.Path & "\Test.bmp"
 
      '-- Prepare header
    With m_uBIH.bmiHeader
        .biSize = Len(m_uBIH.bmiHeader)
        .biPlanes = 1
        .biBitCount = 24
        .biWidth = NewWidth
        .biHeight = NewHeight
        m_BytesWidth = (.biWidth * (.biBitCount \ 8) + 3) And -4&
        .biSizeImage = .biHeight * m_BytesWidth
        MapW = .biWidth
        MapH = .biHeight
    End With
 
    '-- Erstellen einer 0-Byte Datei
    hFile = CreateFile(App.Path & "\Test.bm", GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
 
    '-- Handle auslesen sowie Speicher einlesen und Datei schreiben
    hFileMap = CreateFileMapping(hFile, 0, PAGE_READWRITE, 0, m_uBIH.bmiHeader.biSizeImage, ByVal 0&) '"MyDIB")
 
    '-- Create DIB section
    m_HDC = CreateCompatibleDC(0) '-- oder: (PictureBox.hDC)
    If (m_HDC <> 0) Then
        '-- Create DIB
        m_hDIb = CreateDIBSection(m_HDC, m_uBIH, DIB_RGB_COLORS, m_lpBits, hFileMap, 0)
     '   If (m_hDIb = 0) Then m_hDIb = CreateDIBSection(m_HDC, m_uBIH, DIB_RGB_COLORS, m_lpBits, 0, 0)
        If (m_hDIb <> 0) Then
            '-- Select into a DC device context
           m_hOldDIB = SelectObject(m_HDC, m_hDIb)
           '-- Set backColor
           Call SetRect(uRect, 0, 0, NewWidth, NewHeight)
           hBrush = CreateSolidBrush(m_BackColor)
           Call FillRect(m_HDC, uRect, hBrush)
           Call DeleteObject(hBrush)
        Else
           Call Destroy
           MsgBox "Fehler m_hDib"
        End If
    End If
    '-- Success
    Create = m_hDIb
End Function

 
Private Sub Destroy()
    '-- Destroy DIB
    If (m_HDC <> 0) Then
        If (m_hDIb <> 0) Then
            Call SelectObject(m_HDC, m_hOldDIB)
            Call DeleteObject(m_hDIb)
        End If
        Call DeleteDC(m_HDC)
    End If
 
    '-- Reset BIH structure
    Call ZeroMemory(m_uBIH, Len(m_uBIH))
 
    '-- Reset DIB vars.
    m_HDC = 0
    m_hDIb = 0
    m_hOldDIB = 0
    m_lpBits = 0
End Sub

 
Private Sub Form_Load()
    Picture1.ScaleMode = 3
    Picture1.AutoRedraw = True
    Picture1.AutoSize = True
    Picture1.Picture = LoadPicture(App.Path & "\1.bmp")
    m_BackColor = vbWhite
    Me.Caption = "Create FileMapping"
    Command1.Caption = "Map-Einlesen und DIB löschen"
    Command2.Caption = "Map-Auslesen und DIB füllen"
End Sub