ProgressBar能不能改变颜色

[caoliyong]

进度条控健默认的颜色是蓝色，能不能改变进度条的颜色，在不同的进度点显示不同的颜色。就是程序运行时当进度条到某一个位置时用不同的颜色显示。各位大侠帮忙阿

[minajo21]

VB自带的不可以，去找一个三方的吧，或者自己写一个，我有一段代码，可以给你。

[caoliyong]

非常感谢您的指导，那就帮人帮到底赐我那段代码吧。感激不尽。
我的 e-mail 是 [e-mail]

[minajo21]

发过去了，请收

[caoliyong]

我还没有收到阿

[lihonggen0]

添加一个用户控件ProgBar1




Public Enum BorderStyles ' BorderStyles for the control
bdNone
bdFixedSingle
End Enum

Public Event Click() ' yup I coded a click event

'********************************
' Here are the private variables
' that contain the properties
'********************************
Private mBackColor As Long
Private mBarColor As Long
Private mVertical As Boolean
Private mMin As Long
Private mMax As Long
Private mValue As Long
Private mBorderStyle As Long

'********************************
' All properties are read/write
'********************************
' If you get an error here, go to project references, and be
' sure that OLE Automation is selected. If you don't want
' to do that, change the OLE_COLOR to Long. It will work,
' but you won't get the pretty color picker in the properties
' window.
Public Property Let BackColor(ByVal NewColor As OLE_COLOR)
mBackColor = NewColor
UserControl.BackColor = NewColor
UserControl_Paint
PropertyChanged "BackColor"
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = mBackColor
End Property

Public Property Let BarColor(ByVal NewColor As OLE_COLOR)
mBarColor = NewColor
UserControl_Paint
PropertyChanged "BarColor"
End Property
Public Property Get BarColor() As OLE_COLOR
BarColor = mBarColor
End Property

Public Property Let Vertical(ByVal val As Boolean)
mVertical = val
UserControl_Resize
PropertyChanged "Vertical"
End Property
Public Property Get Vertical() As Boolean
Vertical = mVertical
End Property

Public Property Let Max(ByVal val As Long)
If val < 1 Then val = 1
If val <= mMin Then val = mMin + 1
mMax = val
If Value > mMax Then Value = mMax
UserControl_Resize
PropertyChanged "Max"
End Property
Public Property Get Max() As Long
Max = mMax
End Property

Public Property Let Min(ByVal val As Long)
If val >= mMax Then val = Max - 1
If val < 0 Then val = 0
mMin = val
If Value < mMin Then Value = mMin
UserControl_Resize
PropertyChanged "Min"
End Property
Public Property Get Min() As Long
Min = mMin
End Property

Public Property Let Value(ByVal val As Long)
If val > mMax Then val = Max
If val < mMin Then val = mMin
mValue = val
UserControl_Paint
PropertyChanged "Value"
End Property
Public Property Get Value() As Long
Value = mValue
End Property

Public Property Let BorderStyle(ByVal val As BorderStyles)
If val < 0 Then val = 0
If val > 1 Then val = 1
mBorderStyle = val
UserControl.BorderStyle = mBorderStyle
UserControl_Resize
PropertyChanged "BorderStyle"
End Property
Public Property Get BorderStyle() As BorderStyles
BorderStyle = mBorderStyle
End Property

'********************************
' Set up the defaults
'********************************
Private Sub UserControl_InitProperties()
BackColor = vbButtonFace
BarColor = vbHighlight
Vertical = False
Max = 100
Min = 0
Value = 50
BorderStyle = 1
End Sub

'********************************
' Reload design-time settings
'********************************
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
On Error Resume Next
BackColor = PropBag.ReadProperty("BackColor", vbButtonFace)
BarColor = PropBag.ReadProperty("BarColor", vbHighlight)
Vertical = PropBag.ReadProperty("Vertical", False)
Max = PropBag.ReadProperty("Max", 100)
Min = PropBag.ReadProperty("Min", 0)
Value = PropBag.ReadProperty("Value", 50)
BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
End Sub

'********************************
' Save design-time settings
'********************************
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "BackColor", BackColor, vbButtonFace
PropBag.WriteProperty "BarColor", BarColor, vbHighlight
PropBag.WriteProperty "Vertical", Vertical, False
PropBag.WriteProperty "Max", Max, 100
PropBag.WriteProperty "Min", Min, 0
PropBag.WriteProperty "Value", Value, 50
PropBag.WriteProperty "BorderStyle", BorderStyle, 1
End Sub

'********************************
' The bulk of the work is this small little
' sub. It does the drawing.
'********************************
Private Sub UserControl_Paint()
Dim w As Long ' I'm storing some properties
Dim h As Long ' in variables to improve performance
Dim v As Long
v = mValue - mMin
w = UserControl.ScaleWidth
h = UserControl.ScaleHeight
If mVertical Then ' is this a vertical control?
UserControl.Line (0, 0)-(w, h - v), mBackColor, BF ' draw the background color
If v > 0 Then ' only draw the bar if there is one to draw
UserControl.Line (0, h)-(w, h - v), mBarColor, BF ' draw the bar
End If
Else
UserControl.Line (v, 0)-(w, h), mBackColor, BF ' this is the same code as above
If v > 0 Then
UserControl.Line (0, 0)-(v, h), mBarColor, BF ' but for horizontal controls
End If
End If
End Sub

'********************************
' There is a little more work to be done
' if the control is resized
'********************************
Private Sub UserControl_Resize()
On Error Resume Next ' just in case
UserControl.ScaleWidth = mMax - mMin
UserControl.ScaleHeight = mMax - mMin
UserControl_Paint ' repaint the control
End Sub

'********************************
' This is really simple. Catch the click event
' in the usercontrol, and pass it on to the
' container form.
'********************************
Private Sub UserControl_Click()
RaiseEvent Click
End Sub

[lihonggen0]

Form1代码


Option Explicit
Private Running As Boolean

Private Sub cmdToggle_Click()

Running = Not Running

If Running Then
cmdToggle.Caption = "Stop"
Else
cmdToggle.Caption = "Start"
End If

Run

End Sub
Private Sub Run()

Dim x As Long
Dim y As Integer
Dim z As Long

Do While Running
For x = 0 To 100
For y = 0 To 4
ProgBar1(y).Value = x
Next y
For z = 1 To 100
DoEvents
If Not Running Then Exit For
Next z
If Not Running Then Exit For
Next x
For x = 100 To 0 Step -1
For y = 0 To 4
ProgBar1(y).Value = x
Next y
For z = 1 To 100
DoEvents
If Not Running Then Exit For
Next z
If Not Running Then Exit For
Next x
Loop
Clear
End Sub

Private Sub Clear()
Dim y As Integer
For y = 0 To 4
ProgBar1(y).Value = 0
Next y
End Sub

'Private Sub Command2_Click()
' Dim I As Integer
' For I = 1 To 20
' Load Text1(I)
' Text1(I).Visible = True
' Text1(I).Left = 100
' Text1(I).Top = I * 400
' Text1(I).Text = "第" & I & "个"
' Next
'End Sub

Private Sub Form_Load()
Clear
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Running = True Then Cancel = 1
End Sub

[minajo21]

又发了一遍

[lilaclone]

到www.21code.com去下载啊，很多的