为了将Excel工作簿导出到.PDF文件，当.PDF文件已经创建并打开时，我收到错误70权限被拒绝。
错误出现在下面的代码行中：
Open filename For Input Lock Read As #filenum
我 https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/open-statement 尝试通过更改模式(必需。指定文件模式的关键字：追加、二进制、输入、输出或随机。如果未指定，则打开文件以进行随机访问。和锁(可选。指定其他进程对打开的文件限制的操作的关键字：共享、锁定读取、锁定写入和锁定读写。但我仍然收到错误。
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
'=============================
预期结果是一个消息框，上面写着：
"未创建 PDF 文件。
文件名.pdf已被其他用户打开！
我在这里错过了什么？
我想我明白你在这里想做什么。一个问题是你允许用户指定一个新的文件名，但随后不检查该文件是否存在或可写等。我在上面的评论中指出了其他一些可能的错误，例如，如果不引发类型 13 不匹配，您将无法比较PathFile = False，如果您传递不存在的文件的名称，您可能会在IsFileOpen函数中获得 53 错误文件名或数字。
摆脱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可以进一步改进这一点，但我不记得如何使用该方法强制执行文件过滤器。