Conversion de couleurs (rvb) en hexadécimal utilisable avec visualbasic

Soyez le premier à donner votre avis sur cette source.

Vue 4 190 fois - Téléchargée 285 fois

Télécharger le projet

Commenter

Description

Ce code que je qualifierais d' "artisanal" est beaucoup plus utile que bien fait. Il s'addresse au débutant qui trouverons probablement utile eux aussi d'avoir un outil qui leur permettra de composer leur couleur et de pouvoir facilement les intégrer dans VB.

Source / Exemple :

Dim RGBRed As Integer
Dim RGBGreen As Long
Dim RGBBlue As Long
Dim DecRed As Integer
Dim DecGreen As Long
Dim DecBlue As Long
Dim Dec As Long
Dim Hex As String
Dim a As String
Dim b As String
Dim c As String
Dim d As String
Dim e As String
Dim f As String

Private Sub Command1_Click()
Restart:
RGBRed = RedBox.Text
RGBGreen = GreenBox.Text
RGBBlue = BlueBox.Text

Select Case RGBRed
  Case Is > 255
    RedBox.Text = "255"
    GoTo Restart
  Case Is < 0
    RedBox.Text = "0"
    GoTo Restart
End Select

Select Case RGBGreen
  Case Is > 255
    GreenBox.Text = "255"
    GoTo Restart
  Case Is < 0
    GreenBox.Text = "0"
    GoTo Restart
End Select

Select Case RGBBlue
  Case Is > 255
    BlueBox.Text = "255"
    GoTo Restart
  Case Is < 0
    BlueBox.Text = "0"
    GoTo Restart
End Select

GetDecimal
End Sub

Private Sub GetHex()
Dim WouldB As Long
Dim NewDec As Long
a = 0
b = 0
c = 0
d = 0
e = 0
f = 0

If Not Dec < 16 And Not Dec = 0 Then
   NewDec = Int(Dec / 16)
   WouldB = NewDec * 16
   a = Dec - WouldB
   Dec = NewDec
Else
a = Dec
b = 0
c = 0
d = 0
e = 0
f = 0
Dec = 0
HexArrangement
End If

If Not Dec < 16 And Not Dec = 0 Then
   NewDec = Int(Dec / 16)
   WouldB = NewDec * 16
   b = Dec - WouldB
   Dec = NewDec
Else
b = Dec
c = 0
d = 0
e = 0
f = 0
Dec = 0
HexArrangement
End If

If Not Dec < 16 And Not Dec = 0 Then
   NewDec = Int(Dec / 16)
   WouldB = NewDec * 16
   c = Dec - WouldB
   Dec = NewDec
Else
c = Dec
d = 0
e = 0
f = 0
Dec = 0
HexArrangement
End If

If Not Dec < 16 And Not Dec = 0 Then
   NewDec = Int(Dec / 16)
   WouldB = NewDec * 16
   d = Dec - WouldB
   Dec = NewDec
Else
d = Dec
e = 0
f = 0
Dec = 0
HexArrangement
End If

If Not Dec < 16 And Not Dec = 0 Then
   NewDec = Int(Dec / 16)
   WouldB = NewDec * 16
   e = Dec - WouldB
   Dec = NewDec
Else
e = Dec
f = 0
Dec = 0
HexArrangement
End If

If Not Dec < 16 And Not Dec = 0 Then
   NewDec = Int(Dec / 16)
   WouldB = NewDec * 16
   f = Dec - WouldB
   Dec = NewDec
Else
f = Dec
Dec = 0
HexArrangement
End If

End Sub

Public Function GetDecimal() As Currency

Label1.Caption = "Valeur RVB(RGB) : " & RGBRed & ", " & RGBGreen & ", " & RGBBlue

DecRed = RGBRed
DecGreen = RGBGreen * 256
DecBlue = RGBBlue * 65536
Dec = DecRed + DecGreen + DecBlue
Label2.Caption = "Valeur Décimale : " & Dec
GetHex

End Function

Private Sub HexArrangement()

Select Case a
    Case 10
      a = "A"
    Case 11
      a = "B"
    Case 12
      a = "C"
    Case 13
      a = "D"
    Case 14
      a = "E"
    Case 15
      a = "F"
End Select

Select Case b
    Case 10
      b = "A"
    Case 11
      b = "B"
    Case 12
      b = "C"
    Case 13
      b = "D"
    Case 14
      b = "E"
    Case 15
      b = "F"
End Select

Select Case c
    Case 10
      c = "A"
    Case 11
      c = "B"
    Case 12
      c = "C"
    Case 13
      c = "D"
    Case 14
      c = "E"
    Case 15
      c = "F"
