Может это подойдет?
Sub ShowProgress()
Dim doc As Document
Dim n As Long
Set doc = CreateDocument
Status.BeginProgress CanAbort:=True
For n = 1 To 1000
doc.ActiveLayer.CreateRectangle2 Rnd() * 8, Rnd() * 11, Rnd() * 5, Rnd() * 5
If (n Mod 10) = 0 Then
Status.UpdateProgress
If Status.Aborted Then Exit For
End If
Next n
Status.EndProgress
End Sub