Индикатор выполнения в MS Access

20

У меня есть запрос, запущенный в Microsoft Access 2010, и для нормальной работы требуется более 30 минут. Я хотел бы представить конечному пользователю некоторый статус запроса. Индикатор выполнения будет приятным, но не обязательным. Доступ, по-видимому, плохо пронизывается и блокируется во время выполнения запроса, отрицая любые обновления, которые я пытаюсь выполнить. Хотя я предпочел бы вытащить VS и написать свое приложение, чтобы сделать это, я вынужден использовать Access.

Любые идеи?

ИЗМЕНИТЬ

Я использовал этот сценарий из пакетного скрипта, который заполнял базу данных, но я хотел бы, чтобы все это было включено в Access. Чтобы быть конкретным, «запрос» - это действительно сценарий VBA, который пингует ряд хостов. Поэтому я не должен беспокоиться о том, чтобы оптимизировать время как таковое, но просто чтобы конечный пользователь знал, что он не заблокирован.     

задан Menefee 14.08.2012 в 18:35
источник
  • Как я помню, у Access возникают проблемы с базами данных среднего размера (~ 100 000 записей) или около того. –  Woot4Moo 14.08.2012 в 18:38
  • Есть вероятность, что запрос может быть ускорен, если вы разместите sql. 30 минут необычно. –  Fionnuala 14.08.2012 в 18:41
  • @ Woot4Moo Вы думаете о далеком прошлом. Любая база данных имеет проблемы, если она не может использовать индексы, например. Доступ - это всего лишь 100 000 записей, если они не очень большие записи. –  Fionnuala 14.08.2012 в 18:42
  • Да, Remou. Пожалуйста, покажите нам ваш запрос Menefee! –  Olivier Jacot-Descombes 14.08.2012 в 19:04
  • Вы не можете добавить индикатор выполнения в процесс запуска одного запроса, потому что это «атомарное» действие в Access. BTW, оптимизация иногда также может быть выполнена путем разделения большого запроса на некоторые более мелкие запросы, что в целом может потребовать меньше памяти. –  Christoph Jüngling 15.08.2012 в 13:57

7 ответов

25

Я часто делаю что-то вроде этого

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

Примечание. Конечно, вы должны программно работать, чтобы это работало. Вы не можете смотреть запрос на выполнение в коде и т. П. В Access. Возможно, вы могли бы разделить работу вашего медленного запроса на более мелкие части, чтобы получить шанс обновить индикатор выполнения. Но вы всегда можете показать часовое стекло; это говорит пользователю, что что-то происходит.

    
ответ дан Olivier Jacot-Descombes 14.08.2012 в 18:52
источник
  • И я думаю, что это как раз и проблема. Я хотел бы знать ход выполнения текущего запроса, но механизм JET DB не обновляет родительский поток, поэтому кажется невозможным. Надеюсь, я здесь не прав ... –  Menefee 14.08.2012 в 20:45
  • Нет, к сожалению, вы правы. Может быть, кто-то может улучшить ваш запрос, если вы покажете SQL. –  Olivier Jacot-Descombes 15.08.2012 в 13:40
  • Если запрос влияет на большое количество строк, вы можете улучшить этот метод, используя буфер транзакции и совершая изменения набора записей только один раз в конце. –  Matt Donnan 15.08.2012 в 14:56
14

Если другие могут найти это полезным, вот класс, который я написал для этой цели. Я использую его все время в проектах разработки Access. Просто добавьте его в свой проект в модуле класса, называемом clsLblProg , и используйте его следующим образом:

Это создает приятный небольшой индикатор выполнения:

В вашей форме все, что вам нужно, это три ярлыка. Установите обратную метку на желаемый размер и сделайте две другие скрытыми. Класс делает все остальное.

И вот код для clsLblProg :

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 => 1%
    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 & "%"
    '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 + 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
    
ответ дан AdamsTips 30.01.2015 в 21:34
источник
  • Хороший класс ... Выглядит немного старая школа, но делает эту работу. Я подтверждаю, что он работает в MS Access 2010 - 32bit –  Combinatix 06.02.2015 в 20:48
  • , где я могу поместить процесс? Мне жаль, это не очевидно для меня, но где я могу поместить свой процесс - например DoCmd.OpenQuery («LongQuery») –  monty327 29.09.2016 в 03:42
  • @ monty327 - Обычно вы будете использовать это, когда будете делать цикл через код. Если у вас есть один длинный запрос, вам может потребоваться немного другой подход, чтобы иметь возможность использовать индикатор выполнения. Надеюсь, это поможет! –  AdamsTips 29.09.2016 в 16:01
  • Это работает очень хорошо. Благодаря! –  Freeman Helmuth 27.09.2017 в 16:53
1

Из-за проблем с доступным контролем я создал домашнюю полосу прогресса, используя 2 прямоугольника. Граница и сплошной бар, который изменяется по мере продвижения. Прогресс прямоугольника впереди границы. Чтобы использовать

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

Можно связать строку состояния с индикатором выполнения, который сообщает, какой элемент обрабатывается. Подобно:   123. Район SomeWhere, торговый агент WhomEver

======== Простой бар заменить pBar_sub ==============

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
    
ответ дан jas0501 04.10.2013 в 11:39
источник
1

Используйте команду DoEvents после обновления панели прогресса (acSysCmdUpdateMeter).

В случае большого количества записей выполняется только DoEvents только каждые x раз, так как это немного замедляет ваше приложение.

    
ответ дан Jan 29.04.2014 в 11:44
источник
0

Просто добавьте мою часть в сборник для будущих читателей.

Если вы используете меньше кода и, возможно, классный интерфейс. Просмотрите мой GitHub для Progressbar для VBA

настраиваемый:

Dll считается для MS-Access, но он должен работать на всех платформах VBA с незначительными изменениями. Все коды можно найти в базе данных примеров.

Этот проект в настоящее время разрабатывается, и не все ошибки охвачены. Поэтому ожидайте некоторых!

Вам следует беспокоиться о DLL сторонних разработчиков, и, если хотите, вы можете использовать любой доверенный онлайн-антивирус перед реализацией dll.

    
ответ дан krish KM 08.05.2018 в 18:41
источник
0

Это не профессиональный подход, но может быть применен, если вам это нравится. Если вы используете форму У вас может быть небольшое текстовое поле в удобном месте по умолчанию с зеленым цветом.

Предположим, что текстовое поле Имя TxtProcessing ,
Свойства могут быть такими, как показано ниже.

Name : TxtProcessing
Visible : Yes
Back color : Green
Locked: Yes
Enter Key Behavior : Default

1) В вашем скрипте VB вы можете поместить Me.TxtProcessing.BackColor = vbRed , который будет в Red, и это означает задачу в Process.
2) вы можете написать весь набор скриптов
3) Наконец вы можете установить Me.TxtProcessing.BackColor = vbGreen

Me.TxtProcessing.BackColor = vbRed
Me.TxtProcessing.SetFocus
Me.Refresh

Your Code here.....

Me.TxtProcessing.BackColor = vbGreen
Me.TxtProcessing.SetFocus

:-) Смешно, но цель достигнута.

    
ответ дан Shiva 18.02.2014 в 13:02
источник
-2

Сначала перетащите прогрессивную панель управления в форму MS Access, затем измените имя прогрессивного бара, например aa .

Затем перейдите к form property , по таймеру :write в коде

me.aa.value=me.aa.value+20

интервал времени 300 по вашему выбору. Запустив форму, вы увидите прогрессивную панель

    
ответ дан user4014162 06.09.2014 в 10:45
источник