VBA代码触发Error 70权限拒绝：客户端异常本地正常求助

数据老陈

2026-6-18

权限拒绝Error 70问题排查与修复建议

客户的VBA代码多年运行无异常，近期所有同事电脑均突然触发Error 70权限拒绝错误，但我在本地运行同款代码完全正常。该代码通过auto_open创建日志文件、auto_close删除日志文件实现文件互斥访问，防止多人同时打开同一文件。本人对Scripting Runtime及相关对象了解有限，主要依赖示例代码编写，现寻求技术协助。

完整代码

Option Explicit
Private opndFile As String, oflePath As String


Sub auto_open()
    Dim fs As New FileSystemObject
    Dim flePath As String
    Dim packPath As String
    Dim bkNme As String
    Dim ws As Worksheet, s As Worksheet
    Dim n As Long
    Dim nDatR As Long, nCntr As Long
    
    Application.ScreenUpdating = False
    For Each s In Sheets
        If s.Name = "Main Menu" Or s.Name = "Commodity" Or s.Name = "Sys" Or s.Name = "CommodCatg" Or s.Name = "Fabric Composition" Or s.Name = "Date" Then
            With s
                 .Visible = True
                 .Activate
                 Debug.Print s.Name
                .Unprotect Password:="bcts2601"
             End With
        End If
    Next s
    
    chkIfFldrsExist
    
    If (Right(ActiveWorkbook.Path, 20) = "\EUROTEX\Commodities") Then
        oflePath = Replace(ActiveWorkbook.Path, "Commodities", "OpenedFiles")
        opndFile = Replace(ActiveWorkbook.Name, "xlsm", "f")

    ElseIf (Right(ActiveWorkbook.Path, 8) = "\EUROTEX") Then
        oflePath = ActiveWorkbook.Path & "\OpenedFiles"
        opndFile = Replace(ActiveWorkbook.Name, "xlsm", "f")
    Else
        oflePath = Replace(ActiveWorkbook.Path, "Templates", "OpenedFiles")
        opndFile = Replace(ActiveWorkbook.Name, "xlsm", "f")
    End If
    
    If opndFile <> "Commodities.f" Then
        If (fs.FileExists(oflePath & "\" & opndFile)) Then 'oFlg.f"
            Application.ScreenUpdating = True
            MsgBox "This file is open by another user ..."
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            ActiveWorkbook.Close False
            Application.DisplayAlerts = True
        Else
            createOpenFlag
        End If
    End If
    
    Set fs = Nothing


    Application.DisplayAlerts = False
     
     For Each s In Sheets
       If s.Name = "Main Menu" Or s.Name = "Commodity" Or s.Name = "Sys" Or s.Name = "CommodCatg" Or s.Name = "Fabric Composition" Or s.Name = "Date" Then

           With s
                .Activate
               .Unprotect Password:="bcts2601"
                If s.Name = "Commodity" Then
                    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData
                    .EnableAutoFilter = True
                    Application.EnableEvents = False
                    n = .Range("E10").CurrentRegion.Rows.Count + 9
                    .Range("D10") = 0
                    .Range("D11:D" & n).FormulaR1C1 = _
                        "=IF(CONCATENATE(RC[1],RC[2],RC[3],RC[4],RC[5],RC[6],RC[7],RC[8],RC[9],RC[10],RC[11],RC[12],RC[13],RC[14],RC[15],RC[16],RC[17],RC[18],RC[19],RC[20],RC[21],RC[22],RC[23],RC[24],RC[25],RC[26],RC[27],RC[28],RC[29],RC[30],RC[31],RC[32])="""","""",R[-1]C+1)"
                    Application.EnableEvents = True
                    
                End If
                If s.Name = "Commodity" Then
                    .Protect Password:="bcts2601", UserInterfaceOnly:=True, DrawingObjects:=True, contents:=True, Scenarios:=True, AllowSorting:=True, AllowFiltering:=True
                Else
                    .Protect Password:="bcts2601", UserInterfaceOnly:=True
                End If
                .EnableOutlining = True
                .EnableSelection = xlNoRestrictions
               
            End With
        End If
    Next s
    
    sCommodity.Unprotect Password:="bcts2601"

    sCommodity.Activate
    n = Application.WorksheetFunction.Count(Range("D:D"))
    sCommodity.Range("D:D").SpecialCells(xlCellTypeFormulas, xlNumbers).Count
    If n > 1 Then
        nDatR = n + 9
        nCntr = 11
        Do Until nCntr > nDatR
            If sCommodity.Range("AC" & nCntr).Value = "" Then
                sCommodity.Range("AC" & nCntr).Value = DateSerial(Year:=2050, Month:=12, Day:=31)
            End If
            nCntr = nCntr + 1
        Loop
    End If
    If n > 2 Then
        sCommodity.AutoFilter.Sort.SortFields.Clear
        sCommodity.AutoFilter.Sort.SortFields.Add Key:= _
            sCommodity.Range("AC10:AC1009"), SortOn:=xlSortOnValues, Order:=xlAscending, _
            DataOption:=xlSortTextAsNumbers
        With sCommodity.AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If

    For Each s In Sheets
       With s
            .Activate
            If ActiveSheet.Name = "Commodity" Then
                With ActiveWindow
                    If .FreezePanes Then .FreezePanes = False
                    .SplitColumn = 6
                    .SplitRow = 10
                    .FreezePanes = True
                End With
            Else
                With ActiveWindow
                    If .FreezePanes Then
                        .FreezePanes = False
                        .SplitColumn = 0
                        .SplitRow = 0
                    End If
                End With
            End If
        End With
    Next s


    Application.DisplayAlerts = True

    
    For Each s In Sheets
        With s
            .Activate
            .Range("A1").Select
            ActiveWindow.ScrollColumn = 1
            ActiveWindow.ScrollRow = 1
        End With
    Next s

    packPath = Application.ActiveWorkbook.Path
    sSys.Range("B1").Value = packPath
    bkNme = GetBook
    
    If bkNme = "Commodities.xlsm" Then
        sSys.Visible = xlHidden
        sDate.Visible = xlHidden
        sFabricComposition.Visible = xlHidden
        sCommodCatg.Visible = xlHidden
        sCommodity.Visible = xlHidden
        sMM.Visible = True
        sMM.Activate
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
        sMM.Range("A1").Select
        ActiveSheet.Shapes("prntRngeRectngle").Visible = False
        ActiveSheet.Shapes("xprtRngeRectngle").Visible = False
        ActiveSheet.Shapes("createwkBk").Visible = True
        ActiveWindow.DisplayWorkbookTabs = False
    Else
        sMM.Visible = True
        sCommodity.Visible = True
        sFabricComposition.Visible = True
        sSys.Visible = xlSheetVeryHidden
        sDate.Visible = xlSheetHidden
        sCommodCatg.Visible = xlVeryHidden
        sMM.Activate
        ActiveWindow.ScrollColumn = 1
        ActiveWindow.ScrollRow = 1
        sMM.Range("A1").Select
        ActiveSheet.Shapes("prntRngeRectngle").Visible = True
        ActiveSheet.Shapes("xprtRngeRectngle").Visible = True
        ActiveSheet.Shapes("createwkBk").Visible = False

        ActiveWindow.DisplayWorkbookTabs = True
    End If
    Application.ScreenUpdating = True
End Sub

Function GetBook() As String
    GetBook = ActiveWorkbook.Name
End Function

Function createOpenFlag()
    Dim fs As New FileSystemObject
    Dim txtf As Object
    Set txtf = fs.CreateTextFile(oflePath & "\" & opndFile, True)
    txtf.WriteLine Environ$("Username")
    Set fs = Nothing

End Function

Sub auto_close()
    On Error Resume Next
    Kill oflePath & "\" & opndFile
End Sub

Sub createTmpFoldr()
    Dim FSO As Scripting.FileSystemObject
    Dim FolderPath As String
    Dim rF As New FileSystemObject
    Dim DocumentsPath As String


    Set FSO = New Scripting.FileSystemObject
    FolderPath = Environ("UserProfile") & "\Temp\"
    If Right(FolderPath, 1) <> "\" Then
        FolderPath = FolderPath & "\"
    End If

    If Not rF.FolderExists(FolderPath) Then MkDir FolderPath


End Sub


Sub submitComposition()
    Dim curr As Worksheet
    Dim currAddr As String
    
    If Not (sFabricComposition.Range("F16").Value = 100) Then
        MsgBox "The Total %Composition of materials must add up to 100%. Please correct this.", vbExclamation, "Total %Composition"
        Exit Sub
    End If
    
    Set curr = Worksheets(sSys.Range("DA5").Value)
    currAddr = sSys.Range("DA2").Value
    curr.Activate
    curr.Range(currAddr).Activate
    curr.Range(currAddr).Value = sFabricComposition.Range("E20").Value
End Sub

Sub navSht()
    Dim curr As Worksheet
    
    Set curr = Worksheets(sSys.Range("H2").Value)
    curr.Activate

End Sub


Sub navHome()
    sMM.Activate
End Sub


Sub setComposition()
    Dim sht As Worksheet
    Dim actCol As Long, actRow As Long, actAddr As String

    Set sht = ActiveWorkbook.ActiveSheet
    actAddr = ActiveCell.Address
    actCol = sht.Range(actAddr).Column
    actRow = sht.Range(actAddr).Row
    
    If (actCol <> sSys.Range("DA8").Value) Or (actRow < sSys.Range("DA11").Value) Or (actRow > sSys.Range("DA14").Value) Then
        MsgBox "Insertion of Total %Composition of materials is not allowed here.", vbExclamation, "Invalid Entry"
        Exit Sub
    End If
    
    sSys.Range("DA2").Value = actAddr
    sSys.Range("DA5").Value = sht.Name
    sFabricComposition.Activate
    
    
End Sub

Sub chkIfFldrsExist()
    Dim rF As New FileSystemObject
    Dim DocumentsPath As String

    sSys.Range("B1").Value = cmdTmplte.Path
    DocumentsPath = sSys.Range("B24").Value
    If Not rF.FolderExists(DocumentsPath) Then MkDir DocumentsPath
    DocumentsPath = sSys.Range("B25").Value
    If Not rF.FolderExists(DocumentsPath) Then MkDir DocumentsPath
    DocumentsPath = sSys.Range("B26").Value
    If Not rF.FolderExists(DocumentsPath) Then MkDir DocumentsPath
    DocumentsPath = sSys.Range("B27").Value
    If Not rF.FolderExists(DocumentsPath) Then MkDir DocumentsPath
    DocumentsPath = sSys.Range("B28").Value
    If Not rF.FolderExists(DocumentsPath) Then MkDir DocumentsPath
    DocumentsPath = sSys.Range("B29").Value
    If Not rF.FolderExists(DocumentsPath) Then MkDir DocumentsPath

End Sub

问题分析与修复步骤

1. 核心原因排查

Error 70权限拒绝大概率是文件/文件夹权限不足或文件被锁定导致，结合代码逻辑，重点检查：

OpenedFiles文件夹的读写权限
残留的日志文件是否被系统锁定
Scripting Runtime组件是否正常

2. 具体修复方案

（1）文件夹权限验证

定位OpenedFiles文件夹，右键→属性→安全
确认所有用户组拥有读取、写入、修改权限
若为网络共享文件夹，额外检查共享权限设置

（2）修复文件锁定问题

原代码auto_close用Kill命令删除文件，容易因未释放句柄导致锁定，替换为FileSystemObject的安全删除逻辑：

Sub auto_close()
    On Error Resume Next
    Dim fs As New FileSystemObject
    If fs.FileExists(oflePath & "\" & opndFile) Then
        fs.DeleteFile oflePath & "\" & opndFile, True '强制删除锁定文件
    End If
    Set fs = Nothing
End Sub

（3）增强日志文件创建的容错性

在createOpenFlag中添加文件夹存在检查和错误处理：

Function createOpenFlag() As Boolean
    createOpenFlag = False
    Dim fs As New FileSystemObject
    Dim txtf As Object
    
    '确保目标文件夹存在
    If Not fs.FolderExists(oflePath) Then
        fs.CreateFolder oflePath
    End If
    
    On Error GoTo Cleanup
    Set txtf = fs.CreateTextFile(oflePath & "\" & opndFile, True)
    txtf.WriteLine Environ$("Username")
    createOpenFlag = True
Cleanup:
    Set txtf = Nothing
    Set fs = Nothing
End Function

（4）修复路径判断逻辑

原代码用固定长度的Right函数判断路径，容易因路径长度变化出错，替换为更可靠的匹配：

Dim basePath As String
basePath = ActiveWorkbook.Path
If InStr(basePath, "\EUROTEX\Commodities") > 0 Then
    oflePath = Replace(basePath, "\Commodities", "\OpenedFiles")
ElseIf InStr(basePath, "\EUROTEX") > 0 Then
    oflePath = basePath & "\OpenedFiles"
Else
    oflePath = Replace(basePath, "\Templates", "\OpenedFiles")
End If
opndFile = Replace(ActiveWorkbook.Name, ".xlsm", ".f") '添加点号避免误匹配

（5）验证Scripting Runtime引用

打开VBA编辑器→工具→引用
勾选Microsoft Scripting Runtime，若找不到则浏览选择C:\Windows\System32\scrrun.dll

内容的提问来源于stack exchange，提问作者Inet Kemp