Soyez le premier à donner votre avis sur cette source.
Vue 6 883 fois - Téléchargée 546 fois
'Pour la source mais à cause des objets voici le source de la feuille 'Pour ceux qui aiment pas les zips ou la compile... 'Mais y a quand même le zip 'Copier ça dans un doc txt vide et renommer le en .frm VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX" Begin VB.Form frmPrinc BorderStyle = 1 'Fixed Single Caption = "Dégradé" ClientHeight = 6765 ClientLeft = 45 ClientTop = 330 ClientWidth = 4710 Icon = "frmPrinc.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 451 ScaleMode = 3 'Pixel ScaleWidth = 314 StartUpPosition = 3 'Windows Default Begin MSComDlg.CommonDialog cmDialPrinc Left = 0 Top = 0 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.OptionButton optSens Caption = "Horizontal" Height = 195 Index = 0 Left = 0 TabIndex = 0 Top = 2400 Value = -1 'True Width = 4575 End Begin VB.OptionButton optSens Caption = "Vertical" Height = 195 Index = 1 Left = 0 TabIndex = 1 Top = 2640 Width = 4575 End Begin VB.Frame framPrinc Height = 3855 Left = 30 TabIndex = 10 Top = 2880 Width = 4635 Begin VB.CommandButton cmdInsert Caption = "Insérer une couleur ici" Height = 495 Left = 2400 TabIndex = 9 Top = 3240 Width = 2055 End Begin VB.CommandButton cmdPlus Caption = "+" Height = 255 Left = 480 TabIndex = 4 Top = 360 Width = 255 End Begin VB.CommandButton cmdMoins Caption = "-" Height = 255 Left = 240 TabIndex = 3 Top = 360 Width = 255 End Begin VB.CommandButton cmdDelete Caption = "Supprimer cette couleur" Height = 495 Left = 120 TabIndex = 8 Top = 3240 Width = 2055 End Begin VB.HScrollBar scrlHrzBlue Height = 255 Left = 240 Max = 255 TabIndex = 7 Top = 2280 Width = 4095 End Begin VB.HScrollBar scrlHrzGreen Height = 255 Left = 240 Max = 255 TabIndex = 6 Top = 1680 Width = 4095 End Begin VB.HScrollBar scrlHrzRed Height = 255 Left = 240 Max = 255 TabIndex = 5 Top = 1080 Width = 4095 End Begin VB.Label lblSample Height = 495 Left = 240 TabIndex = 15 ToolTipText = "Cliquez ici pour choisir une couleur..." Top = 2640 Width = 4095 End Begin VB.Label lblColor Height = 255 Left = 840 TabIndex = 14 Top = 405 Width = 1455 End Begin VB.Label lblBlue Caption = "Bleu" Height = 255 Index = 0 Left = 240 TabIndex = 13 Top = 1980 Width = 1095 End Begin VB.Label lblGreen Caption = "Vert" Height = 255 Left = 240 TabIndex = 12 Top = 1380 Width = 1095 End Begin VB.Label lblRed Caption = "Rouge" Height = 255 Left = 240 TabIndex = 11 Top = 780 Width = 1215 End End Begin VB.PictureBox picPrinc Height = 2295 Left = 0 ScaleHeight = 2235 ScaleWidth = 4635 TabIndex = 2 Top = 0 Width = 4695 End End Attribute VB_Name = "frmPrinc" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Declare Function GradientFill Lib "msimg32" (ByVal Desthdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As Any, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Boolean Private Type TRIVERTEX X As Long Y As Long Red As Integer Green As Integer Blue As Integer Alpha As Integer End Type Private Type Couleur Red As Integer Green As Integer Blue As Integer End Type Private Type GRADIENT_RECT UpperLeft As Long LowerRight As Long End Type Private Const GRADIENT_FILL_RECT_H = 0 Private Const GRADIENT_FILL_RECT_V = 1 Dim couleurActuelle As Integer Dim Couleur() As Couleur Dim couleurs() As TRIVERTEX Private Sub colorisemoitoutca() Dim gRect As GRADIENT_RECT Dim sens As Integer Dim i As Integer Dim nbreTotalDeCouleurs As Integer nbreTotalDeCouleurs = UBound(Couleur) ReDim couleurs(nbreTotalDeCouleurs) As TRIVERTEX gRect.UpperLeft = 0 gRect.LowerRight = 1 If optSens(1).Value = True Then For i = 0 To nbreTotalDeCouleurs - 1 If i >= nbreTotalDeCouleurs - 1 Then Exit For couleurs(i).X = 0 couleurs(i).Y = i * (picPrinc.Height / (nbreTotalDeCouleurs - 1)) couleurs(i).Alpha = 0 couleurs(i).Red = "&H" & Hex(Couleur(i).Red / 16 * 256 * 16) couleurs(i).Green = "&H" & Hex(Couleur(i).Green / 16 * 256 * 16) couleurs(i).Blue = "&H" & Hex(Couleur(i).Blue / 16 * 256 * 16) couleurs(i + 1).X = picPrinc.Width couleurs(i + 1).Y = (i + 1) * (picPrinc.Height / (nbreTotalDeCouleurs - 1)) couleurs(i + 1).Alpha = 0 couleurs(i + 1).Red = "&H" & Hex(Couleur(i + 1).Red / 16 * 256 * 16) couleurs(i + 1).Green = "&H" & Hex(Couleur(i + 1).Green / 16 * 256 * 16) couleurs(i + 1).Blue = "&H" & Hex(Couleur(i + 1).Blue / 16 * 256 * 16) If GradientFill(picPrinc.hDC, couleurs(i), 2, gRect, 1, GRADIENT_FILL_RECT_V) = False Then MsgBox "Une erreur s'est produite...", vbCritical, "Oh..." Next i Else For i = 0 To nbreTotalDeCouleurs - 1 If i >= nbreTotalDeCouleurs - 1 Then Exit For couleurs(i).X = i * (picPrinc.Width / (nbreTotalDeCouleurs - 1)) couleurs(i).Y = 0 couleurs(i).Alpha = 0 couleurs(i).Red = "&H" & Hex(Couleur(i).Red / 16 * 256 * 16) couleurs(i).Green = "&H" & Hex(Couleur(i).Green / 16 * 256 * 16) couleurs(i).Blue = "&H" & Hex(Couleur(i).Blue / 16 * 256 * 16) couleurs(i + 1).X = (i + 1) * (picPrinc.Width / (nbreTotalDeCouleurs - 1)) couleurs(i + 1).Y = picPrinc.Height couleurs(i + 1).Alpha = 0 couleurs(i + 1).Red = "&H" & Hex(Couleur(i + 1).Red / 16 * 256 * 16) couleurs(i + 1).Green = "&H" & Hex(Couleur(i + 1).Green / 16 * 256 * 16) couleurs(i + 1).Blue = "&H" & Hex(Couleur(i + 1).Blue / 16 * 256 * 16) If GradientFill(picPrinc.hDC, couleurs(i), 2, gRect, 1, GRADIENT_FILL_RECT_H) = False Then MsgBox "Une erreur s'est produite...", vbCritical, "Oh..." Next i End If End Sub Private Sub cmdDelete_Click() Dim i As Integer If UBound(Couleur) = 2 Then MsgBox "Vous ne pouvez pas supprimer une couleur lorsque seules deux couleurs sont définies.", vbInformation, "Erreur...": Exit Sub For i = couleurActuelle To UBound(Couleur) - 1 Couleur(i).Red = Couleur(i + 1).Red Couleur(i).Green = Couleur(i + 1).Green Couleur(i).Blue = Couleur(i + 1).Blue Next i ReDim Preserve Couleur(UBound(Couleur) - 1) If couleurActuelle = UBound(Couleur) Then couleurActuelle = couleurActuelle - 1 lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur) initScrl End Sub Private Sub cmdInsert_Click() Dim i As Integer ReDim Preserve Couleur(UBound(Couleur) + 1) For i = UBound(Couleur) To couleurActuelle + 1 Step -1 Couleur(i).Red = Couleur(i - 1).Red Couleur(i).Green = Couleur(i - 1).Green Couleur(i).Blue = Couleur(i - 1).Blue Next i Couleur(couleurActuelle).Red = 0 Couleur(couleurActuelle).Green = 0 Couleur(couleurActuelle).Blue = 0 lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur) initScrl End Sub Private Sub cmdMoins_Click() couleurActuelle = couleurActuelle - 1 If couleurActuelle < 0 Then couleurActuelle = 0 lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur) initScrl End Sub Private Sub cmdPlus_Click() couleurActuelle = couleurActuelle + 1 If couleurActuelle > UBound(Couleur) - 1 Then ReDim Preserve Couleur(UBound(Couleur) + 1) Couleur(UBound(Couleur)).Red = 0 Couleur(UBound(Couleur)).Green = 0 Couleur(UBound(Couleur)).Blue = 0 lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur) Else lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur) End If initScrl End Sub Private Sub initScrl() scrlHrzRed.Value = Couleur(couleurActuelle).Red scrlHrzGreen = Couleur(couleurActuelle).Green scrlHrzBlue = Couleur(couleurActuelle).Blue lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub Private Sub Form_Load() ReDim Couleur(2) As Couleur Couleur(0).Red = 0 Couleur(0).Green = 0 Couleur(0).Blue = 0 Couleur(1).Red = 255 Couleur(1).Green = 255 Couleur(1).Blue = 255 couleurActuelle = 0 lblColor.Caption = "Couleur " & couleurActuelle + 1 & "/" & UBound(Couleur) initScrl End Sub Private Sub lblSample_Click() Dim laCouleur As Long cmDialPrinc.ShowColor laCouleur = cmDialPrinc.Color lblSample.BackColor = laCouleur scrlHrzRed.Value = Int(laCouleur And &HFF) scrlHrzGreen.Value = Int((laCouleur And &H100FF00) / &H100) scrlHrzBlue.Value = Int((laCouleur And &HFF0000) / &H10000) End Sub Private Sub optSens_Click(index As Integer) colorisemoitoutca End Sub Private Sub picPrinc_Paint() colorisemoitoutca End Sub Private Sub scrlHrzBlue_Change() Couleur(couleurActuelle).Blue = scrlHrzBlue.Value lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub Private Sub scrlHrzBlue_Scroll() Couleur(couleurActuelle).Blue = scrlHrzBlue.Value lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub Private Sub scrlHrzGreen_Change() Couleur(couleurActuelle).Green = scrlHrzGreen.Value lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub Private Sub scrlHrzGreen_Scroll() Couleur(couleurActuelle).Green = scrlHrzGreen.Value lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub Private Sub scrlHrzRed_Change() Couleur(couleurActuelle).Red = scrlHrzRed.Value lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub Private Sub scrlHrzRed_Scroll() Couleur(couleurActuelle).Red = scrlHrzRed.Value lblSample.BackColor = RGB(scrlHrzRed.Value, scrlHrzGreen.Value, scrlHrzBlue.Value) colorisemoitoutca End Sub
29 juin 2002 à 19:52
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.