blocks|key|499219|text|我经常做这样的事情|type|unstyled|depth|inlineStyleRanges|entityRanges|data|499220|Dim+n+As+Long,+db+As+DAO.Database,+rs+As+DAO.Recordset

'Show+the+hour+glass
DoCmd.Hourglass+True

Set+db+=+CurrentDb
Set+rs+=+db.OpenRecordset("SELECT+...")

rs.MoveLast+'Needed+to+get+the+accurate+number+of+records

'Show+the+progress+bar
SysCmd+acSysCmdInitMeter,+"working...",+rs.RecordCount

rs.MoveFirst
Do+Until+rs.EOF
++++'Do+the+work+here+...

++++'Update+the+progress+bar
++++n+=+n+%2B+1
++++SysCmd+acSysCmdUpdateMeter,+n

++++'Keep+the+application+responding+(optional)
++++DoEvents

++++rs.MoveNext
Loop
rs.Close:+Set+rs+=+Nothing
db.Close:+Set+db+=+Nothing

'Remove+the+progress+bar
SysCmd+acSysCmdRemoveMeter

'Show+the+normal+cursor+again
DoCmd.Hourglass+False|code-block|syntax|javascript|499221|注意:当然，您必须以编程方式完成工作，这样才能正常工作。您不能在Access中查看代码或类似代码中的运行查询。也许你可以将慢查询的工作拆分成更小的部分，以便有机会更新进度条。但是您可以始终显示沙漏；这会告诉用户发生了什么事情。|499222|entityMap^0|0|0|0^^$0|@$1|2|3|4|5|6|7|K|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|L|8|@]|9|@]|A|$E|F]]|$1|G|3|H|5|6|7|M|8|@]|9|@]|A|$]]|$1|I|3|-4|5|6|7|N|8|@]|9|@]|A|$]]]|J|$]]

I often do something like this

<pre class="lang-vb prettyprint-override"><code>Dim n As Long, db As DAO.Database, rs As DAO.Recordset

'Show the hour glass
DoCmd.Hourglass True

Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ...")

rs.MoveLast 'Needed to get the accurate number of records

'Show the progress bar
SysCmd acSysCmdInitMeter, "working...", rs.RecordCount

rs.MoveFirst
Do Until rs.EOF
 'Do the work here ...

 'Update the progress bar
 n = n + 1
 SysCmd acSysCmdUpdateMeter, n

 'Keep the application responding (optional)
 DoEvents

 rs.MoveNext
Loop
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing

'Remove the progress bar
SysCmd acSysCmdRemoveMeter

'Show the normal cursor again
DoCmd.Hourglass False
</code></pre>

Note: Of course you must do the work programmatically for this to work. You cannot watch a runnging query in code or the like in Access. Possibly you could split the work of your slow query into smaller pieces, in order to get the chance of updating a progress bar. But you can always show the hour glass; this tells the user that something is happening.

blocks|key|499265|text|由于可用控件的问题，我使用两个矩形创建了一个自制的进度条。一个边框和实心条，可以随着进度调整大小。边框前面的进度矩形。要使用|type|unstyled|depth|inlineStyleRanges|entityRanges|data|499266|If+pbar+Is+Nothing+Then
++++Set+pbar+=+New+pBar_sub
++++pbar.init+Me.Progressbar_border,+Me.ProgressBar_Bar
End+If
pbar.value+=+0
pbar.show
pbar.max+=+145+'+number+of+interations
...
...
Do+While+Not+recset.EOF
++++count+=+count+%2B+1
++++pbar.value+=+count
'+++get+next+
++++recset.MoveNext
Loop|code-block|syntax|javascript|499267|用户可以将状态行与进度条相关联，该进度条宣布正在处理的元素。比如:+123。地区SomeWhere，销售代理WhomEver|499268|========进度条替换pBar_sub+==============|499269|Option+Compare+Database
Option+Explicit

Dim+position++++As+Long
Dim+maximum+++++As+Long
Dim+increment+++As+Single
Dim+border++++++As+Object
Dim+bar+++++++++As+Object

