Farbcode-Eingabe
Hier konnen Sie verschiedene Farbcode eingeben, auch durcheinander. Anschließend wird die Farbe in der PictureBox angezeigt.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
 

 
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
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