Option Explicit
 
'############ 'Für RGB Auswertung  #######################
Private Declare Function GetSysColor Lib "user32" ( _
                               ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
        "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal _
        ByteLen As Long)
 
 
Private Type OLECOLOR
   RedOrSys As Byte
   Green As Byte
   Blue As Byte
   Type As Byte
End Type
 
Dim sysRGB As Boolean, sysHex As Boolean, sysVB As Boolean
Dim sysR$, sysG$, sysB$
Private Const VK_F1 = &H70

 
Private Sub Command1_Click()
   Call sysFalse
   Call Del
End Sub

 
Private Sub sysFalse()
   sysRGB = False
   sysHex = False
   sysVB = False
End Sub

 
Private Sub Del()
   txtRed.Text = ""
   txtGreen.Text = ""
   txtBlue.Text = ""
   txtHexR.Text = ""
   txtHexG.Text = ""
   txtHexB.Text = ""
   txtvbR.Text = ""
   txtvbG.Text = ""
   txtvbB.Text = ""
End Sub

 
Private Sub ConvertRGB()
   Dim strColor As String
 
   If txtRed <> "" Then
   If txtRed > 255 Then txtRed = 255
   If Len(txtRed) < 1 Then
        txtRed = ""
        lblRed = Hex(0)
    Else
        lblRed = Hex(txtRed)
    End If
    End If
 
    If txtGreen <> "" Then
    If txtGreen > 255 Then txtGreen = 255
    If Len(txtGreen) < 1 Then
        txtGreen = ""
        lblGreen = Hex(0)
    Else
        lblGreen = Hex(txtGreen)
    End If
    End If
 
    If txtBlue <> "" Then
    If txtBlue > 255 Then txtBlue = 255
    If Len(txtBlue) < 1 Then
        txtBlue = ""
        lblBlue = Hex(0)
    Else
        lblBlue = Hex(txtBlue)
    End If
    End If
 
 
    If Len(lblBlue) = 1 Then
      lblBlue = "0" & lblBlue
    End If
 
    If Len(lblRed) = 1 Then
      lblRed = "0" & lblRed
    End If
 
    If Len(lblGreen) = 1 Then
      lblGreen = "0" & lblGreen
    End If
 
   txtHexR = lblRed
   txtHexG = lblGreen
   txtHexB = lblBlue
 
   txtvbB = lblBlue
   txtvbG = lblGreen
   txtvbR = lblRed
 
   If txtRed <> "" Then sysR$ = txtRed Else sysR$ = "0"
   If txtGreen <> "" Then sysG$ = txtGreen Else sysG$ = "0"
   If txtBlue <> "" Then sysB$ = txtBlue Else sysB$ = "0"
 
   strColor = RGB(sysR, sysG, sysB)
 
  Picture1.BackColor = strColor
End Sub

 
Private Sub txtBlue_Change()
    If sysRGB Then ConvertRGB
End Sub

 
Private Sub txtBlue_Click()
   sysFalse
   sysRGB = True
End Sub

 
Private Sub txtGreen_Change()
    If sysRGB Then ConvertRGB
End Sub

 
Private Sub txtGreen_Click()
   sysFalse
   sysRGB = True
End Sub

 
Private Sub txtRed_Change()
    If sysRGB Then ConvertRGB
End Sub

 
Private Sub txtRed_Click()
   sysFalse
   sysRGB = True
