Progress Bar not accurate

Hi,



I'm making a code to run a Progress Bar from different forms and as per their conditions.



Have two forms:

1- Form1="frmProgressMeter"

2- Form2="frmDatabaseStwitcher"

3- Module1=for Functions



On frmDatabaseStwitcher, the code for Progress Bar is:

-----------

Option Compare Database

Option Explicit

Private Declare Sub sapiSleep Lib "kernel32" _

Alias "Sleep" _

(ByVal dwMilliseconds As Long)



Sub OpenProgressBar(nTopLimit As Long, strCaption As String)

If nTopLimit > 0 Then

DoCmd.OpenForm "FrmProgressMeter", OpenArgs:=strCaption

Forms("FrmProgressMeter").TopLimit = nTopLimit

End If

End Sub



Function SetProgressBar(nCurrent_Pos As Long) As Long

If IsLoaded("FrmProgressMeter") Then

Forms("FrmProgressMeter").Current_pos = nCurrent_Pos

SetProgressBar = Forms("FrmProgressMeter").Current_pos()

End If

End Function



Sub CloseProgressBar()

If IsLoaded("FrmProgressMeter") Then

Forms("FrmProgressMeter").CloseMe

End If

End Sub



Sub sSleep(lngMilliSec As Long)

If lngM

illiSec > 0 Then

Call sapiSleep(lngMilliSec)

End If

End Sub



------------



Code to run Progress Bar with Condition is:



----------

Private Sub cmdDisconnect_Click()

On Error GoTo Err_cmdDisconnect_Click



Dim dbs As DAO.Database

Dim tdf As DAO.TableDef

Dim strDatabaseName As String

Dim File As String

Dim retval

Dim NOS As Long 'No of steps

Dim n As Long 'Total Steps



Set dbs = CurrentDb()

File = "Data" & Format(StartDate, "yy") & Format(EndDate, "yy") & ".accdb" '(Output = Data1516.accdb)

strDatabaseName = Folderpath & "\" & File



Me.lblStatus.Caption = "Connecting to current database. Please wait..."

DoCmd.Hourglass True

Me.CmdClose.Enabled = False

Me.cmdConnect.Enabled = False

Me.Dbase.Enabled = False

Me.CmdDisconnect.Enabled = False

retval = SysCmd(acSysCmdSetStatus, "Connecting to current database")



OpenProgressBar 100, "Completed"



NOS = dbs.TableDefs.count

For n = 1 To 100

sSleep 10

SetProgressBar n + NOS

Next n


For Each tdf In dbs.TableDefs

If tdf.Connect <> "" Then

tdf.Connect = ";DATABA

SE=" & strDatabaseName & (";PWD=zujan")

tdf.RefreshLink

End If



SetProgressBar n + NOS
Next tdf

sSleep 1000

CloseProgressBar



Me.lblStatus.Caption = "Done."

DoCmd.Hourglass False

retval = SysCmd(acSysCmdClearStatus)



MsgBox "The Auto Evolution database is now connected with " & _

"'" & File & "'.", vbInformation, "Connection Successful"

DoCmd.Close acForm, Me.NAME



Exit_cmdDisconnect_Click:

Exit Sub



Err_cmdDisconnect_Click:



DoCmd.Hourglass False

If Err.Number <> 2467 Then

MsgBox ("Unable to execute database switch now."), vbCritical, "Error"

Me.CmdClose.Enabled = True

Me.cmdConnect.Enabled = True

Me.Dbase.Enabled = True

Me.CmdDisconnect.Enabled = True

Resume Exit_cmdDisconnect_Click

End If

End Sub

Progress Bar not accurate