打开文件时比较path的VBA代码

我想比较它打开时的文件path。

当打开时，比较path是“\ server \ myfolder1 \ myfolder2 \”。 如果为TRUE，则什么都不做。 如果FALSE，则显示MSGBOX并closures文件。

我尝试了以下代码：

Private Sub Workbook_Open() Dim LocalFile As String LocalFile = "\\Server\folder1\folder2" If ActiveWorkbook.Path <> LocalFile Then MsgBox ("This file is not original") End If Range("B2").Value = ActiveWorkbook.Path End Sub 

当我复制到我的本地光盘时，它工作。 但是当我从快捷方式或映射指向我的networkingpath打开，它不起作用。

提示？

Answer 1

尝试将驱动器号转换为完整的networkingpath。 Microsoft参考代码在这里 。

以下是转换为完整networkingpath的function代码

 Option Explicit Declare Function WNetGetConnection32 Lib "MPR.DLL" Alias _ "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal _ lpszRemoteName As String, lSize As Long) As Long Sub Test() If Not IsError(GetNetPath("Z")) Then MsgBox GetNetPath("Z") Else MsgBox "Error" End If End Sub Function GetNetPath(ByVal DriveLetter As String) Dim lpszRemoteName As String * 255 Dim cch As Long Dim lStatus As Long DriveLetter = DriveLetter & ":" cch = 255 lStatus = WNetGetConnection32(DriveLetter, lpszRemoteName, cch) If lStatus& = 0 Then GetNetPath = application.clean(lpszRemoteName) Else GetNetPath = CVErr(xlErrNA) End If End Function 

 Private Sub Workbook_Open() Dim LocalFile As String Dim CurrentPath As String Dim CurrentDrive As String * 1 Dim CurrentDriveMap As Variant LocalFile = "\\Server\folder1\folder2" CurrentPath = ThisWorkbook.Path CurrentDrive = CurrentPath CurrentDriveMap = GetNetPath(CurrentDrive) If Not IsError(CurrentDriveMap) Then CurrentPath = CurrentDriveMap & Mid(CurrentPath, 3, Len(CurrentPath)) End If If CurrentPath <> LocalFile Then GoTo NotOriginalHandler End If Range("B2").Value = ActiveWorkbook.Path Exit Sub NotOriginalHandler: MsgBox ("This file is not original") ThisWorkbook.Close End Sub 

Answer 2

试试下面

 Private Sub Workbook_Open() ChDir ("\\172.16.5.4\BTS-Team") If ActiveWorkbook.Path <> CurDir Then MsgBox ("This file is not original") End If Range("B2").Value = ActiveWorkbook.Path End Sub