基本问题
我有以下每天按计划运行的任务: 批处理文件 --> 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
最佳答案
这种情况不再像开始时那样莫名其妙地发生。无法再重新创建。所以我想一个可能的答案就是等待。
关于excel - 几个月没有出现问题后，VBScript 突然无法运行宏，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/48508696/