End Sub

 
Private Sub ConvertHex()
   Dim strColor As String
   Dim strTemp As String
 
   On Error GoTo err
 
   If txtHexR <> "" Then sysR$ = txtHexR Else sysR$ = "00"
   If txtHexG <> "" Then sysG$ = txtHexG Else sysG$ = "00"
   If txtHexB <> "" Then sysB$ = txtHexB Else sysB$ = "00"
 
   strColor = "&H" & sysB & sysG & sysR '& "&"
 
   Picture1.BackColor = strColor
    Text1.Text = Picture1.BackColor
    strTemp = Text1.Text
 
   If txtHexR <> "" Then
    If Len(txtHexR) < 1 Then
        txtHexR = ""
        lblRed2 = 0
     Else
        lblRed2 = R(strTemp)
        lblRed = txtHexR
     End If
    End If
 
    If txtHexG <> "" Then
     If Len(txtHexG) < 1 Then
        txtHexG = ""
        lblGreen2 = 0
     Else
        lblGreen2 = G(strTemp)
        lblGreen = txtHexG
     End If
    End If
 
    If txtHexB <> "" Then
     If Len(txtHexB) < 1 Then
        txtHexB = ""
        lblBlue2 = 0
     Else
        lblBlue2 = B(strTemp)
        lblBlue = txtHexB
     End If
    End If
 
    If Len(lblBlue2) = 1 Then
      lblBlue2 = "0" & lblBlue2
    End If
 
    If Len(lblRed2) = 1 Then
      lblRed2 = "0" & lblRed2
    End If
 
    If Len(lblGreen2) = 1 Then
      lblGreen2 = "0" & lblGreen2
    End If
 
   txtRed = lblRed2
   txtGreen = lblGreen2
   txtBlue = lblBlue2
 
   txtvbB = lblBlue
   txtvbG = lblGreen
   txtvbR = lblRed
 Exit Sub
err:
   Exit Sub
End Sub

Private Sub txtHexR_Change()
    If sysHex Then ConvertHex
End Sub

Private Sub txtHexG_Change()
    If sysHex Then ConvertHex
End Sub

Private Sub txtHexB_Change()
    If sysHex Then ConvertHex
End Sub

 
Private Sub txtHexR_Click()
   sysFalse
   sysHex = True
End Sub

 
Private Sub txtHexG_Click()
   sysFalse
   sysHex = True
End Sub

 
Private Sub txtHexB_Click()
   sysFalse
   sysHex = True
End Sub

 
 
Private Sub ConvertVB()
   Dim strColor As String
   Dim strTemp As String
 
 
   On Error GoTo err
 
   If txtvbR <> "" Then sysR$ = txtvbR Else sysR$ = "00"
   If txtvbG <> "" Then sysG$ = txtvbG Else sysG$ = "00"
   If txtvbB <> "" Then sysB$ = txtvbB Else sysB$ = "00"
 
   strColor = "&H" & sysB & sysG & sysR '& "&"
 
   Picture1.BackColor = strColor
    Text1.Text = Picture1.BackColor
    strTemp = Text1.Text
 
   If txtvbR <> "" Then
    If Len(txtvbR) < 1 Then
        txtvbR = ""
        lblRed2 = 0
      Else
        lblRed2 = R(strTemp)
        lblRed = txtvbR
     End If
    End If
 
    If txtvbG <> "" Then
     If Len(txtvbG) < 1 Then
        txtvbG = ""
        lblGreen2 = 0
     Else
        lblGreen2 = G(strTemp)
        lblGreen = txtvbG
     End If
    End If
 
    If txtvbB <> "" Then
     If Len(txtvbB) < 1 Then
        txtvbB = ""
        lblBlue2 = 0
     Else
        lblBlue2 = B(strTemp)
        lblBlue = txtvbB
     End If
    End If
 
    If Len(lblBlue2) = 1 Then
      lblBlue2 = "0" & lblBlue2
    End If
 
    If Len(lblRed2) = 1 Then
      lblRed2 = "0" & lblRed2
    End If
 
    If Len(lblGreen2) = 1 Then
      lblGreen2 = "0" & lblGreen2
    End If
 
   txtRed = lblRed2
   txtGreen = lblGreen2
   txtBlue = lblBlue2
 
   txtHexB = lblBlue
   txtHexG = lblGreen
   txtHexR = lblRed
 Exit Sub
err:
   Exit Sub
End Sub

Private Sub txtvbR_Change()
    If sysVB Then ConvertVB
End Sub

Private Sub txtvbG_Change()
    If sysVB Then ConvertVB
End Sub

Private Sub txtvbB_Change()
    If sysVB Then ConvertVB
End Sub

 
Private Sub txtvbR_Click()
   sysFalse
   sysVB = True
End Sub

 
Private Sub txtvbG_Click()
   sysFalse
   sysVB = True
