PDA

View Full Version : Checking to see if XLS file is local



Dr.K
05-19-2011, 07:04 AM
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:

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
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.

GTO
05-20-2011, 10:12 AM
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.


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

Dr.K
06-03-2011, 12:08 PM
Ah, a clever idea. I will give it a whirl on my next go around with this project.

Thank you.

Paul_Hossler
06-04-2011, 03:29 PM
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

Dr.K
06-15-2011, 12:08 PM
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\"

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