excel - 几个月没有出现问题后，VBScript 突然无法运行宏

Question

基本问题

我有以下每天按计划运行的任务:批处理文件 --> vbscript --> 两个宏

但是，在没有出现问题几个月后，我现在收到以下错误:

1004:无法运行宏“M1DelimiterSetupErrDescription”。该宏可能在此工作簿中不可用，或者所有宏可能被禁用。

以下 VBScript 中的这一行发生上述错误:

ErrDescriptionResult = xlApp.Run("M1DelimiterSetupErrDescription")

<小时/>

我尝试过的

通过反复试验，我发现了几件事:

• 可以手动运行宏，包括 M1DelimiterSetupErrDescription
• 以非只读方式打开 .xlsm 文件无法解决问题
• 将有问题的 ErrDescriptionResult = xlApp.Run ("M1DelimiterSetupErrDescription") 移至代码中较早的位置，即 ErrNumberResult = xlApp.Run ("M1DelimiterSetupErrNumber")线，使其运行没有问题。
• 打开 .xlsm 文件确实会显示黄色的“启用宏”按钮/栏，但按下按钮后不会显示受信任文档提示。我不知道为什么会这样 - 这很不寻常。

<小时/>

批处理文件:

pushd (directory) 
cscript "Provider File Automation.vbs"
IF ERRORLEVEL 1 EXIT /b %ERRORLEVEL%

VBScript:

Option Explicit

  Dim xlApp 
  Dim xlBook
  Dim ErrNumberResult
  Dim ErrDescriptionResult


  'Have to use this for the Get Excel.Application lines
  On Error Resume Next


  'Make sure there's no error pre-registered for some reason
  If Err.Number <> 0 Then Err.Clear
  ErrNumberResult = 0


  'Get Excel ready to work
  Set xlApp = GetObject("","Excel.Application")
  If xlApp <> "Microsoft Excel" Then Msgbox xlApp 
  If xlApp is Nothing Then Set xlApp = CreateObject("Excel.Application")


  'Check for errors
  If Err.Number <> 0 Then
      Msgbox Err.Number & ": " & Err.Description & " The script will now quit."
      WScript.Quit Err.Number
  End If


  'Change the delimiter
  Set xlBook = xlApp.Workbooks.Open("(directory)\Provider File Automation v1.05.xlsm", 0, True)
  ErrNumberResult = xlApp.Run ("M1DelimiterSetupErrNumber")
  ErrDescriptionResult = xlApp.Run ("M1DelimiterSetupErrDescription")
  If xlApp.Workbooks.Count = 1 Then xlApp.DisplayAlerts = False
  xlApp.Quit
  xlApp.DisplayAlerts = True


  'Check for errors
  If ErrNumberResult <> 0 Then
      Msgbox ErrNumberResult & ": " & ErrDescriptionResult & " The script will now quit."
      WScript.Quit ErrNumberResult
  End If
  Set xlBook = Nothing 
  Set xlApp = Nothing


  'Get Excel ready to work again
  Set xlApp = GetObject("","Excel.Application")
  If xlApp <> "Microsoft Excel" Then Msgbox xlApp
  If xlApp is Nothing Then Set xlApp = CreateObject("Excel.Application")


  'Check for errors
  If Err.Number <> 0 Then
      Msgbox Err.Number & ": " & Err.Description & " The script will now quit."
      WScript.Quit Err.Number
  End If


  'Create the provider file and change the delimiter back
  Set xlBook = xlApp.Workbooks.Open("(directory)\Provider File Automation v1.05.xlsm", 0, True) 
  ErrNumberResult = xlApp.Run ("M2ProviderFileAutomationErrNumber")
  ErrDescriptionResult = xlApp.Run ("M2ProviderFileAutomationErrDescription")
  If xlApp.Workbooks.Count = 1 Then xlApp.DisplayAlerts = False
  xlApp.Quit
  xlApp.DisplayAlerts = True


  'Check for errors
  If ErrNumberResult <> 0 Then
      Msgbox ErrNumberResult & ": " & ErrDescriptionResult & " The script will now quit."
      WScript.Quit ErrNumberResult
  End If
  Set xlBook = Nothing 
  Set xlApp = Nothing

.xlsm 模块:

Option Explicit

Private Declare Function SetLocaleInfo _
Lib "kernel32" Alias "SetLocaleInfoA" ( _
ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String) As Boolean

Private Declare Function GetUserDefaultLCID% Lib "kernel32" ()

Private Const LOCALE_SLIST = &HC
Private Const LOCALE_NAME_USER_DEFAULT = vbNullString
'Private Const LOCALE_USER_DEFAULT = "0x0400"