Sub+init(rect+As+Object,+b+As+Object)
++++Set+border+=+rect
++++Set+bar+=+b
++++bar.width+=+0
++++hide
End+Sub
Sub+hide()
++++bar.visible+=+False
++++border.visible+=+False
End+Sub
Sub+show()
++++bar.visible+=+True
++++border.visible+=+True
End+Sub
Property+Get+Max()+As+Integer
++++Max+=+maximum
End+Property
Property+Let+Max(val+As+Integer)
++++maximum+=+val
++++increment+=+border.width+/+val
End+Property
Property+Get+value()+As+Integer
++++value+=+position
End+Property
Property+Let+value(val+As+Integer)
++++position+=+val
++++bar.width+=+increment+*+value
End+Property|499270|entityMap^0|0|0|0|0|0^^$0|@$1|2|3|4|5|6|7|O|8|@]|9|@]|A|$]]|$1|B|3|C|5|D|7|P|8|@]|9|@]|A|$E|F]]|$1|G|3|H|5|6|7|Q|8|@]|9|@]|A|$]]|$1|I|3|J|5|6|7|R|8|@]|9|@]|A|$]]|$1|K|3|L|5|D|7|S|8|@]|9|@]|A|$E|F]]|$1|M|3|-4|5|6|7|T|8|@]|9|@]|A|$]]]|N|$]]

Due to problems with available control I created a home grown progress bar using 2 rectangles. A border, and solid bar that is resized as things progress. The progress rectangle in in front of the border. To use

<pre><code>If pbar Is Nothing Then
 Set pbar = New pBar_sub
 pbar.init Me.Progressbar_border, Me.ProgressBar_Bar
End If
pbar.value = 0
pbar.show
pbar.max = 145 ' number of interations
...
...
Do While Not recset.EOF
 count = count + 1
 pbar.value = count
' get next 
 recset.MoveNext
Loop
</code></pre>

One can associate a status line with the progress bar that announces what element is being processed. Like:
 123. District SomeWhere, sales agent WhomEver

======== Progress Bar substitute pBar_sub ==============

<pre><code>Option Compare Database
Option Explicit

Dim position As Long
Dim maximum As Long
Dim increment As Single
Dim border As Object
Dim bar As Object

Sub init(rect As Object, b As Object)
 Set border = rect
 Set bar = b
 bar.width = 0
 hide
End Sub
Sub hide()
 bar.visible = False
 border.visible = False
End Sub
Sub show()
 bar.visible = True
 border.visible = True
End Sub
Property Get Max() As Integer
 Max = maximum
End Property
Property Let Max(val As Integer)
 maximum = val
 increment = border.width / val
End Property
Property Get value() As Integer
 value = position
End Property
Property Let value(val As Integer)
 position = val
 bar.width = increment * value
End Property
</code></pre>

blocks|key|282571|text|这不是一种专业的方法，但如果你喜欢的话也可以应用。如果你正在使用一个表单，你可以在一个方便的地方放置一个小的文本框，默认的颜色是绿色。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|282572|假设文本框名称为TxtProcessing，|offset|length|style|CODE|282573|属性可以如下所示。|282574|Name+:+TxtProcessing
Visible+:+Yes
Back+color+:+Green
Locked:+Yes
Enter+Key+Behavior+:+Default|code-block|syntax|javascript|282575|1)在你的VB脚本中，你可以放入红色的Me.TxtProcessing.BackColor+=+vbRed，它表示任务正在进行中。|282576|2)你可以编写你所有的脚本|282577|3)最后你可以把Me.TxtProcessing.BackColor+=+vbGreen|282578|Me.TxtProcessing.BackColor+=+vbRed
Me.TxtProcessing.SetFocus
Me.Refresh

Your+Code+here.....

Me.TxtProcessing.BackColor+=+vbGreen
Me.TxtProcessing.SetFocus|282579|:-)很有趣，但目的已经实现了。|282580|entityMap^0|0|8|D|0|0|0|J|Y|0|0|8|10|0|0|0^^$0|@$1|2|3|4|5|6|7|10|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|11|8|@$D|12|E|13|F|G]]|9|@]|A|$]]|$1|H|3|I|5|6|7|14|8|@]|9|@]|A|$]]|$1|J|3|K|5|L|7|15|8|@]|9|@]|A|$M|N]]|$1|O|3|P|5|6|7|16|8|@$D|17|E|18|F|G]]|9|@]|A|$]]|$1|Q|3|R|5|6|7|19|8|@]|9|@]|A|$]]|$1|S|3|T|5|6|7|1A|8|@$D|1B|E|1C|F|G]]|9|@]|A|$]]|$1|U|3|V|5|L|7|1D|8|@]|9|@]|A|$M|N]]|$1|W|3|X|5|6|7|1E|8|@]|9|@]|A|$]]|$1|Y|3|-4|5|6|7|1F|8|@]|9|@]|A|$]]]|Z|$]]

