Progressbar style xp (modifiée + d'option)

Télécharger le projet
Commenter

Description

Et bien n'ayant pas windows XP g u l'i d 2 faire une ProgressBar dans le même genre que le XP.
2 + on pe changer la couleur sans passer par du code (comme ds la progressBar Classic)
A oui c 1 activx et la variable qui renvoi la progression est : Value
Mode dégrader normal ...
Bon Prog
SupraDolph

Source / Exemple : 


'Declaration De L'API GetSysColor :
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'Declaration Des Variables :
Dim Ctrl_value As Long
Dim Ctrl_Back_Couleur As OLE_COLOR      'Couleur Arrière Plan
Dim Ctrl_Int_Color As OLE_COLOR         'Couleur De La ProgB
Dim Ctrl_Font_Color As OLE_COLOR        'Couleur De La Police
Dim Ctrl_Line_Color As OLE_COLOR        'Couleur Du Contour
Dim Ctrl_Line As Boolean                'Affiche Ou Pas Le Contour
Dim Ctrl_FontVisible As Boolean         'Affiche Ou Pas La Police
Dim Ctrl_FixedSingle As Boolean         'Defini Le Borderstyle De Le ProgB
Dim Ctrl_ModeXP As Boolean              'Selectionne Le Mode
Dim Ctrl_Degrader As Boolean            'Selectionne Le Dégrader

Private Sub UserControl_Initialize()
UserControl_Resize
End Sub

Private Sub UserControl_Resize()
P1.Move 0, 0, UserControl.Width, UserControl.Height
Changement
End Sub

Private Sub UserControl_Show()
Changement
End Sub

Private Sub UserControl_InitProperties()
Ctrl_value = 0
Ctrl_Back_Couleur = &H8000000F
Ctrl_Int_Color = &H8000000D
Ctrl_Line_Color = &H8000000D
Ctrl_Font_Color = vbBlack
Ctrl_FontVisible = True
Ctrl_FixedSingle = True
Ctrl_Line = False
Ctrl_ModeXP = True
Ctrl_Degrader = True
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Ctrl_value = PropBag.ReadProperty("value", "0")
Ctrl_Back_Couleur = PropBag.ReadProperty("CtrlBackColor", &H8000000F)
Ctrl_Int_Color = PropBag.ReadProperty("CtrlIntColor", &H8000000D)
Set P1.Font = PropBag.ReadProperty("Font", Ambient.Font)
Ctrl_FontVisible = PropBag.ReadProperty("FontVisible", True)
Ctrl_Font_Color = PropBag.ReadProperty("FontColor", vbBlack)
Ctrl_Line_Color = PropBag.ReadProperty("LineColor", &H8000000D)
Ctrl_FixedSingle = PropBag.ReadProperty("FixedSingle", True)
Ctrl_Line = PropBag.ReadProperty("Line", False)
Ctrl_ModeXP = PropBag.ReadProperty("ModeXP", True)
Ctrl_Degrader = PropBag.ReadProperty("Degrader", True)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("value", Ctrl_value, "0")
Call PropBag.WriteProperty("CtrlBackColor", Ctrl_Back_Couleur, &H8000000F)
Call PropBag.WriteProperty("CtrlIntColor", Ctrl_Int_Color, &H8000000D)
Call PropBag.WriteProperty("Font", P1.Font, Ambient.Font)
Call PropBag.WriteProperty("FontVisible", Ctrl_FontVisible, True)
Call PropBag.WriteProperty("FontColor", Ctrl_Font_Color, vbBlack)
Call PropBag.WriteProperty("LineColor", Ctrl_Line_Color, &H8000000D)
Call PropBag.WriteProperty("FixedSingle", Ctrl_FixedSingle, True)
Call PropBag.WriteProperty("Line", Ctrl_Line, False)
Call PropBag.WriteProperty("ModeXP", Ctrl_ModeXP, True)
Call PropBag.WriteProperty("Degrader", Ctrl_Degrader, True)
End Sub
'Effectue Toutes Les Opération Graphiques.
Private Sub Changement()
P1.ForeColor = Ctrl_Font_Color
P1.BackColor = Ctrl_Back_Couleur
If Ctrl_FixedSingle = True Then P1.BorderStyle = 1 Else P1.BorderStyle = 0

CouleurRGB Ctrl_Int_Color, mrd, mvd, mbd
If Ctrl_value > 100 Then Ctrl_value = 100
Dim var1, var2, var3, var4, nb1, nb2
var1 = P1.ScaleHeight / 2
var3 = P1.ScaleHeight / 1.5
var4 = Ctrl_value / 100 * P1.ScaleWidth
nb2 = Ctrl_value / 100 * (P1.ScaleWidth / (var3 + 30) + 1)
P1.Cls
    Calcul_Value
If Ctrl_ModeXP = True Then
    For nb1 = 0 To nb2 - 1
    var2 = (var3 + 30) * nb1
    For i = 0 To var1
        If Ctrl_Degrader = True Then
            P1.Line (var2, i)-(var2 + var3, i), RGB(255 - (i / var1 * (255 - mrd)), 255 - (i / var1 * (255 - mvd)), 255 - (i / var1 * (255 - mbd)))
            P1.Line (var2, 2 * var1 - i)-(var2 + var3, 2 * var1 - i), RGB(255 - (i / var1 * (255 - mrd)), 255 - (i / var1 * (255 - mvd)), 255 - (i / var1 * (255 - mbd)))
        Else
            P1.Line (var2, 2 * i)-(var2 + var3, 2 * i), Ctrl_Int_Color
        End If
    Next i
    Calcul_Value
    Next nb1
Else
    For i = 0 To var4
        If Ctrl_Degrader = True Then
            P1.Line (i, 0)-(i, P1.ScaleHeight), RGB(255 - i / P1.ScaleWidth * (255 - mrd), 255 - i / P1.ScaleWidth * (255 - mvd), 255 - i / P1.ScaleWidth * (255 - mbd))
        Else
            P1.Line (i, 0)-(i, P1.ScaleHeight), Ctrl_Int_Color
        End If
    Next i
    Calcul_Value
End If
If Ctrl_Line = True Then
    P1.DrawWidth = 2
    P1.Line (0, P1.ScaleHeight)-(0, 0), Ctrl_Line_Color
    P1.Line (0, 0)-(P1.ScaleWidth, 0), Ctrl_Line_Color
    P1.Line (P1.ScaleWidth, 0)-(P1.ScaleWidth, P1.ScaleHeight), Ctrl_Line_Color
    P1.Line (P1.ScaleWidth, P1.ScaleHeight)-(0, P1.ScaleHeight), Ctrl_Line_Color
    P1.DrawWidth = 1
End If
End Sub

Public Property Get Value() As String
Value = Ctrl_value
End Property

Public Property Let Value(ByVal New_CtrlValue As String)
On Error GoTo Err
Ctrl_value = New_CtrlValue
Changement
PropertyChanged "CtrlValue"
Exit Property
Err:
If New_CtrlValue > 0 Then Ctrl_value = 100 Else Ctrl_value = 0
Changement
PropertyChanged "CtrlValue"
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = Ctrl_Back_Couleur
End Property

Public Property Let BackColor(ByVal New_CtrlBackColor As OLE_COLOR)
Ctrl_Back_Couleur = New_CtrlBackColor
Changement
PropertyChanged "CtrlBackColor"
End Property

Public Property Get IntColor() As OLE_COLOR
IntColor = Ctrl_Int_Color
End Property

Public Property Let IntColor(ByVal New_CtrlIntColor As OLE_COLOR)
Ctrl_Int_Color = New_CtrlIntColor
Changement
PropertyChanged "CtrlIntColor"
End Property

Public Property Get Font() As Font
Set Font = P1.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
Set P1.Font = New_Font
P1.FontName = Font.Name
P1.FontSize = Font.Size
P1.FontBold = Font.Bold
P1.FontItalic = Font.Italic
P1.FontStrikethru = Font.Strikethrough
P1.FontUnderline = Font.Underline
Changement
PropertyChanged "Font"
End Property

Public Property Get FontVisible() As Boolean
FontVisible = Ctrl_FontVisible
End Property

Public Property Let FontVisible(ByVal New_FontVisible As Boolean)
Ctrl_FontVisible = New_FontVisible
Changement
PropertyChanged "FontVisible"
End Property

Public Property Get FontColor() As OLE_COLOR
FontColor = Ctrl_Font_Color
End Property

Public Property Let FontColor(ByVal New_Font_Color As OLE_COLOR)
Ctrl_Font_Color = New_Font_Color
Changement
PropertyChanged "FontColor"
End Property

Public Property Get FixedSingle() As Boolean
FixedSingle = Ctrl_FixedSingle
End Property

Public Property Let FixedSingle(ByVal New_FixedSingle As Boolean)
Ctrl_FixedSingle = New_FixedSingle
Changement
PropertyChanged "FixedSingle"
End Property

Public Property Get Line() As Boolean
Line = Ctrl_Line
End Property

Public Property Let Line(ByVal New_Line As Boolean)
Ctrl_Line = New_Line
Changement
PropertyChanged "Line"
End Property

Public Property Get LineColor() As OLE_COLOR
LineColor = Ctrl_Line_Color
End Property

Public Property Let LineColor(ByVal New_LineColor As OLE_COLOR)
Ctrl_Line_Color = New_LineColor
Changement
PropertyChanged "LineColor"
End Property

Public Property Get ModeXP() As Boolean
ModeXP = Ctrl_ModeXP
End Property

Public Property Let ModeXP(ByVal New_ModeXP As Boolean)
Ctrl_ModeXP = New_ModeXP
Changement
PropertyChanged "ModeXP"
End Property

Public Property Get Degrader() As Boolean
Degrader = Ctrl_Degrader
End Property

Public Property Let Degrader(ByVal New_Degrader As Boolean)
Ctrl_Degrader = New_Degrader
Changement
PropertyChanged "Degrader"
End Property
'Transforme De L'Hexadecimal En RGB :
Private Sub CouleurRGB(Couleur, mrd, mvd, mbd)
Couleur = OleColorToRGB(Couleur)
'Valeur rouge
mrd = (((Couleur And 255) * 50) + ((Couleur And 255) * 50)) \ 100
'Valeur vert
mvd = ((((Couleur \ 256) And 255) * 50) + (((Couleur \ 256) And 255) * 50)) \ 100
'Valeur bleu
mbd = ((((Couleur \ 65536) And 255) * 50) + (((Couleur \ 65536) And 255) * 50)) \ 100
End Sub

Private Function OleColorToRGB(ByVal Couleur As OLE_COLOR) As Long
If Couleur And &H80000000 Then
OleColorToRGB = GetSysColor(Couleur Xor &H80000000)
Else
OleColorToRGB = Couleur
End If
End Function
'Affiche Le Pourcentage Si On Le Demande :
Private Function Calcul_Value()
    If FontVisible = True Then
    P1.CurrentX = (P1.ScaleWidth - P1.TextWidth(Ctrl_value & "%")) / 2
    P1.CurrentY = (P1.ScaleHeight - P1.TextHeight(Ctrl_value & "%")) / 2
    P1.Print Ctrl_value & "%"
    End If
End Function

Conclusion :


Telecharger le il est super !
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (SupraDolph)