'Get Locale Info
Private Declare Function GetLocaleInfoEx _
Lib "kernel32" ( _
ByVal lpLocaleName As String, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long) As Long

Private Declare Function GetLastError Lib "kernel32" () As Long


Function M1DelimiterSetupErrNumber() As Long

    M1ChangeDelimiterToPipe
    M1DelimiterSetupErrNumber = Err.Number

End Function


Function M1DelimiterSetupErrDescription() As String

    M1DelimiterSetupErrDescription = Err.Description

End Function


Sub M1ChangeDelimiterToPipe()

Dim lngTryAgainCtr As Long
Dim strListSeparator As String
Dim lpLCData As String
Dim Long1 As Long

    lngTryAgainCtr = 0

TryAgain:
    lngTryAgainCtr = lngTryAgainCtr + 1

    'Change delimiter to pipe
'    Call SetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SLIST, "|")
    Call SetLocaleInfo(GetUserDefaultLCID(), LOCALE_SLIST, "|")

    'Check to make sure setting separator as pipe worked correctly
    Long1 = GetLocaleInfoEx(LOCALE_NAME_USER_DEFAULT, LOCALE_SLIST, lpLCData, 0)

    'Make sure that Long1 came out with an appropriate value, exit with error number if it didn't
    If Long1 = 0 Then
        If lngTryAgainCtr < 3 Then
            GoTo TryAgain
        Else
            Err.Number = 1
            Err.Description = "GetLocaleInfoEx() failed, returned value of 0"
'            MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
            Exit Sub
        End If
    Else
        strListSeparator = String$(Long1, 0)
        Long1 = GetLocaleInfoEx(LOCALE_NAME_USER_DEFAULT, LOCALE_SLIST, strListSeparator, Long1)

        If InStr(strListSeparator, "|") = 0 Then
            If lngTryAgainCtr < 3 Then
                GoTo TryAgain
            Else
                If GetLocaleInfoEx(LOCALE_NAME_USER_DEFAULT, LOCALE_SLIST, strListSeparator, Long1) <> 0 Then Debug.Print GetLastError
                Err.Number = 2
                Err.Description = "Changing list separator to pipe unsuccessful."
'                MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
                Exit Sub
            End If
        End If

        'Close workbook to allow Excel to reset its memory of delimiter
        'Show alerts if more workbooks open
'        If Workbooks.Count = 1 Then Application.DisplayAlerts = False
'        Application.Quit
    End If

End Sub


Function M2ProviderFileAutomationErrNumber() As Long

    M2ProviderFileAutomation
    M2ProviderFileAutomationErrNumber = Err.Number

End Function


Function M2ProviderFileAutomationErrDescription() As String

    M2ProviderFileAutomationErrDescription = Err.Description

End Function


Sub M2ProviderFileAutomation()
'
' M2ProviderFileAutomation Macro
'
' Keyboard Shortcut: Ctrl+Shift+W
'
Dim strProvFileSaveLoc As String 'Full File Name
Dim strProvFileUnzipped As String 'Location of Text File after Unzipping
Dim strProvFileEITcsv As String 'Location where csv is saved
Dim strProvFileWebAddr As String 'web address
Dim oXMLHTTP As Object
Dim Long1 As Long
Dim strListSeparator As String
Dim lpLCData As String

    'Check to make sure Part 1 ran correctly and separator is pipe
    Long1 = GetLocaleInfoEx(LOCALE_NAME_USER_DEFAULT, LOCALE_SLIST, lpLCData, 0)

    'Make sure that Long1 came out with an appropriate value, exit with error number if it didn't
    If Long1 = 0 Then
        Err.Number = 1
        Err.Description = "GetLocaleInfoEx() failed, returned value of 0"
'        MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
        Exit Sub
    Else
        strListSeparator = String$(Long1, 0)
        Long1 = GetLocaleInfoEx(LOCALE_NAME_USER_DEFAULT, LOCALE_SLIST, strListSeparator, Long1)

        If InStr(strListSeparator, "|") = 0 Then
            If GetLocaleInfoEx(LOCALE_NAME_USER_DEFAULT, LOCALE_SLIST, strListSeparator, Long1) <> 0 Then Debug.Print GetLastError
            Err.Number = 3
            Err.Description = "Part 2 detects non-pipe list separator."
