运行 Open 语句 (I/O) 以检查 .pdf 文件是否打开时，错误 70 权限被拒绝

Question

为了将 Excel 工作簿导出为 .PDF 文件，当 .PDF 文件已创建并打开时，我收到错误 70 权限被拒绝。

错误出现在下面这行代码中：

Open filename For Input Lock Read As #filenum

我尝试通过更改模式（必需。指定文件模式的关键字：追加、二进制、输入、输出或随机）来修改 Open 语句 (https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/open-statement)。如果未指定，则打开文件以进行随机访问。 ) 和锁（可选。指定其他进程对打开文件的操作限制的关键字：Shared、Lock Read、Lock Write 和 Lock Read Write。）。但我仍然收到错误消息。

Sub exportPDF_Click()

    Dim filename, filePath, PathFile As String
    filename = "Name of the File"
    filePath = ActiveWorkbook.Path

    On Error GoTo errHandler

    If Len(filename) = 0 Then Exit Sub

    PathFile = filePath & "\" & filename & ".pdf"
    ' Check if file exists, prompt overwrite
    If existFile(PathFile) Then

        If MsgBox("The file already exists." & Chr (10) & "Overwrite 
        existing file?", _
          vbQuestion + vbYesNo, "Existing File") = vbNo Then

            Do
            PathFile = Application.GetSaveAsFilename _
            (InitialFileName:=filePath, _
                FileFilter:="PDF Files (*.pdf), *.pdf", _
                Title:="Select a folder and a name to save the
                file."

            ' Handle cancel
            If PathFile = False Then Exit Sub

            ' Loop if new filename still exists
            Loop While existFile(PathFile)
        End If
    End If

    If fileOpened(PathFile) Then
        GoTo errHandler
    Else
        ThisWorkbook.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            filename:=PathFile, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True
    End If

    Exit Sub

errHandler:
        ' Display a message stating the file in use.
        MsgBox "The PDF file was not created." & Chr (10) & Chr (10) & 
        filename & ".pdf" & "has been opened by another user!"

End Sub

'=============================
Function existFile(rsFullPath As String) As Boolean
  existFile = CBool(Len(Dir$(rsFullPath)) > 0)
End Function
'=============================
'=============================
Function fileOpened(PathFile As String)

' Test to see if the file is open.
fileOpened = IsFileOpen(PathFile)
End Function
'=============================
'=============================

' This function checks to see if a file is open or not. If the file is
' already open, it returns True. If the file is not open, it returns
' False. Otherwise, a run-time error occurs because there is
' some other problem accessing the file.

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer

    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum '<--- error line
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.

    ' Check to see which error occurred.
    Select Case errnum

        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False

        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True

        ' Another error occurred.
        Case Else
            Error errnum
    End Select

End Function
'=============================

预期的结果是一个 MsgBox 说：

“未创建 PDF 文件。

File.pdf 的名称已被其他用户打开！"

我在这里缺少什么？

Answer 1

我想我明白你在这里想要做什么。一个问题是您允许用户指定一个新文件名，但随后不检查该文件是否存在或是否可写等。我在上面的 cmets 中注意到了一些其他可能的错误，例如您无法比较 @987654321 @ 而不引发 Type 13 不匹配，如果您传递不存在文件的名称，您可能会在 IsFileOpen 函数中得到 53 Bad FileName 或 Number。

摆脱fileOpened，它除了作为IsFileOpen 的包装之外没有任何用处，所以只需使用IsFileOpen 代替。在您的主程序中摆脱笨拙的On Error。如果需要，我们当然可以重新添加有针对性的错误处理，但我认为不需要。

我已经划分/重构了下面的代码，我认为这将解决问题。特别是我写了另一个函数fileIsWriteable 并用它来包装existFile 和IsFileOpen 函数，以及消息框提示。

然后主过程针对初始PathFile 调用此函数。如果文件不可写，那么我们调用另一个新函数getNewFileName，它确保用户选择一个可写（解锁或不存在）的文件名。

我认为这是不言自明的，但如果我需要澄清，请告诉我。

Option Explicit

Sub exportPDF_Click()

Dim filename$, filePath$, PathFile$
Dim fdlg As FileDialog
filename = "Book1"
filePath = "C:\debug\"
Dim mb As VbMsgBoxResult
If Len(filename) = 0 Then Exit Sub

PathFile = filePath & "\" & filename & ".pdf"

If Not fileIsWriteable(PathFile) Then
    ' File is NOT writeable.
    PathFile = getNewFileName(filePath)
End If
If Len(PathFile) > 0 Then
    ThisWorkbook.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        filename:=PathFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
End If
End Sub

Function fileIsWriteable(filePath As String) As Boolean
Dim mb As VbMsgBoxResult
    If existFile(filePath) Then
        If IsFileOpen(filePath) Then
            MsgBox filePath & "has been opened by another user!"
            fileIsWriteable = False
        Else
            mb = MsgBox(filePath & " already exists." & Chr(10) & "Overwrite existing file?", _
                vbQuestion + vbYesNo, "Existing File")
            fileIsWriteable = mb = vbYes
        End If
    Else
        ' file either doesn't exist, or exists but isn't open/locked, so we should
        ' be able to write to it:
        fileIsWriteable = True
    End If
End Function

Function getNewFileName(filePath As String) As String
Dim fn$
Do
    fn = Application.GetSaveAsFilename( _
            InitialFileName:=filePath, _
            FileFilter:="PDF Files (*.pdf), *.pdf", _
            Title:="Select a folder and a name to save the file.")
    If fn = "False" Then Exit Function
Loop While Not fileIsWriteable(fn)
getNewFileName = fn
End Function

Function existFile(rsFullPath As String) As Boolean
  existFile = CBool(Len(Dir$(rsFullPath)) > 0)
End Function

Function IsFileOpen(filename As String)
' This function checks to see if a file is open or not. If the file is
' already open, it returns True. If the file is not open, it returns
' False. Otherwise, a run-time error occurs because there is
' some other problem accessing the file.
Dim filenum As Integer, errnum As Integer

On Error Resume Next   ' Turn error checking off.
filenum = FreeFile()   ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum '<--- error line
Close filenum          ' Close the file.
errnum = Err           ' Save the error number that occurred.
On Error GoTo 0        ' Turn error checking back on.

' Check to see which error occurred.
Select Case errnum

    ' No error occurred.
    ' File is NOT already open by another user.
    Case 0
     IsFileOpen = False

    ' Error number for "Permission Denied."
    ' File is already opened by another user.
    Case 70
        IsFileOpen = True

    ' Another error occurred.
    Case Else
        Err.Raise errnum
End Select

End Function

注意：我认为这可以通过使用Application.FileDialog 而不是Application.GetSaveAsFileName 来进一步改进，但我不记得如何使用该方法强制执行文件过滤器。