FileMapping


Zu wenig Systemressourcen bei der VB6 Grafik-Bearbeitung?
Ein einfaches Script für die Erstellung von Auslagerungsdateien mit FileMapping.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Entwicklung des Scripts bei ActiveVB

Projekt - Download
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
'Erstellen Sie folgende Steuerelemente:
'CommandButton Command1, CommandButton Command2, Form Form1,
'


'-- 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