'            MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
            Exit Sub
        Else
            'Makes things go faster
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            'Save the provider file
            strProvFileWebAddr = (web address)
            strProvFileSaveLoc = (path)
            strProvFileUnzipped = (path)

            'Delete any in the way files
            'Automated provider file folder - unzipped folder contents
            If Dir(strProvFileUnzipped) <> "" Then
                Kill strProvFileUnzipped
                RmDir (path1)
                RmDir (path2)
                RmDir (path3)
                RmDir (path4)
            End If
            'archive zip file
            If Dir((potentially existing archive file path)) <> "" Then Kill ((potentially existing archive file path))
            'archive text file
            If Dir((potentially existing archive file2 path)) <> "" Then Kill ((potentially existing archive file2 path))

            'You can also set a ref. to Microsoft XML, and Dim oXMLHTTP as MSXML2.XMLHTTP
            Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
            oXMLHTTP.Open "GET", strProvFileWebAddr, False 'Open socket to get the website
            oXMLHTTP.Send 'send request

            'Wait for request to finish
            Do While oXMLHTTP.readyState <> 4
                DoEvents
            Loop

            Dim oResp() As Byte
            oResp = oXMLHTTP.responseBody 'Returns the results as a byte array

            'Create local file and save results to it
            Dim Int1 As Integer
            Int1 = FreeFile()
            If Dir(strProvFileSaveLoc) <> "" Then Kill strProvFileSaveLoc
            Open strProvFileSaveLoc For Binary As #Int1
            Put #Int1, , oResp
            Close #Int1

            'Clear memory
            Set oXMLHTTP = Nothing

            'Unzip zipped provider file
            Dim objShell As Object
            Set objShell = CreateObject("Shell.Application")
            'Has to be variants, can't be strings
            Dim varFLProviderFileAutomationFolder As Variant
            varFLProviderFileAutomationFolder = (path)
            Dim varProviderFileSaveLocation As Variant
            varProviderFileSaveLocation = strProvFileSaveLoc
            objShell.Namespace(varFLProviderFileAutomationFolder).CopyHere objShell.Namespace(varProviderFileSaveLocation).items
            On Error Resume Next
            Dim objFileSystemObject As Object
            Set objFileSystemObject = CreateObject("scripting.filesystemobject")
            objFileSystemObject.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
            On Error GoTo 0

            'Excel changes to provider file
            Workbooks.OpenText strProvFileUnzipped, DataType:=xlDelimited, _
            TextQualifier:=xlTextQualifierDoubleQuote, Other:=True, Otherchar:="|", FieldInfo:=Array(Array(1, 2), _
            Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2), Array(9, 2), _
            Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15, 2), Array(16, 2), _
            Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), Array(22, 2), Array(23, 2), _
            Array(24, 2))

            ActiveWorkbook.Sheets(1).Rows(1).Delete
            ActiveWorkbook.Sheets(1).Columns("B:C").Replace What:="""", Replacement:="'", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
            ActiveWorkbook.Sheets(1).Columns("G").Replace What:="""", Replacement:="'", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

            strProvFileEITcsv = (path)
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=strProvFileEITcsv, FileFormat:=xlCSV, local:=True
            Application.DisplayAlerts = True
            'Don't have permission to copy from folder
            Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs Filename:=(path), FileFormat:=xlCSV, local:=True
            Application.DisplayAlerts = True
            ActiveWorkbook.Close False

            'Change delimiter back to comma
            Call SetLocaleInfo(GetUserDefaultLCID(), LOCALE_SLIST, ",")

            'Move zip file to archive
            If Dir((potential archive file path)) = "" Then
                Name strProvFileSaveLoc As (potential archive file path)
            Else
                Err.Number = 4
                Err.Description = "Zip file already exists in archive."
'                MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
            End If

            'Move txt file to archive
            If Dir((potential archive file2 path)) = "" Then
                Name strProvFileUnzipped As (potential archive file2 path)
            Else
                If Err.Number <> 4 Then
                    Err.Number = 5
                    Err.Description = "Text file already exists in archive."
'                    MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
                    GoTo SkipRMDir
                Else
                    Err.Number = 6
                    Err.Description = "Zip and text files already exists in archive."
'                    MsgBox Err.Number & ": " & Err.Description & " The script will now quit."
                    GoTo SkipRMDir
                End If
            End If

            'Cleanup
            RmDir (path1)
            RmDir (path2)
            RmDir (path3)
            RmDir (path4)

'            MsgBox "Provider file done."

SkipRMDir:
            Application.ScreenUpdating = True
            Application.Calculation = xlAutomatic

            'Show alerts if more workbooks open
'            If Workbooks.Count = 1 Then Application.DisplayAlerts = False
'            Application.Quit
        End If
    End If

End Sub

Answer 1

这种情况不再像开始时那样莫名其妙地发生。无法再重新创建。所以我想一个可能的答案就是等待。