修改跨工作簿形状OnAction宏名时出现1004错误求助

问题描述 #

需要修改外部工作簿objWorkbookToObsfucate中指定形状的OnAction宏名，将原宏名"Sample Spreadsheet_original_Temp.xlsm'!showMyTimer"替换为运行时生成的新宏名"Sample Spreadsheet_original_Temp.xlsm'!aW7S2Q41LN5TU4A5SWDO2"。但设置shp.OnAction时频繁触发1004错误，即便已经通过IsWorkbookOpen验证目标工作簿处于打开状态，且DoesMacroExist确认新宏存在，代码依然偶发成功偶发失败。

相关代码 #

Public Sub OnActionMacroRename(ByRef objWorkbookToObsfucate As Workbook, ByVal OriginalOnActionMacroName As String, ByVal ModifiedOnActionMacroName As String, ByVal shapecopy As String)
    Dim ws As Worksheet
    Dim shp As Shape
    Dim OriginalMacroName As String
    Dim ModifiedMacroName As String
    Dim i As Long
    
    Debug.Print "Attempting to set OnAction to: " & ModifiedOnActionMacroName
    Debug.Print "Looking for shape with name: " & shapecopy
    
' Loop through all sheets in objWorkbookToObsfucate
    For Each ws In objWorkbookToObsfucate.Sheets
        ' Skip if no shapes
         If ws.Shapes.count = 0 Then GoTo NextSheet
             ' Loop through all shapes in ws of objWorkbookToObsfucate
             For Each shp In ws.Shapes
                    Debug.Print "Shape name: " & shp.Name
                     ' Find original SHP
                         If shp.Name = shapecopy Then
                                Debug.Print shapecopy & " shape Found . Attempting to set OnAction for AutoShape."
                                Debug.Print "ModifiedOnActionMacroName: " & ModifiedOnActionMacroName
                                Debug.Print ws.CodeName
                                Debug.Print shp.Parent.Parent.Name
                                                        
                                 ' Checks before setting the OnAction property
                                If IsWorkbookOpen("Sample Spreadsheet_original_Temp.xlsm") Then
                                        Dim wb As Workbook
                                        Set wb = Workbooks("Sample Spreadsheet_original_Temp.xlsm")
                                            If DoesMacroExist(wb, "aW7S2Q41LN5TU4A5SWDO2") Then
                                            ''Bug is here!!
                                                ''Rename shape in Workbook objWorkbookToObsfucate
                                                ''shp.OnAction = ModifiedOnActionMacroName
                                                shp.OnAction = "'Sample Spreadsheet_original_Temp.xlsm'!aW7S2Q41LN5TU4A5SWDO2"
                                            Else
                                                MsgBox "Macro not found."
                                            End If
                                 Else
                                        MsgBox "Workbook not open."
                                 End If
                               Exit For
                         End If
            Next
NextSheet:
    Next ws
Exit Sub
End Sub

' Function to check if workbook is open
Function IsWorkbookOpen(wbName As String) As Boolean
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(wbName)
    On Error GoTo 0
    IsWorkbookOpen = Not wb Is Nothing
End Function

' Function to check if a macro exists in a workbook
Function DoesMacroExist(wb As Workbook, macroName As String) As Boolean
    Dim vbComp As Object
    Dim vbMod As Object
    Dim lineNum As Long
    Dim lineText As String
    
    For Each vbComp In wb.VBProject.VBComponents
        If vbComp.Type = 1 Then ' 1 is vbext_ct_StdModule
            Set vbMod = vbComp.codeModule
            With vbMod
                For lineNum = 1 To .CountOfLines
                    lineText = .Lines(lineNum, 1)
                    If InStr(1, lineText, "Sub " & macroName & "(", vbTextCompare) > 0 Then
                        DoesMacroExist = True
                        Exit Function
                    End If
                Next lineNum
            End With
        End If
    Next vbComp
    DoesMacroExist = False
End Function

问题排查与解决方法 #

1. 工作簿名称引用格式问题 #

硬编码工作簿名称可能因格式细节出错，建议通过工作簿对象动态生成OnAction字符串，确保单引号和名称匹配：

shp.OnAction = "'" & wb.Name & "'!" & "aW7S2Q41LN5TU4A5SWDO2"

2. 工作表/形状保护限制 #

若目标工作表或形状处于保护状态，修改OnAction会触发权限错误，需先解除保护再恢复：

Dim isSheetProtected As Boolean
isSheetProtected = ws.ProtectContents
If isSheetProtected Then
    ws.Unprotect '若有密码，需传入对应参数，如ws.Unprotect "yourPassword"
End If

' 执行OnAction设置代码
shp.OnAction = "'Sample Spreadsheet_original_Temp.xlsm'!aW7S2Q41LN5TU4A5SWDO2"

If isSheetProtected Then
    ws.Protect '恢复保护，按需传入密码和保护参数，如ws.Protect "yourPassword", DrawingObjects:=True
End If

3. VBProject访问权限限制 #

DoesMacroExist函数需要访问VBA项目对象模型，若Excel宏安全设置禁止该访问，会导致函数误判或后续操作失败。需开启权限：

文件 > 选项 > 信任中心 > 信任中心设置 > 宏设置 > 勾选"信任对VBA项目对象模型的访问"

4. 线程延迟问题 #

偶发失败可能和Excel UI线程未及时处理事件有关，添加DoEvents强制刷新：

DoEvents '处理所有待办系统事件
shp.OnAction = "'Sample Spreadsheet_original_Temp.xlsm'!aW7S2Q41LN5TU4A5SWDO2"

5. 形状类型适配 #

不同类型形状的OnAction设置方式不同，需区分普通形状和ActiveX控件：

If shp.Type = msoOLEControlObject Then
    ' ActiveX控件需通过OLEObject设置
    shp.OLEObject.Object.OnAction = "'Sample Spreadsheet_original_Temp.xlsm'!aW7S2Q41LN5TU4A5SWDO2"
Else
    ' 普通形状直接设置
    shp.OnAction = "'Sample Spreadsheet_original_Temp.xlsm'!aW7S2Q41LN5TU4A5SWDO2"
End If

内容的提问来源于stack exchange，提问作者Noam Brand