PDA

Vollständige Version anzeigen : Bunte Endlosformulare-Teil1 BMP mit einem Pixel erstellen


Marsu65
28.01.2013, 20:44
Hallo zusammen,

da meine Anwender es manchmal bunt mögen, tauchte immer mal wieder die Frage auf, wie man Datensätze im Endlosformular farbig 'untermalen' kann.

Kommt man mit 4 Farben (3 + Standard) aus, reicht die bedingte Formatierung.
Auch wenn in den letzten Acc-Versionen nun 50 bed. Formatierungsmöglichkeiten gegeben sind, bleibt der Nachteil, dass wenn mal die Farbe gewechselt werden soll oder eine neue hinzukommt, muss das entweder im Entwurf oder programmatisch geschehen.

Eine andere Möglichkeit, sein Endlosformular bunt zu machen und dabei flexibel zu bleiben, bietet die Vorhaltung von Farben in einer Tabelle als OLE-Bild.
Jetzt schreien sicher viele, dass Bilder nicht in eine DB gehören, da sie dadurch extrem aufgebläht werden kann.

Für Hintergrundfarben, welche z.B. in gebundenen OLE-Steuerelementen dargestellt werden, reicht jedoch eine Bitmap mit einem einzigen Pixel.

Wie man eine solche Bitmap-Datei erstellt, zeigt folgender Modulcode:

Option Compare Database
Option Explicit

'////////////////////////////////////////////////////////////////////////
'// Modul zur Erstellung einer BMP-Datei mit nur einem Farbpixel (24bit)
'// INHALT:
'// CreateSinglePixelBMP Erstellen einer BMP-Datei mit einem Pixel
'//
'// Autor: Axel Prott (DeBePRO)
'// (c) Das Modul und Teile davon dürfen frei verwendet werden.
'// Ein Hinweis auf die Herkunft/den Autor gehört zum guten Ton!
'// Based on:
'// http://de.wikipedia.org/wiki/Windows_Bitmap
'// http://www.uvm.edu/~rerickso/education/vb_bmp/BMP.html
'////////////////////////////////////////////////////////////////////////

'Dateikopf 14 Bytes
Private Type BITMAPFILEHEADER
bfType As String * 2 ' file type always &H4D42h or "BM" or &19778
bfSize As Long ' size in bytes usually 0 for uncompressed (58 for 1 Pixel), unzuverlaessig
bfReserved As Long ' always 0
bfOffBits As Long ' normaly 54, starting position of image data in bytes
End Type

'Informationsblock 40 Bytes
Private Type BITMAPINFOHEADER
biSize As Long 'Size of this header, always 40
biWidth As Long 'width of your image (this time=1)
biHeight As Long 'height of your image (this time=1)
biPlanes As Integer 'always 1
biBitCount As Integer 'Farbtiefe number of bits per pixel 1, 4, 8, or 24! We take 24
biCompression As Long '0 data is not compressed
biSizeImage As Long 'size of bitmap in bytes, typicaly 0 when uncompressed
biXPelsPerMeter As Long 'normaly 0, preferred resolution in pixels per meter
biYPelsPerMeter As Long 'normaly 0, preferred resolution in pixels per meter
biClrUsed As Long 'number of colors that are actually used (can be 0)
biClrImportant As Long 'which color is most important (0 means all of them)
End Type

Private Type PIXEL 'Die Bitmapstruktur moechte gerne die Reihenfolge BGR
piBlue As Byte 'daher nicht vertauschen!
piGreen As Byte
piRed As Byte
End Type

Const ENDBYTE As Byte = 0 'Fuer das Leerbyte am Ende.
'Notwendig, da eine Zeile aus durch 4 teilbaren Bytes bestehen muss


Public Function CreateSinglePixelBMP _
(ByVal lColor As Long, _
ByVal sFilename As String) As Boolean
'Erstellt eine BMP-Datei mit einem Pixel
'Parameter: lColor Windowsfarbe als LONG
' sFilename Pfad inkl.Dateiname für die Speicherung der BMP-Datei
'Rueckgabe: Im Fehlerfall FALSE, sonst TRUE
'Autor: Axel Prott (DeBePRO)
'Version: 1.0 28.01.2013
'(c) Frei zu verwenden. Ein Hinweis auf die Herkunft/den Autor gehört zum guten Ton!
On Error GoTo Err_handler
Dim BMPHead As BITMAPFILEHEADER 'HeaderStructure
Dim BMPInfo As BITMAPINFOHEADER 'InfoStructure
Dim Pix As PIXEL 'PixelStructure BGR
Dim aRGB As Variant 'Datenfeld fuer PixelStructure
Dim ff As Integer 'Freefile

CreateSinglePixelBMP = True 'Init
'get RGB from Long
aRGB = Split(Farbanteile(lColor), ",")

'assign values
'Header
BMPHead.bfType = "BM"
BMPHead.bfSize = 58
BMPHead.bfReserved = 0
BMPHead.bfOffBits = 54
'Info
BMPInfo.biSize = 40
BMPInfo.biWidth = 1
BMPInfo.biHeight = 1
BMPInfo.biPlanes = 1
BMPInfo.biBitCount = 24
BMPInfo.biCompression = 0
BMPInfo.biSizeImage = 4 '0
BMPInfo.biXPelsPerMeter = 0
BMPInfo.biYPelsPerMeter = 0
BMPInfo.biClrUsed = 0
BMPInfo.biClrImportant = 0
'the one and only pixel
Pix.piBlue = aRGB(2)
Pix.piGreen = aRGB(1)
Pix.piRed = aRGB(0)

'check if File exists
If Len(Dir(sFilename)) > 0 Then
Kill sFilename
DoEvents
End If

'put our data into file
ff = FreeFile
Open sFilename For Binary Access Write Lock Write As ff
Put #ff, , BMPHead
Put #ff, , BMPInfo
Put #ff, , Pix
Put #ff, , ENDBYTE
Close ff
DoEvents
Exit Function
Err_handler:
CreateSinglePixelBMP = False
MsgBox "Error " & Err.Number & " in Function CreateSinglePixelBMP (mdl_BMP_Create_SinglePix):" & vbCrLf & Err.Description
End Function


Private Function Farbanteile(ByVal Farbe As Long) As String
'// Liefert ein String mit den Farbanteilen RGB zurueck
'// Parameter: Farbe
'// Rueckgabe: r,g,b
'// by Axel Prott (DeBePRO)
On Error GoTo errorhandler
Farbanteile = Str$(Farbe And vbRed) & ","
Farbanteile = Farbanteile & Str$((Farbe And vbGreen) \ &H100) & ","
Farbanteile = Farbanteile & Str$((Farbe And vbBlue) \ &H10000)
Exit Function
errorhandler:
MsgBox "Error " & Err.Number & " in Function Farbanteile (mdl_Farben):" & vbCrLf & Err.Description
Farbanteile = vbNullString
End Function


Sub testCreateSinglePixelBMP()
Call CreateSinglePixelBMP(vbRed, CurrentProject.Path & "\red.bmp")
End Sub


Wie man die Bitmap-Datei per Hilfsformular und VBA in ein OLE-Feld bekommt, wird später folgen.