View Full Version : 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:
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.
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
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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.