End Select

Select Case d
    Case 10
      d = "A"
    Case 11
      d = "B"
    Case 12
      d = "C"
    Case 13
      d = "D"
    Case 14
      d = "E"
    Case 15
      d = "F"
End Select

Select Case e
    Case 10
      e = "A"
    Case 11
      e = "B"
    Case 12
      e = "C"
    Case 13
      e = "D"
    Case 14
      e = "E"
    Case 15
      e = "F"
End Select

Select Case f
    Case 10
      f = "A"
    Case 11
      f = "B"
    Case 12
      f = "C"
    Case 13
      f = "D"
    Case 14
      f = "E"
    Case 15
      f = "F"
End Select

Hex = f + e + d + c + b + a

Result.Text = "&H00" & Hex$

'Petit exercice pour les plus callés: Trouvez une façon d'optimiser ce code

Dim EstiDeVariableQuiSertARienSaufARalentirLeProgramme As String
EstiDeVariableQuiSertARienSaufARalentirLeProgramme = "&H00" & Hex$

lbpreview.BackColor = EstiDeVariableQuiSertARienSaufARalentirLeProgramme$

'Fin de l'exercice, mais si ca vous chante, vous pouvez continuer...

End Sub

Private Sub Form_Load()
Label8.Caption = "B" & vbNewLine & "r" & vbNewLine & "i" & vbNewLine & "l" & vbNewLine & "l" & vbNewLine & "a" & vbNewLine & "n" & vbNewLine & "c" & vbNewLine & "e"
End Sub

Private Sub Label4_Click()
RedBox.Text = RedBox.Text + 10
GreenBox.Text = GreenBox.Text + 10
BlueBox.Text = BlueBox.Text + 10
Command1_Click
End Sub

Private Sub Label4_DblClick()
RedBox.Text = RedBox.Text + 10
GreenBox.Text = GreenBox.Text + 10
BlueBox.Text = BlueBox.Text + 10
Command1_Click
End Sub

Private Sub Label5_Click()
RedBox.Text = RedBox.Text + 1
GreenBox.Text = GreenBox.Text + 1
BlueBox.Text = BlueBox.Text + 1
Command1_Click
End Sub

Private Sub Label5_DblClick()
RedBox.Text = RedBox.Text + 1
GreenBox.Text = GreenBox.Text + 1
BlueBox.Text = BlueBox.Text + 1
Command1_Click
End Sub

Private Sub Label6_Click()
RedBox.Text = RedBox.Text - 1
GreenBox.Text = GreenBox.Text - 1
BlueBox.Text = BlueBox.Text - 1
Command1_Click
End Sub

Private Sub Label6_DblClick()
RedBox.Text = RedBox.Text - 1
GreenBox.Text = GreenBox.Text - 1
BlueBox.Text = BlueBox.Text - 1
Command1_Click
End Sub

Private Sub Label7_Click()
RedBox.Text = RedBox.Text - 10
GreenBox.Text = GreenBox.Text - 10
BlueBox.Text = BlueBox.Text - 10
Command1_Click
End Sub

Private Sub Label7_DblClick()
RedBox.Text = RedBox.Text - 10
GreenBox.Text = GreenBox.Text - 10
BlueBox.Text = BlueBox.Text - 10
Command1_Click
End Sub

Private Sub RedBox_KeyPress(KeyAscii As Integer)
If InStr("1234567890" & Chr(8), Chr$(KeyAscii)) = 0 Then 'Ce code a été trouvé sur www.Codes-Sources.com et l'auteur est "Je m'en rappel plus et je le retrouve pas"
KeyAscii = 0
End If
End Sub

Private Sub GreenBox_KeyPress(KeyAscii As Integer)
If InStr("1234567890" & Chr(8), Chr$(KeyAscii)) = 0 Then 'Ce code a été trouvé sur www.Codes-Sources.com et l'auteur est "Je m'en rappel plus et je le retrouve pas"
KeyAscii = 0
End If
End Sub

Private Sub BlueBox_KeyPress(KeyAscii As Integer)
If InStr("1234567890" & Chr(8), Chr$(KeyAscii)) = 0 Then 'Ce code a été trouvé sur www.Codes-Sources.com et l'auteur est "Je m'en rappel plus et je le retrouve pas"
KeyAscii = 0
End If
End Sub

Conclusion :

Le code n'est pas très optimisé et je l'ai fait il y a un bout de temps, mais de toute facon, il est tellement petit, qu'on s'en fou bien si sa prend 0,04 seconde au lieu de 0,01, non?

Télécharger le projet