Progress bar

[noliveira]

Dear all,
I have this code working and would like to insert a progress bar. I´m having problems to do that...

Sub getExpiredUsers()
MsgBox "This script can take a few minutes to run!" & vbNewLine & "Please wait a while...", , "Return Experied Users Accounts"
Set objShell = CreateObject("Wscript.Shell")
lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" & "TimeZoneInformation\ActiveTimeBias")
If (UCase(TypeName(lngBiasKey)) = "LONG") Then
lngTZBias = lngBiasKey
ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
lngTZBias = 0

For k = 0 To UBound(lngBiasKey)
lngTZBias = lngTZBias + (lngBiasKey(k) * 256 ^ k)
Next
End If
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
adoCommand.ActiveConnection = adoConnection
Set objRootDSE = GetObject("ldap://RootDSE")
strDNSDomain = objRootDSE.get("defaultNamingContext")
strBase = "<LDAP://" & strDNSDomain & ">"
' Filter on user objects expired before August 19, 2008.
strFilter = "(&(objectCategory=person)(objectClass=user)" & "(accountExpires<=128635956000000000)(!accountExpires=0))"
strAttributes = "displayName,accountExpires"
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
'Run query.
Set adoRecordset = adoCommand.Execute
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile("D:\SecurityReports\ExperiedUsersAccounts.txt")

Do Until adoRecordset.EOF
strName = adoRecordset.Fields("displayName").Value
Set objDate = adoRecordset.Fields("accountExpires").Value
dtmDate = Integer8Date(objDate, lngTZBias)
'Wscript.Echo "User account: " & strName & ", Expired: " & dtmDate
objTextFile.Write "User account: " & strName & ", Expired: " & dtmDate
adoRecordset.MoveNext
Loop
adoRecordset.Close
adoConnection.Close
End Sub
Function Integer8Date(ByVal objDate, ByVal lngBias)
'Convert Integer8 (64-bit) value to a date
Dim lngAdjust, lngDate, lngHigh, lngLow
lngAdjust = lngBias
lngHigh = objDate.HighPart
lngLow = objDate.LowPart

If (lngLow < 0) Then
lngHigh = lngHigh + 1
End If
If (lngHigh = 0) And (lngLow = 0) Then
lngAdjust = 0
End If
lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) + lngLow) / 600000000 - lngAdjust) / 1440

On Error Resume Next
Integer8Date = CDate(lngDate)
If (Err.Number <> 0) Then
On Error GoTo 0
Integer8Date = #1/1/1601#
End If
On Error GoTo 0
MsgBox "End of script!!", , "Return Experied Users Accounts"

End Function

Coul you help?
Tnanks