如何检查用户是否已打开"从文件中选择编辑"对话框

Question

我需要建立一个检查，看看用户通过msofiledialogopen选择的工作簿是否已经在用户计算机上打开。如何引用此工作簿，而不是使用Workbooks("Example.xlsx"(这样的固定名称？

edit：文件位于Sharepoint上，这可能解释了为什么我不能如此容易地从文件路径中提取名称。

到目前为止，我的代码如下所示：

Dim ItemSelected As String, ItemSelectedName As String
Dim wkb as Workbook
With Application.FileDialog(msoFileDialogOpen) 
.AllowMultiSelect = False
.Title = "Select Workbook"
.ButtonName = ""

ItemSelected = .SelectedItems(1)
ItemSelectedName = Right$(ItemSelected, Len(ItemSelected) - InStrRev(ItemSelected, ""))
End With
If Workbooks(ItemSelectedName) Is Nothing Then
Set wkb = Workbooks.Open(ItemSelected)
Else
MSGBox "File already open"
Exit Sub
End If

Answer 1

这就是我的工作方式"检查"；如果在我的某个工作簿中打开了一个文件。

请注意，我和您做的几乎相同，只是我首先通过我的两个助手函数检查文件是否存在，然后尝试打开它以查看它是否已经打开，而不是检查文件名。

Option Explicit
Sub open_file()
Dim wbMasterfile As Workbook, wbThisBook As Workbook
Dim sFullFilePath As String, filnavn As String
Dim masterfileAlreadOpen As Boolean

sFullFilePath = Trim(ThisWorkbook.Worksheets("Innstillinger").Range("H2"))

filnavn = Right(sFullFilePath, Len(sFullFilePath) - Application.WorksheetFunction.Max( _
InStrRev(sFullFilePath, "", -1, vbBinaryCompare), _
InStrRev(sFullFilePath, "/", -1, vbBinaryCompare)))

If sharepointFileExists(sFullFilePath) Or fileOnDisk(sFullFilePath) Then

' Open the file if it's not already open
On Error Resume Next
Set wbMasterfile = Application.Workbooks(filnavn)
On Error GoTo 0

If wbMasterfile Is Nothing Then
Set wbMasterfile = Workbooks.Open(Filename:=sFullFilePath, ReadOnly:=True)
masterfileAlreadOpen = False
Else
masterfileAlreadOpen = True
End If

' What you want to do...

If Not wbMasterfile Is Nothing And Not masterfileAlreadOpen Then
wbMasterfile.Close SaveChanges:=False
End If
Else
MsgBox Prompt:="Check that the filename and -path (in the sheet ""Innstillinger"") are correct.", _
Title:="Wrong path or name.", Buttons:=vbExclamation
End If

End Sub ' open_file
Function sharepointFileExists(ByVal strUrl As String) As Boolean
On Error GoTo ErrorHandler
Dim oHttp As Object

Set oHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
oHttp.Open "HEAD", strUrl, False
oHttp.Send
'Debug.Print oHttp.Status
sharepointFileExists = CBool(oHttp.Status = 200)
Exit Function
ErrorHandler:
'Debug.Print Err.Number & " - " & Err.Description
'Debug.Print "Feil: - " & oHttp.Status
sharepointFileExists = False
End Function ' sharepointFileExists
Function fileOnDisk(ByVal strPath As String) As Boolean
On Error GoTo ErrorHandler

With CreateObject("Scripting.FileSystemObject")
fileOnDisk = .FileExists(strPath)
End With
Exit Function
ErrorHandler:
' Debug.Print Err.Number & " - " & Err.Description
fileOnDisk = False
End Function ' fileOnDisk

Answer 2

试试这个(未测试(

Sub trySelectingItem2()
Dim ItemSelected As String, ItemSelectedName As String
Dim wkb As Workbook

With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Select Workbook"
.ButtonName = ""

ItemSelected = .SelectedItems(1)
'ItemSelectedName = Right$(ItemSelected, Len(ItemSelected) - InStrRev(ItemSelected, ""))
ItemSelectedName = CreateObject("Scripting.FileSystemObject").GetFilename(ItemSelectedName)
End With

On Error Resume Next
Set wkb = Workbooks(ItemSelectedName)
On Error GoTo 0

If wkb Is Nothing Then
Set wkb = Workbooks.Open(ItemSelected)
ElseIf LCase(wkb.FullName) = LCase(ItemSelected) Then
MsgBox "File already open"
Exit Sub
Else
MsgBox "Another file with matching name is open"
Exit Sub
End If
End Sub