Built in Status Bar Progress Meter for list of tasks not recordset

[patriciaxxx]

What I need is to include the Built in Status Bar Progress Meter so that it reports on the progress of a function or sub or block of code that executes various tasks other than recordsets for which there are many examples on the web.

Here is the code for progress meter. But all it does is shows progress of whatever the number is in this case 5000. how do I modify and include the progress meter code into function 1 and function 2 to show the actual progress of those functions:-

Dim varRtn As Variant
Dim inti As Integer
'Initialize the progress meter
varRtn = SysCmd(acSysCmdInitMeter, "Doing Stuff", 5000)
For inti = 1 To 5000
'Increment the progress meter on each iteration
varRtn = SysCmd(acSysCmdUpdateMeter, inti)
DoEvents
Next inti
'Remove the meter
varRtn = SysCmd(acSysCmdRemoveMeter)

Here are 2 sample functions which I would like the built in progress meter to work with:-

‘FUNCTION_1
Public Function ReLinkTables() As Boolean
On Local Error GoTo ReLinkTables_Err
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim dbCurr As DAO.Database
Dim tdf As TableDef
ReLinkTables = False


Set dbCurr = CurrentDb

'Test specified table for correct path.
If (CurrentProject.path & "\switchboardbe.mdb" = Right(dbCurr.TableDefs("tblLogonPassword").Connect, Len(dbCurr.TableDefs("tblLogError").Connect) - (InStr _
(1, dbCurr.TableDefs("tblLogError").Connect, "DATABASE=") + 8))) Then Exit Function

'Get all linked tables in a collection.
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If Len(.Connect) > 0 Then
collTbls.Add Item:=.Name & .Connect, Key:=.Name
End If
End With
Next
Set tdf = Nothing

'link all tables.
For i = collTbls.Count To 1 Step -1
strTbl = Left$(collTbls(i), InStr(1, collTbls(i), ";") - 1)
strDBPath = CurrentProject.path & "\switchboardbe.mdb"
'Reconnect.
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = ";Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
'Success.
ReLinkTables = True

ReLinkTables_Exit:
Set collTbls = Nothing
Set tdf = Nothing
Set dbCurr = Nothing
Exit Function

ReLinkTables_Err:
ReLinkTables = False
Call LogError(Err.Number, Err.Description, "ReLinkTables()", , True)
Resume ReLinkTables_Exit

End Function

‘FUNCTION _2
Function EnableBypassKey()
On Error GoTo EnableBypassKey_Err
Const DB_Text As Long = 10
Dim IconPath As String
IconPath = CurrentProject.path & "\icon.ico"

If CurrentDb.Properties("AppTitle") = "Switchboard project v" & GetVersionNumber Then CurrentDb.Properties.Delete ("AppTitle")
If CurrentDb.Properties("AppIcon") = IconPath Then CurrentDb.Properties.Delete ("AppIcon")
Application.RefreshTitleBar
ChangeProperty "StartUpMenuBar", dbText, "(default)"
ChangeProperty "AllowFullMenus", dbBoolean, True
ChangeProperty "AllowShortcutMenus", dbBoolean, True
ChangeProperty "StartupShowDBWindow", dbBoolean, True
ChangeProperty "StartupShowStatusBar", dbBoolean, True
ChangeProperty "StartupShortcutMenuBar", dbText, "(default)"
ChangeProperty "AllowBuiltInToolbars", dbBoolean, True
ChangeProperty "AllowToolbarChanges", dbBoolean, True
ChangeProperty "AllowBypassKey", dbBoolean, True
ChangeProperty "AllowBreakIntoCode", dbBoolean, True
ChangeProperty "AllowSpecialKeys", dbBoolean, True
ChangeProperty "StartUpForm", dbText, "(none)"
Application.CommandBars.DisableAskAQuestionDropdown = False
Beep

MsgBox "The application is" & Chr(13) & "about to close", vbOKOnly, MsgTitle()

'Set database property to false.
Dim db As Database
Set db = DBEngine(0)(0)
db.Properties![Administrator] = True

Forms!frmLogonPassword.OnClose = "" 'Disable form event.
DoCmd.Close acForm, "frmLogonPassword"
DoCmd.Quit acExit

EnableBypassKey_Exit:
Exit Function

EnableBypassKey_Err:
Call LogError(Err.Number, Err.Description, "EnableBypassKey()", , True)
Resume EnableBypassKey_Exit

End Function

 

[MazeWorX]

this should do on function1 There is no point to function 2 as it will happen so fast you ll never see it. As a matter of fact it'll be pretty quick on the first on aswell

'FUNCTION_1
Public Function ReLinkTables() As Boolean
    On Local Error GoTo ReLinkTables_Err
    Dim collTbls As New Collection
    Dim i As Integer
    Dim strDBPath As String
    Dim strTbl As String
    Dim dbCurr As DAO.Database
    Dim tdf As TableDef
    Dim varRtn As Variant
    Dim inti As Integer
    ReLinkTables = False

    Set dbCurr = CurrentDb()

    'Test specified table for correct path.
    If (CurrentProject.Path & "\switchboardbe.mdb" _
      = Right(dbCurr.TableDefs("tblLogonPassword").Connect, _
              Len(dbCurr.TableDefs("tblLogError").Connect) - (InStr _
              (1, dbCurr.TableDefs("tblLogError").Connect, "DATABASE=") + 8))) Then
        Exit Function
    End If
    'Get all linked tables in a collection.
    dbCurr.TableDefs.Refresh
    For Each tdf In dbCurr.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                collTbls.Add Item:=.Name & .Connect, key:=.Name
            End If
        End With
    Next
    Set tdf = Nothing
    varRtn = SysCmd(acSysCmdInitMeter, "Doing Stuff", collTbls.Count)
    For inti = 1 To collTbls.Count
        varRtn = SysCmd(acSysCmdUpdateMeter, inti)
        DoEvents
        'link all tables.
        For i = collTbls.Count To 1 Step -1
            strTbl = Left$(collTbls(i), InStr(1, collTbls(i), ";") - 1)
            strDBPath = CurrentProject.Path & "\switchboardbe.mdb"
            'Reconnect.
            Set tdf = dbCurr.TableDefs(strTbl)
            With tdf
                .Connect = ";Database=" & strDBPath
                .RefreshLink
                collTbls.Remove (.Name)
            End With
        Next
    Next inti
    'Success.
    ReLinkTables = True
    varRtn = SysCmd(acSysCmdRemoveMeter)
ReLinkTables_Exit:
    Set collTbls = Nothing
    Set tdf = Nothing
    Set dbCurr = Nothing
    Exit Function

ReLinkTables_Err:
    ReLinkTables = False
    Call LogError(Err.Number, Err.Description, "ReLinkTables()", , True)
    Resume ReLinkTables_Exit

End Function

HTH << MaZeWorX >> "I have not failed I have only found ten thousand ways that don't work" <<Edison>>

 

[patriciaxxx]

Works great
Thanks MazeWorX