End Sub

 
Private Sub txtvbB_Click()
   sysFalse
   sysVB = True
End Sub

 
Private Function WinColor(VBColor As Long) As Long
   Dim SysClr As OLECOLOR
 
   CopyMemory SysClr, VBColor, Len(SysClr)
 
   If SysClr.Type = &H80 Then 'Es ist eine Systemfarbe
      WinColor = GetSysColor(SysClr.RedOrSys)
   Else 'Es ist keine Systemfarbe
      WinColor = VBColor
   End If
End Function

 
Private Function R(ByVal Color As Long) As Byte
   CopyMemory R, WinColor(Color), 1
End Function

 
Private Function G(ByVal Color As Long) As Byte
   CopyMemory G, ByVal VarPtr(WinColor(Color)) + 1, 1
End Function

 
Private Function B(ByVal Color As Long) As Byte
   CopyMemory B, ByVal VarPtr(WinColor(Color)) + 2, 1
End Function

 
 
Private Sub Form_KeyDown(KeyCode As Integer, _
                                         Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtRed_KeyDown(KeyCode As Integer, _
                                         Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtRed_KeyPress(KeyAscii As Integer)
   cKeyPress2 KeyAscii
End Sub

 
Private Sub txtGreen_KeyDown(KeyCode As Integer, _
                                         Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtGreen_KeyPress(KeyAscii As Integer)
   cKeyPress2 KeyAscii
End Sub

 
Private Sub txtBlue_KeyDown(KeyCode As Integer, _
                                         Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtBlue_KeyPress(KeyAscii As Integer)
   cKeyPress2 KeyAscii
End Sub

 
Private Sub txtHexR_KeyDown(KeyCode As Integer, _
                                         Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtHexR_KeyPress(KeyAscii As Integer)
   cKeyPress KeyAscii
End Sub

 
Private Sub txtHexG_KeyDown(KeyCode As Integer, _
                                       Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtHexG_KeyPress(KeyAscii As Integer)
   cKeyPress KeyAscii
End Sub

 
Private Sub txtHexB_KeyDown(KeyCode As Integer, _
                                      Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtHexB_KeyPress(KeyAscii As Integer)
   cKeyPress KeyAscii
End Sub

 
Private Sub txtvbR_KeyDown(KeyCode As Integer, _
                                       Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtvbR_KeyPress(KeyAscii As Integer)
   cKeyPress KeyAscii
End Sub

 
Private Sub txtvbG_KeyDown(KeyCode As Integer, _
                                       Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtvbG_KeyPress(KeyAscii As Integer)
   cKeyPress KeyAscii
End Sub

 
Private Sub txtvbB_KeyDown(KeyCode As Integer, _
                                        Shift As Integer)
   ChortCt KeyCode, Shift
End Sub

 
Private Sub txtvbB_KeyPress(KeyAscii As Integer)
   cKeyPress KeyAscii
End Sub

 
 
' Tasten
Private Sub cKeyPress(KeyAscii As Integer)
  Select Case KeyAscii
    Case 48 To 57, 65, 66, 67, 68, 69, 70, _
                         97, 98, 99, 100, 101, 102, 8
        ' nur 0-9, a b c d e f <==
    Case Else
      KeyAscii = 0
  End Select
End Sub

 
Private Sub cKeyPress2(KeyAscii As Integer)
  Select Case KeyAscii
    Case 48 To 57, 8
        ' nur 0-9, <==
    Case Else
      KeyAscii = 0
  End Select
End Sub

 
 'ChortCut
Private Sub ChortCt(KeyCode As Integer, Shift As Integer)
  If KeyCode = VK_F1 Then
  '    ...
  ElseIf KeyCode = vbKeyEscape Then
     '  ...
  ElseIf KeyCode = vbKeyReturn Then 'Enter
     '...
  ElseIf KeyCode = vbKeyDelete Then 'Entf
     '...
  ElseIf (Shift And 2) > 0 Then 'Strg
        'Tastaturcode auswerten
      Select Case KeyCode
            'Umleitung auf Menübefehle
          Case vbKeyB: '...
          Case vbKeyO: '...
      End Select
  End If
End Sub