Checking to see if XLS file is local

I distribute tools in Excel form all over my company. I put them in a shared folder on one of our servers, and people copy them to their local computers to use them. Since some folks are too stupid to copy it first, and just open it right from it's shared location, I've been using a piece of code to check:

[vba]Private Sub Workbook_Open()


If Not Left(ThisWorkbook.FullName, 1) = Left(Environ("USERPROFILE"), 1) Or _
Not Left(ThisWorkbook.FullName, 1) = Left(Environ("windir"), 1) Then
MsgBox "This tool can not be run from a network location." _
& vbLf & vbLf & "Copy the .xls file to your desktop, and open it from there." _
, vbCritical, "File not local!"
ThisWorkbook.Close False
End If


End Sub[/vba]
This has always worked fine.

BUT. Now I have a tool with world-wide distribution, and it has started failing on computers in our UK office. Even when they copy it to their desktops, it trips the MSGBOX and closes. WHY?

What would make this fail?

I already tweaked the code once: first it only checked to see if the drive letter was the same as the drive with the Desktop, and now it it allows for either that OR the same drive letter as the windows disk.

Any suggestions appreciated.

Greetings Dr. K,

Both 'USERPROFILE' and 'WINDIR' returned the letter to the hard drive for me, so not sure if this will help. Maybe check the Drive Type.

Code:

---

Option Explicit
   
Sub ex()
Dim TextString As String
    If Not AcceptableDrive(TextString) Then
        MsgBox TextString, vbCritical, "File not local!"
        ThisWorkbook.Close False
    End If
End Sub
   
Function AcceptableDrive(msg As String) As Boolean
Dim FSO                    As Object '<--- FileSystemObject
Dim fsoThisWorkbook_Drive  As Object '<--- Drive
   
Const DRV_UNKNOWN = 0
Const DRV_REMOVABLE = 1
Const DRV_FIXED = 2
Const DRV_NETWORK = 3
Const DRV_CDROM = 4
Const DRV_RAM = 5
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fsoThisWorkbook_Drive = FSO.GetDrive(FSO.GetDriveName(ThisWorkbook.Path))
   
    Select Case fsoThisWorkbook_Drive.DriveType
    Case 0, 1, 5
        msg = "It appears you have this file stored in a removable (or unknown) storage device."
    Case 2
        AcceptableDrive = True
        Exit Function
    Case 3
        msg = "It appears you have this file stored in a network folder."
    Case 4
        msg = "It appears you have this file stored in a CD."
    End Select
   
    msg = msg & "This tool can not be run from this location." _
        & vbLf & vbLf & "Copy the .xls file to your desktop, and open it from there."
End Function

---

Hope that helps,

Mark

Ah, a clever idea. I will give it a whirl on my next go around with this project.

Thank you.

As an FYI, in my company they image the single HD with a C: and D: particition

The O/S is imaged onto the C: and they configure My Documents, etc. on to the D: particition. Documents and Settings (=%USERPROFILE%) is on the C:

Maybe that's the way your UK is set up

As an FYI#2, they want us to store (and run) our docs, etc. on the H: drive, which is our personal space on the (backed up every night) Share drive.

I'm pretty sure that Mark's code would consider that a Network drive, so it might not work if that's their process.

You might have to test the drive for the user's My Documents to see, instead of testing for the drive of Windows


Paul

In the current iteration, all it does is make sure that the file is NOT in the default location. Seems to work pretty good, but does require Windows API to convert the drivepath to UNC.

If Const_Path is a public constant containing the UNC path:

Const_Path as String = "\\10.4.23.48\fpdc17\vol2\shared\Database\"

[VBA]Option Explicit
Option Private Module

Private Type UNIVERSAL_NAME_INFO
lpUniversalName As String * 256
End Type

Private Declare Function WNetGetUniversalName Lib "mpr" Alias "WNetGetUniversalNameA" _
(ByVal lpLocalPath As String, _
ByVal dwInfoLevel As Long, _
lpBuffer As Any, _
lpBufferSize As Long) As Long

Function GetUNCPath(Path As String) As String

Dim intStart As Integer
Dim lngResults As Long
Dim udtUNCPath As UNIVERSAL_NAME_INFO

lngResults = WNetGetUniversalName(Path, &H1, udtUNCPath, Len(udtUNCPath))

GetUNCPath = Replace(udtUNCPath.lpUniversalName, vbNullChar, "")

intStart = InStr(1, GetUNCPath, "\\")
If intStart > 1 Then GetUNCPath = Right(GetUNCPath, (Len(GetUNCPath) - intStart + 1))


End Function


Function OriginalLocation() As Boolean


OriginalLocation = False

If ThisWorkbook.Path & "\" = Const_Path Then OriginalLocation = True
If GetUNCPath(ThisWorkbook.Path) & "\" = Const_Path Then OriginalLocation = True


End Function[/VBA]