Как синхронизировать приложение и VBA модуль

Понедельник, 16 Июня 2014 г. 14:24 + в цитатник

Доброго дня господа !

Необходимо в процессе выполнения пользовательского потока
изменить Application.StatusBar (в Excele)
Весь файл прилагаю !
Подскажите пожалуйста

Заранее благодарен !

Option Explicit

Private StatusBarState As Boolean
Private EnableEventsState As Boolean
Private ScreenUpdatingState As Boolean
Private FULLS_CHAR As String
Private FRAME_CHAR As String
Private SPACE_CHAR As String
Private Const NUM_BAR As Integer = 50
Private Const MAX_LEN As Integer = 255

Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
Private Sub Class_Initialize()
  StatusBarState = Application.DisplayStatusBar
  EnableEventsState = Application.EnableEvents
  ScreenUpdatingState = Application.ScreenUpdating
  FULLS_CHAR = ChrW(9609)
  FRAME_CHAR = ChrW(9597)
  SPACE_CHAR = ChrW(9620)
  Application.DisplayStatusBar = True 
  Application.ScreenUpdating = False
  Application.EnableEvents = False
End Sub
Public Function Refresh(ByVal Value As Integer, Optional ByVal MaxValue As Integer = 0, Optional ByVal Status As String = "", Optional ByVal ShowPercent As Boolean = True) As String
  Dim Display As String
  If Value < 0 Or MaxValue < 0 Or (Value > 100 And MaxValue = 0) Then Exit Function
  If MaxValue > 0 Then Value = Int((Value * 100) / MaxValue) + IIf(Int((Value * 100) / MaxValue) = (Value * 100) / MaxValue, 0, 1)
  Display = String(Int(Value / (100 / NUM_BAR)), FULLS_CHAR)
  Display = Display & String(NUM_BAR - Int(Value / (100 / NUM_BAR)), SPACE_CHAR)
  Display = Status & "  " & FRAME_CHAR & Display & FRAME_CHAR
  If ShowPercent = True Then Display = Display & "(" & Value & "%)"
  If Len(Display) > MAX_LEN Then Display = Right(Display, MAX_LEN)
  Refresh = Display
End Function
Public Sub WaitTime(ByVal Time As Integer)
  Dim I As Integer
  For I = 1 To NUM_BAR
    Application.StatusBar = Refresh(I, NUM_BAR, "Execute Query", True) - 'ПРИОСТАНОВИТЬ ПОТОК и ПРИСВОИТЬ ЗНАЧЕНИЕ    Sleep CInt(Time * 1000# / NUM_BAR)
  Next
End Sub
Private Sub Class_Terminate()
  Application.StatusBar = False
  Application.DisplayStatusBar = StatusBarState
  Application.ScreenUpdating = ScreenUpdatingState
  Application.EnableEvents = EnableEventsState
End Sub