Verifying a database location 1

[bjt52]

Is it possible with VBA to verify the current location of the database? What I would like to do is have the database verify that it is in a specific folder before it will run.
Thanks

 

[JerryKlmns]

Try

CurrentProject.Path
or
CurrentProject.FullName

 

[bjt52]

Thanks Jerry
It works great..

 

[bjt52]

Jerry,
I have got this to work with the database being on a local E:\Files\Sales\SalesOrder.mdb. I have several machine that are not mapped on the E-drive so is there are way to have it work with \\OH38783\Files\Sales\SalesOrder.mdb?
Thanks

 

[JerryKlmns]

Cant think of a ready built-in command but this would do the trick

Function MappedServerName(myPath As String) As String
Dim objWshNetwork As Object
Dim objCheckDrive As Object
Dim fso As Object
Dim lCheckDriveCounts As Long
Dim iCount As Long
Dim myServerName As String
    
    MappedServerName = ""
    Set objWshNetwork = CreateObject("WScript.Network")
    Set objCheckDrive = objWshNetwork.EnumNetworkDrives()
    lCheckDriveCounts = objCheckDrive.Count
    Set fso = CreateObject("Scripting.FileSystemObject")
    For iCount = 0 To lCheckDriveCounts - 1 Step 2
        If Trim(UCase(objCheckDrive.Item(iCount)) & "") = fso.GetDriveName(myPath) Then
            myServerName = UCase(objCheckDrive.Item(iCount + 1))
            myServerName = Left(myServerName, InStrRev(myServerName, "\"))
            myServerName = Replace(myServerName, "\", "")
            MappedServerName = myServerName
            Exit For
        End If
    Next iCount
    Set fso = Nothing
    Set objCheckDrive = Nothing
    Set objWshNetwork = Nothing
End Function

 

[bjt52]

Jerry,
Please excuse my ignorance for I am a novice at VBA and I need to ask a few questions.
But first let me explain what I am trying to do. I am trying to write a routine for the Onload Event of my splash screen to verify that the copy of the database is located on specific server and folder before it will run this is the code If CurrentProject.FullName<>
E:\Files\Sales\SalesOrder.mdb then
Msgbox "Access Denied"
Docmd.Quit
I place my path \\OH38783\Files\Sales\SalesOrder.mdb in the
MappedServerName=” \\OH38783\Files\Sales\SalesOrder.mdb” which I think is correct?
How would I include this function to do what I am trying to achieve?
Thanks

 

[ClydeData]

If what you want is that the database will only open on certain PC,s (IE make sure it can't be copied and opened elsewere) try this

1)Place this code on the on open event of your splash

Dim sFile As String
sFile = "C:\WINDOWS\YourDatabaselicence.txt"
If Dir(sFile) = "" Then
DoCmd.Quit acQuitSaveNone
End If

2) place an text file called YourDatabaselicence.txt in the winows directory



This checks if C:\WINDOWS\YourDatabaselicence.txt exists if it does not exist then it closes the database

Hope this helps

JImmy

 

[bjt52]

Jerry,
Thansk..
This is a good ideal for the local machines but I have remote users and the database will be one a server that dont have access the the Root Drive.

 

[bjt52]

The last not was to Jimmy not Jerry

 

[JerryKlmns]

Sorry for the late responding

Doesn't this work for you
?MappedServerName(CurrentProject.Path)

Runs ok, on mine!

 

[bjt52]

Jerry,
When I try ?MappedServerName(CurrentProject.Path)
complier error:
Sub or Function not defined.

 

[JerryKlmns]

This is to be run from the immediate window (Ctrl+G)
?MappedServerName(CurrentProject.Path)

and the answer should be the name of the server. Will not work if the mdb is on your local drive

 

[bjt52]

Jerry,
I did run it from the immediate window and the mdb is on a remote machine. That is why i not sure what is wrong..

 

[JerryKlmns]

bjt52

Lets take it from the beggining

Suppose you have mapped the \\OH38783\Files as G:
The function should return OH38783

Case 1
Your users map it as J:
The function should return OH38783

Case 2
Your users don't map it at all, but the use the full path \\OH38783\Files\Sales\SalesOrder.mdb to open the mdb.
The function should return a zero length string, (it is not EMPTY). Then we have do amend it to use this Split(CurrentProject.Path,"\")(2)

Following is the final amended code

Function MappedServerName(myPath As String) As String
Dim objWshNetwork As Object
Dim objCheckDrive As Object
Dim fso As Object
Dim lCheckDriveCounts As Long
Dim iCount As Long
Dim myServerName As String
    
    MappedServerName = ""
    Set objWshNetwork = CreateObject("WScript.Network")
    Set objCheckDrive = objWshNetwork.EnumNetworkDrives()
    lCheckDriveCounts = objCheckDrive.Count
    Set fso = CreateObject("Scripting.FileSystemObject")
    For iCount = 0 To lCheckDriveCounts - 1 Step 2
        If Trim(UCase(objCheckDrive.Item(iCount)) & "") = fso.GetDriveName(myPath) Then
            myServerName = UCase(objCheckDrive.Item(iCount + 1))
            myServerName = Left(myServerName, InStrRev(myServerName, "\"))
            myServerName = Replace(myServerName, "\", "")
            MappedServerName = myServerName
            Exit For
        End If
    Next iCount
    Set fso = Nothing
    Set objCheckDrive = Nothing
    Set objWshNetwork = Nothing
    If MappedServerName = "" Then 
       MappedServerName = Split(CurrentProject.Path, "\")(2)
    End If
End Function

Hope that it works now for you.

 

[bjt52]

Thanks Jerry