MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Access & Datenbanken > Microsoft Access - Code Archiv
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 28.01.2013, 20:44   #1
Marsu65
MOF Guru
MOF Guru
Standard Codebeispiel - Bunte Endlosformulare-Teil1 BMP mit einem Pixel erstellen

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:

Code:

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.

Geändert von Marsu65 (28.01.2013 um 20:55 Uhr).
Marsu65 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 18:07 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.