This is not a professional way but can be applied if you like it.
If you are using a form
You can have a small text box in a convenient place default with Green color.

Supposing the text box Name is <code>TxtProcessing</code>, Properties can be as below.

<pre><code>Name : TxtProcessing
Visible : Yes
Back color : Green
Locked: Yes
Enter Key Behavior : Default
</code></pre>

1) In your VB script you can put <code>Me.TxtProcessing.BackColor = vbRed</code> which will be in Red and it signifies the task in Process. 
2) you can write all your set of scripts 
3) At last you can put <code>Me.TxtProcessing.BackColor = vbGreen</code>

<pre><code>Me.TxtProcessing.BackColor = vbRed
Me.TxtProcessing.SetFocus
Me.Refresh

Your Code here.....

Me.TxtProcessing.BackColor = vbGreen
Me.TxtProcessing.SetFocus
</code></pre>

:-) Funny but purpose is achieved.

blocks|key|282628|text|首先在MS+Access窗体中拖动进度条控件，然后更改进度条的名称，如aa。|type|unstyled|depth|inlineStyleRanges|offset|length|style|CODE|entityRanges|data|282629|然后转到form+property，在代码中的timer+:write上|282630|me.aa.value=me.aa.value%2B20|code-block|syntax|javascript|282631|时间间隔300根据您的选择。运行窗体，您将看到渐进栏|282632|entityMap^0|Z|2|0|4|D|T|6|0|0|0^^$0|@$1|2|3|4|5|6|7|Q|8|@$9|R|A|S|B|C]]|D|@]|E|$]]|$1|F|3|G|5|6|7|T|8|@$9|U|A|V|B|C]|$9|W|A|X|B|C]]|D|@]|E|$]]|$1|H|3|I|5|J|7|Y|8|@]|D|@]|E|$K|L]]|$1|M|3|N|5|6|7|Z|8|@]|D|@]|E|$]]|$1|O|3|-4|5|6|7|10|8|@]|D|@]|E|$]]]|P|$]]

First drag progressive bar control in MS Access form, then change the name of progressive bar like <code>aa</code>. 

Then go to <code>form property</code>, on timer <code>:write</code> in code 

<pre><code>me.aa.value=me.aa.value+20
</code></pre>

time interval 300 as per your choice. Run the form you will see the progressive bar

blocks|key|499490|text|如果其他人觉得这很有用，下面是我为此目的编写的一个类。我一直在我的Access开发项目中使用它。只需将其放入名为clsLblProg的类模块中，并按如下方式使用它：|type|unstyled|depth|inlineStyleRanges|offset|length|style|CODE|entityRanges|data|499491|​|499492|📷|atomic|499493|499494|这会产生一个漂亮的小进度条：|499495|499496|499497|499498|在您的表单上，您只需要三个标签。将背面标签设置为所需的大小，并隐藏其他两个标签。剩下的工作由类来完成。|499499|499500|499501|499502|下面是clsLblProg的代码|499503|Option+Compare+Database
Option+Explicit

'+By+Adam+Waller
'+Last+Modified:++12/16/05

'Private+Const+sngOffset+As+Single+=+1.5++++'+For+Excel
Private+Const+sngOffset+As+Single+=+15++++++'+For+Access

Private+mdblMax+As+Double+++'+max+value+of+progress+bar
Private+mdblVal+As+Double+++'+current+value+of+progress+bar
Private+mdblFullWidth+As+Double+'+width+of+front+label+at+100%25
Private+mdblIncSize+As+Double
Private+mblnHideCap+As+Boolean++'+display+percent+complete
Private+mobjParent+As+Object++++'+parent+of+back+label
Private+mlblBack+As+Access.Label+++++'+existing+label+for+back
Private+mlblFront+As+Access.Label+++'+label+created+for+front
Private+mlblCaption+As+Access.Label+'+progress+bar+caption
Private+mdteLastUpdate+As+Date++++++'+Time+last+updated
Private+mblnNotSmooth+As+Boolean++++'+Display+smooth+bar+by+doevents+after+every+update.

