Zurück zur Homepage

Dialog zur Farbauswahl

Um eine Farbe zu wählen, muss man das Rad nicht neu erfinden. Windows hat in der comdlg32.dll eine Menge Standarddialoge, darunter auch einen zur Wahl der Farbe. Damit man den Dialog auf dem Bildschirm beliebig positionieren kann, braucht man einen Hook. Das ist zwar auch in Excel möglich, würde den Code aber unnötig aufblähen und birgt gewisse Risiken. Also habe ich es weggelassen.
Dafür wird der RGB-Wert aber in die Zwischenablage kopiert. Ob man das wirklich braucht, sei dahingestellt, es ist aber ein nettes Feature. Das Kopieren von Strings in die Zwischenablage ist übrigens komplizierter, als es sich anhört. Viele, viele Programmabstürze hat mich das vor ein paar Jahren gekostet, als ich die Funktionen geschrieben habe.

Beispielmappe (farben.zip 20 KB)

 

'In ein Modul zur Farbauswahl

Option Explicit
Private Type CHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type


Private Declare Function CHOOSEMYCOLOR Lib "comdlg32.dll" Alias _
    "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long


Public Sub DialogFarbe()

Dim a As CHOOSECOLOR, x As Long, y As String
Dim CustomColors(63) As Byte
Dim R As Byte, G As Byte, B As Byte
a.lpCustColors = StrConv(CustomColors, vbUnicode)
a.lStructSize = Len(a)
If CHOOSEMYCOLOR(a) <> 0 Then
    x = a.rgbResult
    y = String(6 - Len(Hex(x)), Asc("0")) & Hex(x)
    R = CByte("&H" & Right(y, 2))
    G = CByte("&H" & Mid(y, 3, 2))
    B = CByte("&H" & Left(y, 2))
    MsgBox "Farbe Lng = " & x & vbCrLf & _
    "Farbe Hex = " & y & vbCrLf & _
    "Rot = " & Right(y, 2) & vbCrLf & _
    "Grün = " & Mid(y, 3, 2) & vbCrLf & _
    "Blau = " & Left(y, 2) & vbCrLf & _
    "Rot = " & R & vbCrLf & _
    "Grün = " & G & vbCrLf & _
    "Blau = " & B
    With Worksheets("Farbe")
        .Range("a1").Interior.Color = x
        .Range("b1").Interior.Color = RGB(R, G, B)
    End With
    BringTextInsClipboard " RGB(" & R & " ," & G & " ," & B & ")"
End If
End Sub

 'In ein anderes Modul zum Kopieren in die Zwischenablage

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (Destination As Any, _
    Source As Any, ByVal Length As Long)

Private Declare Function CloseClipboard Lib _
    "user32" () As Long

Private Declare Function OpenClipboard Lib _
    "user32" (ByVal hWnd As Long) As Long

Private Declare Function EmptyClipboard Lib _
    "user32" () As Long

Private Declare Function SetClipboardData Lib _
    "user32" (ByVal wFormat As Long, ByVal hMem _
    As Long) As Long

Private Declare Function GetClipboardData Lib _
    "user32" (ByVal wFormat As Long) As Long

Private Declare Function IsClipboardFormatAvailable _
    Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32" _
    (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GlobalLock Lib "kernel32" _
    (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32" _
    (ByVal hMem As Long) As Long

Private Declare Function GlobalSize Lib "kernel32" _
    (ByVal hMem As Long) As Long


Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_SHARE = &H2000
Private Const GMEM_All = (GMEM_ZEROINIT Or GMEM_SHARE Or _
    GMEM_MOVEABLE)
Private Const CF_TEXT = 1


Public Sub BringTextInsClipboard(ByVal DenText As String)

Dim hMemory As Long, lngMemoryText As Long, Länge As Long
Dim xxx() As Byte
xxx = StrConv(DenText & vbNullChar, vbFromUnicode)
Länge = UBound(xxx) + 1
'Speicher reservieren
hMemory = GlobalAlloc(GMEM_All, Länge)
'Zeiger holen. Solange gültig, bis GlobalUnlock
lngMemoryText = GlobalLock(hMemory)
'Text in den Speicher kopieren
CopyMemory ByVal lngMemoryText, xxx(0), Länge
'Clipboard öffnen
OpenClipboard 0&
'Clipboard leeren
EmptyClipboard
'Clipboard füllen
SetClipboardData CF_TEXT, ByVal lngMemoryText
'Clipboard schließen
CloseClipboard
GlobalUnlock hMemory
End Sub


Public Function TextAusClipboard() As String

Dim c As String, d As Long
Dim hMemory As Long, lngMemoryText As Long, Länge As Long
'Überprüfen, ob Clipboard Text enthält
If IsClipboardFormatAvailable(CF_TEXT) Then
    'Clipboard öffnen
    OpenClipboard 0&
    'Zeiger auf den Block, der Text enthält
    hMemory = GetClipboardData(CF_TEXT)
    If hMemory = 0 Then
        'Kein Text, Clipboard schließen
        CloseClipboard
        Exit Function
    End If
    'Zeiger holen. Solange gültig, bis GlobalUnlock
    lngMemoryText = GlobalLock(hMemory)
    'Blocklänge ermitteln
    Länge = GlobalSize(lngMemoryText)
    'Buffer initialisieren
    c = String(Länge, 0)
    'Text in Buffer Kopieren
    CopyMemory ByVal c, ByVal lngMemoryText, Länge
    GlobalUnlock lngMemoryText
    'Clipboard schließen
    CloseClipboard
    'Textlänge (Pos ASC(0)) ermitteln und kürzen
    TextAusClipboard = Left$(c, InStr(1, c, Chr(0)) - 1)
End If
End Function