Function StringIBState(strIBDir)
     StringIBState = IBStateToString( IBState(strIBDir) )
End Function

function IBStateToString(iIBState)
     IBStateToString = ""
     if iIBState = 0 then
           IBStateToString = "В базе никого нет"
     end if
     if iIBState = 1 then
            IBStateToString = "База работает в монопольном режиме"
     end if
     if iIBState = 2 then
            IBStateToString = "В базе работает один пользователь в разделенном режиме"
     end if
     if iIBState = -1 then
           IBStateToString = "Выполнен некорректный выход из 1С, нужна переиндексация"
     end if
     if iIBState = 3 then
            IBStateToString = "1С работает в разделенном режиме"
     end if
end function

Function IBState(strIBDir)
     iIBUsersCount = GetIBUsersCount(strIBDir)
     bIsAnyUserInIB = not TryFileOpen(strIBDir)

     if (iIBUsersCount = 0) then ' убрал условие открытия. Если 0 какая разница можно писать или нет?
           IBState = 0 ' в базе никого нет
     end if
     if (iIBUsersCount = -1) then '  то же самое. Если монопольно, какая разница можно открыть или нет?
           IBState = 1 ' кто-то сидит монопольно
     end if
     if (iIBUsersCount = 1) and bIsAnyUserInIB then
           IBState = 2 ' В базе работает один пользователь
     end if
     if (iIBUsersCount > 0) and not bIsAnyUserInIB then
           IBState = -1 ' некорректный выход из программы, нужна переиндексация
     end if
     if (iIBUsersCount > 1) and bIsAnyUserInIB then
           IBState = 3 '1С работает в разделенном режиме
     end if
End Function

Function TryFileOpen(strIBDir)
     TryFileOpen = false
     set fso = CreateObject("Scripting.FileSystemObject")
   
     strIBDir2 = strIBDir
     if Right(strIBDir, 1) <> "\" then
           strIBDir2 = strIBDir & "\"
     end if

     on Error resume next
     ForAppending = 8
     set file = fso.OpenTextFile(strIBDir2 & "1susers.dbf", ForAppending)
     iErrNumber = Err.Number

     on Error goto 0

     if iErrNumber <> 0 then
           Exit Function
     end if
     
     file.Close
     TryFileOpen = true
End Function
     
Function GetIBUsersCount(strIBDir)
     GetIBUsersCount = -1
     strText = "select usrscnt from 1susers"
     
     'ConnectString =      "DRIVER=Microsoft Visual FoxPro Driver;Deleted=Yes;Null=Yes;Collate=RUSSIAN;"+ _
     '                              "Exclusive=No;SourceType=DBF;SourceDB="+strIBDir
     ConnectString = "DRIVER=Driver do Microsoft dBase (*.dbf);FIL=dBase 5.0;DriverId=533;CollatingSequence=ASCII;DefaultDir=" & _
                                   strIBDir & ";UID=Admin"
                                   
     set Connection=CreateObject("ADODB.Connection")
     Connection.ConnectionTimeOut=600

     Connection.Open(ConnectString)

     set Rs=CreateObject("ADODB.RecordSet")
     Rs.ActiveConnection=Connection
     
     on Error resume next

     Rs.Open strText, Connection
     iErrNumber = Err.Number

     on Error goto 0
     
     if iErrNumber = 0 then
           GetIBUsersCount = CInt(Rs.Fields(0).Value)
     else
           GetIBUsersCount = -1 ' монопольный режим
     end if

     on Error resume next
     Rs.Close
     Connection.Close
     on Error goto 0
End Function

Из кода 1С можно поступить проще