'+This+class+displays+a+progress+bar+created
'+from+3+labels.
'+to+use,+just+add+a+label+to+your+form,
'+and+use+this+back+label+to+position+the
'+progress+bar.

Public+Sub+Initialize(BackLabel+As+Access.Label,+FrontLabel+As+Access.Label,+CaptionLabel+As+Access.Label)

++++On+Error+GoTo+0++++'+Debug+Mode


++++Dim+objParent+As+Object+'+could+be+a+form+or+tab+control
++++Dim+frm+As+Form

++++Set+mobjParent+=+BackLabel.Parent
++++'+set+private+variables
++++Set+mlblBack+=+BackLabel
++++Set+mlblFront+=+FrontLabel
++++Set+mlblCaption+=+CaptionLabel

++++'+set+properties+for+back+label
++++With+mlblBack
++++++++.Visible+=+True
++++++++.SpecialEffect+=+2++'+sunken.+Seems+to+lose+when+not+visible.
++++End+With

++++'+set+properties+for+front+label
++++With+mlblFront
++++++++mdblFullWidth+=+mlblBack.Width+-+(sngOffset+*+2)
++++++++.Left+=+mlblBack.Left+%2B+sngOffset
++++++++.Top+=+mlblBack.Top+%2B+sngOffset
++++++++.Width+=+0
++++++++.Height+=+mlblBack.Height+-+(sngOffset+*+2)
++++++++.Caption+=+""
++++++++.BackColor+=+8388608
++++++++.BackStyle+=+1
++++++++.Visible+=+True
++++End+With

++++'+set+properties+for+caption+label
++++With+mlblCaption
++++++++.Left+=+mlblBack.Left+%2B+2
++++++++.Top+=+mlblBack.Top+%2B+2
++++++++.Width+=+mlblBack.Width+-+4
++++++++.Height+=+mlblBack.Height+-+4
++++++++.TextAlign+=+2+'fmTextAlignCenter
++++++++.BackStyle+=+0+'fmBackStyleTransparent
++++++++.Caption+=+"0%25"
++++++++.Visible+=+Not+Me.HideCaption
++++++++.ForeColor+=+16777215+++'+white
++++End+With
++++'Stop

++++Exit+Sub

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Initialize",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Sub

Private+Sub+Class_Terminate()

++++On+Error+GoTo+0++++'+Debug+Mode

++++On+Error+Resume+Next
++++mlblFront.Visible+=+False
++++mlblCaption.Visible+=+False
++++On+Error+GoTo+0++++'+Debug+Mode

++++Exit+Sub

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Class_Terminate",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Sub

Public+Property+Get+Max()+As+Double

++++On+Error+GoTo+0++++'+Debug+Mode

++++Max+=+mdblMax

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Max",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Let+Max(ByVal+dblMax+As+Double)

++++On+Error+GoTo+0++++'+Debug+Mode

++++mdblMax+=+dblMax

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Max",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Get+Value()+As+Double

++++On+Error+GoTo+0++++'+Debug+Mode

++++Value+=+mdblVal

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Value",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Let+Value(ByVal+dblVal+As+Double)

++++On+Error+GoTo+0++++'+Debug+Mode

++++'update+only+if+change+is+=>+1%25
++++If+(CInt(dblVal+*+(100+/+mdblMax)))+>+(CInt(mdblVal+*+(100+/+mdblMax)))+Then
++++++++mdblVal+=+dblVal
++++++++Update
++++Else
++++++++mdblVal+=+dblVal
++++End+If

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Value",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Get+IncrementSize()+As+Double

++++On+Error+GoTo+0++++'+Debug+Mode

++++IncrementSize+=+mdblIncSize

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"IncrementSize",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Let+IncrementSize(ByVal+dblSize+As+Double)

++++On+Error+GoTo+0++++'+Debug+Mode

++++mdblIncSize+=+dblSize

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"IncrementSize",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Get+HideCaption()+As+Boolean

++++On+Error+GoTo+0++++'+Debug+Mode

++++HideCaption+=+mblnHideCap

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"HideCaption",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Public+Property+Let+HideCaption(ByVal+blnHide+As+Boolean)

++++On+Error+GoTo+0++++'+Debug+Mode

++++mblnHideCap+=+blnHide

++++Exit+Property

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"HideCaption",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Property

Private+Sub+Update()

++++On+Error+GoTo+0++++'+Debug+Mode

