剪贴板为空时弹窗警告的VBA代码调试求助

需求：编写VBA代码，粘贴剪贴板内容前检查是否为空，若为空则弹窗警告用户，避免进入宏中断模式。

原代码尝试检查剪贴板格式和文本内容，但仍会触发Excel默认警告，代码如下：

Sub PASTE_SYSTEM()

Application.ScreenUpdating = False
Application.Calculation = xlManual

Dim Type As String

Type = InputBox("What type of Property?", "Type?")
    If StrPtr(Type) = 0 Then Exit Sub

    ThisWorkbook.Sheets("RECEITAS_DS").Range("K2") = UCase(Type)

Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
SText = DataObj.GetText(1)

If DataObj.GetFormat(1) = False Then
    MsgBox "You haven't copied anything yet or the format is incorrect!", vbCritical
    Exit Sub
End If

问题原因 #

当剪贴板为空时，调用DataObj.GetText(1)会直接触发运行时错误，代码还未执行到判断逻辑，就会弹出Excel默认警告，导致宏中断。

修复后的代码 #

通过添加错误捕获机制，提前处理剪贴板为空的异常，避免触发默认警告：

Sub PASTE_SYSTEM()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    Dim Type As String
    Type = InputBox("What type of Property?", "Type?")
    If StrPtr(Type) = 0 Then
        Application.ScreenUpdating = True
        Application.Calculation = xlAutomatic
        Exit Sub
    End If
    ThisWorkbook.Sheets("RECEITAS_DS").Range("K2") = UCase(Type)

    Dim DataObj As MSForms.DataObject
    Dim SText As String
    Set DataObj = New MSForms.DataObject
    
    ' 启用错误捕获，处理剪贴板为空的异常
    On Error Resume Next
    DataObj.GetFromClipboard
    SText = DataObj.GetText(1)
    On Error GoTo 0 ' 恢复默认错误处理

    ' 检查是否存在错误或文本为空
    If Err.Number <> 0 Or Trim(SText) = "" Then
        MsgBox "You haven't copied anything yet or the format is incorrect!", vbCritical
        Err.Clear ' 重置错误状态
        Application.ScreenUpdating = True
        Application.Calculation = xlAutomatic
        Exit Sub
    End If

    ' 在此添加你的粘贴逻辑（示例：ActiveSheet.Paste）
    ' ActiveSheet.Paste

    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub

关键修改点 #

1. 添加On Error Resume Next捕获GetText的运行时错误，避免Excel默认警告弹出
2. 检查错误号和文本内容，双重验证剪贴板有效性
3. 在所有退出分支恢复ScreenUpdating和Calculation的默认设置，避免影响后续操作

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