++++Dim+intPercent+As+Integer
++++Dim+dblWidth+As+Double
++++'On+Error+Resume+Next
++++intPercent+=+mdblVal+*+(100+/+mdblMax)
++++dblWidth+=+mdblVal+*+(mdblFullWidth+/+mdblMax)
++++mlblFront.Width+=+dblWidth
++++mlblCaption.Caption+=+intPercent+&+"%25"
++++'mlblFront.Parent.Repaint++++'+may+not+be+needed

++++'+Use+white+or+black,+depending+on+progress
++++If+Me.Value+>+(Me.Max+/+2)+Then
++++++++mlblCaption.ForeColor+=+16777215+++'+white
++++Else
++++++++mlblCaption.ForeColor+=+0++'+black
++++End+If

++++If+mblnNotSmooth+Then
++++++++If+mdteLastUpdate+<>+Now+Then
++++++++++++'+update+every+second.
++++++++++++DoEvents
++++++++++++mdteLastUpdate+=+Now
++++++++End+If
++++Else
++++++++DoEvents
++++End+If

++++Exit+Sub

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Update",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Sub

Public+Sub+Increment()

++++On+Error+GoTo+0++++'+Debug+Mode

++++Dim+dblVal+As+Double
++++dblVal+=+Me.Value
++++If+dblVal+<+Me.Max+Then
++++++++Me.Value+=+dblVal+%2B+1
++++++++'Call+Update
++++End+If

++++Exit+Sub

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Increment",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Sub

Public+Sub+Clear()

++++On+Error+GoTo+0++++'+Debug+Mode

++++Call+Class_Terminate

++++Exit+Sub

ErrHandler:

++++Select+Case+Err.Number
++++++++Case+Else
++++++++++++LogErr+Err,+"clsLblProg",+"Clear",+Erl
++++++++++++Resume+Next+'+Resume+at+next+line.
++++End+Select

End+Sub

Private+Function+ParentForm(ctlControl+As+Control)+As+String

++++'+returns+the+name+of+the+parent+form
++++Dim+objParent+As+Object

++++Set+objParent+=+ctlControl

++++Do+While+Not+TypeOf+objParent+Is+Form
+++++++Set+objParent+=+objParent.Parent
++++Loop

++++'+Now+we+should+have+the+parent+form
++++ParentForm+=+objParent.Name

End+Function

Public+Property+Get+Smooth()+As+Boolean
++++'+Display+the+progress+bar+smoothly.
++++'+True+by+default,+this+property+allows+the+call
++++'+to+doevents+after+every+increment.
++++'+If+False,+it+will+only+update+once+per+second.
++++'+(This+may+increase+speed+for+fast+progresses.)
++++'
++++'+negative+to+set+default+to+true
++++Smooth+=+mblnNotSmooth
End+Property

Public+Property+Let+Smooth(ByVal+IsSmooth+As+Boolean)
++++mblnNotSmooth+=+Not+IsSmooth
End+Property

Private+Sub+LogErr(objErr,+strMod,+strProc,+intLine)
++++'+For+future+use.
End+Sub|code-block|syntax|javascript|499504|entityMap|0|IMAGE|mutability|IMMUTABLE|imageUrl|https://ask.qcloudimg.com/http-save/yehe-900000/d21c1f28f6f7ed282978f83205c7f0b1.jpeg|imageAlt|1|https://ask.qcloudimg.com/http-save/yehe-900000/3e72643675e02cfa1a97a34bcf6deb51.jpeg|2|https://ask.qcloudimg.com/http-save/yehe-900000/0f0bf82b380fc80244625b5a2250cac8.jpeg^0|1K|A|0|0|0|1|0|0|0|0|0|0|1|1|0|0|0|0|0|1|2|0|0|3|A|0|0^^$0|@$1|2|3|4|5|6|7|1F|8|@$9|1G|A|1H|B|C]]|D|@]|E|$]]|$1|F|3|G|5|6|7|1I|8|@]|D|@]|E|$]]|$1|H|3|I|5|J|7|1J|8|@]|D|@$9|1K|A|1L|1|1M]]|E|$]]|$1|K|3|G|5|6|7|1N|8|@]|D|@]|E|$]]|$1|L|3|M|5|6|7|1O|8|@]|D|@]|E|$]]|$1|N|3|G|5|6|7|1P|8|@]|D|@]|E|$]]|$1|O|3|I|5|J|7|1Q|8|@]|D|@$9|1R|A|1S|1|1T]]|E|$]]|$1|P|3|G|5|6|7|1U|8|@]|D|@]|E|$]]|$1|Q|3|R|5|6|7|1V|8|@]|D|@]|E|$]]|$1|S|3|G|5|6|7|1W|8|@]|D|@]|E|$]]|$1|T|3|I|5|J|7|1X|8|@]|D|@$9|1Y|A|1Z|1|20]]|E|$]]|$1|U|3|G|5|6|7|21|8|@]|D|@]|E|$]]|$1|V|3|W|5|6|7|22|8|@$9|23|A|24|B|C]]|D|@]|E|$]]|$1|X|3|Y|5|Z|7|25|8|@]|D|@]|E|$10|11]]|$1|12|3|-4|5|6|7|26|8|@]|D|@]|E|$]]]|13|$14|$5|15|16|17|E|$18|19|1A|-4]]|1B|$5|15|16|17|E|$18|1C|1A|-4]]|1D|$5|15|16|17|E|$18|1E|1A|-4]]]]

In case others might find this useful, here is a class I wrote for this purpose. I use it all the time in my Access development projects. Just drop it into your project in a class module called <code>clsLblProg</code>, and use it like this:

<img src="https://i.stack.imgur.com/jGOZB.jpg" alt="enter image description here">

This produces a nice little progress bar:

<img src="https://i.stack.imgur.com/HrEUU.jpg" alt="enter image description here">

On your form, all you need is three labels. Set the back label to the desired size and make the other two hidden. The class does the rest.

<img src="https://i.stack.imgur.com/t8rHg.jpg" alt="enter image description here">

And here is the code for <code>clsLblProg</code>:

<pre><code>Option Compare Database
Option Explicit

' By Adam Waller
' Last Modified: 12/16/05

'Private Const sngOffset As Single = 1.5 ' For Excel
Private Const sngOffset As Single = 15 ' For Access

Private mdblMax As Double ' max value of progress bar
Private mdblVal As Double ' current value of progress bar
Private mdblFullWidth As Double ' width of front label at 100%
Private mdblIncSize As Double
Private mblnHideCap As Boolean ' display percent complete
Private mobjParent As Object ' parent of back label
Private mlblBack As Access.Label ' existing label for back
Private mlblFront As Access.Label ' label created for front
Private mlblCaption As Access.Label ' progress bar caption
Private mdteLastUpdate As Date ' Time last updated
Private mblnNotSmooth As Boolean ' Display smooth bar by doevents after every update.

' This class displays a progress bar created
' from 3 labels.
' to use, just add a label to your form,
' and use this back label to position the
' progress bar.

Public Sub Initialize(BackLabel As Access.Label, FrontLabel As Access.Label, CaptionLabel As Access.Label)

 On Error GoTo 0 ' Debug Mode


 Dim objParent As Object ' could be a form or tab control
 Dim frm As Form

 Set mobjParent = BackLabel.Parent
 ' set private variables
 Set mlblBack = BackLabel
 Set mlblFront = FrontLabel
 Set mlblCaption = CaptionLabel

 ' set properties for back label
 With mlblBack
 .Visible = True
 .SpecialEffect = 2 ' sunken. Seems to lose when not visible.
 End With

 ' set properties for front label
 With mlblFront
 mdblFullWidth = mlblBack.Width - (sngOffset * 2)
 .Left = mlblBack.Left + sngOffset
 .Top = mlblBack.Top + sngOffset
 .Width = 0
 .Height = mlblBack.Height - (sngOffset * 2)
 .Caption = ""
 .BackColor = 8388608
 .BackStyle = 1
 .Visible = True
 End With

 ' set properties for caption label
 With mlblCaption
 .Left = mlblBack.Left + 2
 .Top = mlblBack.Top + 2
 .Width = mlblBack.Width - 4
 .Height = mlblBack.Height - 4
 .TextAlign = 2 'fmTextAlignCenter
 .BackStyle = 0 'fmBackStyleTransparent
 .Caption = "0%"
 .Visible = Not Me.HideCaption
 .ForeColor = 16777215 ' white
 End With
 'Stop

 Exit Sub

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Initialize", Erl
 Resume Next ' Resume at next line.
 End Select

End Sub

Private Sub Class_Terminate()

 On Error GoTo 0 ' Debug Mode

 On Error Resume Next
 mlblFront.Visible = False
 mlblCaption.Visible = False
 On Error GoTo 0 ' Debug Mode

 Exit Sub

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Class_Terminate", Erl
 Resume Next ' Resume at next line.
 End Select

End Sub

Public Property Get Max() As Double

 On Error GoTo 0 ' Debug Mode

 Max = mdblMax

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Max", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Let Max(ByVal dblMax As Double)

 On Error GoTo 0 ' Debug Mode

 mdblMax = dblMax

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Max", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Get Value() As Double

 On Error GoTo 0 ' Debug Mode

 Value = mdblVal

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Value", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Let Value(ByVal dblVal As Double)

 On Error GoTo 0 ' Debug Mode

 'update only if change is =&gt; 1%
 If (CInt(dblVal * (100 / mdblMax))) &gt; (CInt(mdblVal * (100 / mdblMax))) Then
 mdblVal = dblVal
 Update
 Else
 mdblVal = dblVal
 End If

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Value", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Get IncrementSize() As Double

 On Error GoTo 0 ' Debug Mode

 IncrementSize = mdblIncSize

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "IncrementSize", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Let IncrementSize(ByVal dblSize As Double)

 On Error GoTo 0 ' Debug Mode

 mdblIncSize = dblSize

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "IncrementSize", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Get HideCaption() As Boolean

 On Error GoTo 0 ' Debug Mode

 HideCaption = mblnHideCap

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "HideCaption", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Public Property Let HideCaption(ByVal blnHide As Boolean)

 On Error GoTo 0 ' Debug Mode

 mblnHideCap = blnHide

 Exit Property

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "HideCaption", Erl
 Resume Next ' Resume at next line.
 End Select

End Property

Private Sub Update()

 On Error GoTo 0 ' Debug Mode

 Dim intPercent As Integer
 Dim dblWidth As Double
 'On Error Resume Next
 intPercent = mdblVal * (100 / mdblMax)
 dblWidth = mdblVal * (mdblFullWidth / mdblMax)
 mlblFront.Width = dblWidth
 mlblCaption.Caption = intPercent &amp; "%"
 'mlblFront.Parent.Repaint ' may not be needed

 ' Use white or black, depending on progress
 If Me.Value &gt; (Me.Max / 2) Then
 mlblCaption.ForeColor = 16777215 ' white
 Else
 mlblCaption.ForeColor = 0 ' black
 End If

 If mblnNotSmooth Then
 If mdteLastUpdate &lt;&gt; Now Then
 ' update every second.
 DoEvents
 mdteLastUpdate = Now
 End If
 Else
 DoEvents
 End If

 Exit Sub

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Update", Erl
 Resume Next ' Resume at next line.
 End Select

End Sub

Public Sub Increment()

 On Error GoTo 0 ' Debug Mode

 Dim dblVal As Double
 dblVal = Me.Value
 If dblVal &lt; Me.Max Then
 Me.Value = dblVal + 1
 'Call Update
 End If

 Exit Sub

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Increment", Erl
 Resume Next ' Resume at next line.
 End Select

End Sub

Public Sub Clear()

 On Error GoTo 0 ' Debug Mode

 Call Class_Terminate

 Exit Sub

ErrHandler:

 Select Case Err.Number
 Case Else
 LogErr Err, "clsLblProg", "Clear", Erl
 Resume Next ' Resume at next line.
 End Select

End Sub

Private Function ParentForm(ctlControl As Control) As String

 ' returns the name of the parent form
 Dim objParent As Object

 Set objParent = ctlControl

 Do While Not TypeOf objParent Is Form
 Set objParent = objParent.Parent
 Loop

 ' Now we should have the parent form
 ParentForm = objParent.Name

End Function

Public Property Get Smooth() As Boolean
 ' Display the progress bar smoothly.
 ' True by default, this property allows the call
 ' to doevents after every increment.
 ' If False, it will only update once per second.
 ' (This may increase speed for fast progresses.)
 '
 ' negative to set default to true
 Smooth = mblnNotSmooth
End Property

Public Property Let Smooth(ByVal IsSmooth As Boolean)
 mblnNotSmooth = Not IsSmooth
End Property

Private Sub LogErr(objErr, strMod, strProc, intLine)
 ' For future use.
End Sub
</code></pre>

blocks|key|499631|text|只是将我的部分添加到上面的集合中，以供将来的读者使用。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|499632|如果你想要更少的代码和更酷的UI。查看我的GitHub+for+Progressbar+for+VBA|offset|length|499633|📷|atomic|499634|​|499635|一个可定制的：|499636|499637|499638|499639|Dll适用于MS-Access，但只需稍作更改即可在所有VBA平台上运行。所有代码都可以在示例数据库中找到。|499640|这个项目目前正在开发中，并没有涵盖所有的错误。所以，期待一些吧！|499641|您应该担心第三方dll，如果您担心，请在实现dll之前随时使用任何可信的在线防病毒软件。|499642|entityMap|0|LINK|mutability|MUTABLE|url|https://github.com/krishKM/VBA_TOOLS/blob/master/README.md#show-cool-progressbar|1|IMAGE|IMMUTABLE|imageUrl|https://ask.qcloudimg.com/http-save/yehe-900000/2b1cfb0bbbfa9fcc6d3130a047f992c1.png|imageAlt|2|https://ask.qcloudimg.com/http-save/yehe-900000/86dd12dbb3f318e0bf1bfe5af20b50aa.png^0|0|L|U|0|0|0|1|1|0|0|0|0|0|1|2|0|0|0|0|0^^$0|@$1|2|3|4|5|6|7|1B|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|1C|8|@]|9|@$D|1D|E|1E|1|1F]]|A|$]]|$1|F|3|G|5|H|7|1G|8|@]|9|@$D|1H|E|1I|1|1J]]|A|$]]|$1|I|3|J|5|6|7|1K|8|@]|9|@]|A|$]]|$1|K|3|L|5|6|7|1L|8|@]|9|@]|A|$]]|$1|M|3|J|5|6|7|1M|8|@]|9|@]|A|$]]|$1|N|3|G|5|H|7|1N|8|@]|9|@$D|1O|E|1P|1|1Q]]|A|$]]|$1|O|3|J|5|6|7|1R|8|@]|9|@]|A|$]]|$1|P|3|Q|5|6|7|1S|8|@]|9|@]|A|$]]|$1|R|3|S|5|6|7|1T|8|@]|9|@]|A|$]]|$1|T|3|U|5|6|7|1U|8|@]|9|@]|A|$]]|$1|V|3|-4|5|6|7|1V|8|@]|9|@]|A|$]]]|W|$X|$5|Y|Z|10|A|$11|12]]|13|$5|14|Z|15|A|$16|17|18|-4]]|19|$5|14|Z|15|A|$16|1A|18|-4]]]]

Just adding my part to the above collection for future readers.

If you are after less code and maybe cool UI. Check out my <a href="https://github.com/krishKM/VBA_TOOLS/blob/master/README.md#show-cool-progressbar" rel="nofollow noreferrer">GitHub for Progressbar for VBA</a>
<a href="https://i.stack.imgur.com/M7CHk.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/M7CHk.png" alt="enter image description here"></a>

a customisable one:

<a href="https://i.stack.imgur.com/bGvul.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/bGvul.png" alt="enter image description here"></a>

The Dll is thought for MS-Access but should work in all VBA platform with minor changes. All codes can be found in the sample database.

This project is currently under development and not all errors are covered. So expect some!

You should be worried about 3rd party dlls and if you are, please feel free to use any trusted online antivirus before implementing the dll.

I have a query running in Microsoft Access 2010 and it takes over 30 minutes to run normally. I would like to present the end user with some status of the query. A progress bar would be nice but not required. Access seems to be poorly threaded and locks up tight during the execution of the query, negating any updates I try. While I'd rather whip out VS and write my own app to do this, I'm forced to use Access.
I used to run this from a batch script which populated the database but I'd like to have it all self-contained in Access. To be specific, the &quot;query&quot; is really a VBA script that pings a series of hosts. So I'm not too concerned about optimizing the time per se but simply about letting the end user know it hasn't locked up.

Progress bar in MS Access

数据库

我有一个查询在Microsoft Access 2010中运行，它需要30分钟才能正常运行。我想向最终用户显示查询的一些状态。进度条很好，但不是必需的。在查询执行过程中，Access的线程化程度似乎很差，并且锁得很紧，这就否定了我尝试的任何更新。虽然我宁愿使用VS并编写自己的应用程序来做这件事，但我还是不得不使用Acc...

问MS Access中的进度条
EN

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问MS Access中的进度条EN

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问MS Access中的进度条
EN