禁用从其他来源复制/粘贴到 Excel

Question

我想禁用复制/粘贴功能，这样人们就无法在我创建的工作簿上粘贴任何内容。

使用下面的代码，我成功地阻止了人们从另一个工作簿复制到这个工作簿，反之亦然。

但是，他们仍然可以从其他非 Excel 来源（例如 Outlook 或 Internet 浏览器）复制。如果它不是来自 excel，则可以将其粘贴到此工作簿中。如何防止这种情况发生，以便在工作簿中不会发生任何粘贴？

模块中的代码：

Sub ToggleCutCopyAndPaste(Allow As Boolean)
     'Activate/deactivate cut, copy, paste and pastespecial menu items
    Call EnableMenuItem(21, Allow) ' cut
    Call EnableMenuItem(19, Allow) ' copy
    Call EnableMenuItem(22, Allow) ' paste
    Call EnableMenuItem(755, Allow) ' pastespecial

         'Activate/deactivate drag and drop ability
        Application.CellDragAndDrop = Allow

         'Activate/deactivate cut, copy, paste and pastespecial shortcut keys
        With Application
            Select Case Allow
            Case Is = False
                .OnKey "^c", ""
                .OnKey "^v", ""
                .OnKey "^x", ""
                .OnKey "^{DEL}", ""
                .OnKey "^{INSERT}", ""
            Case Is = True
                .OnKey "^c"
                .OnKey "^v"
                .OnKey "^x"
                .OnKey "^{DEL}"
                .OnKey "^{INSERT}"
            End Select
        End With
    End Sub

    Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
         'Activate/Deactivate specific menu item
        Dim cBar As CommandBar
        Dim cBarCtrl As CommandBarControl
        For Each cBar In Application.CommandBars
            If cBar.Name <> "Clipboard" Then
                Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True)
                If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled
            End If
        Next
    End Sub

ThisWorkbook 中的代码：

Private Sub Workbook_Open()
Call ToggleCutCopyAndPaste(False)
End Sub

Private Sub Workbook_Activate()
    Call ToggleCutCopyAndPaste(False)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_Deactivate()
    Call ToggleCutCopyAndPaste(True)
End Sub

Answer 1

我发现了另一种方法，它禁止人们从 Outlook、Internet 浏览器等粘贴到工作簿中。不需要模块。只需将以下代码放入 ThisWorkbook：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CutCopyMode = True
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "^{INSERT}",
Application.OnKey "^{DELETE}",
Application.CommandBars("Cell").Enabled = True
Application.CellDragAndDrop = True
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
End Sub

Private Sub Workbook_Open()
Application.CutCopyMode = False
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "^{INSERT}", ""
Application.OnKey "^{DELETE}", ""
Application.CommandBars("Cell").Enabled = False
Application.CellDragAndDrop = False
'use if statement here if you want to situationally keep ribbon
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
'Else
'Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
'End If
End Sub

Private Sub Workbook_Activate()
Application.CutCopyMode = False
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "^{INSERT}", ""
Application.OnKey "^{DELETE}", ""
Application.CommandBars("Cell").Enabled = False
Application.CellDragAndDrop = False
'use if statement here if you want to situationally keep ribbon
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
'Else
'Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
'End If
End Sub

Private Sub Workbook_Deactivate()
Application.CellDragAndDrop = True
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "^{INSERT}"
Application.OnKey "^{DELETE}"
Application.CommandBars("Cell").Enabled = True
Application.CutCopyMode = True
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
Application.CutCopyMode = False
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "^{INSERT}", ""
Application.OnKey "^{DELETE}", ""
Application.CommandBars("Cell").Enabled = False
Application.CellDragAndDrop = False
End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
Application.CellDragAndDrop = True
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "^{INSERT}"
Application.OnKey "^{DELETE}"
Application.CommandBars("Cell").Enabled = True
Application.CutCopyMode = True
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.OnKey "^c", ""
Application.OnKey "^v", ""
Application.OnKey "^{INSERT}", ""
Application.OnKey "^{DELETE}", ""
Application.CommandBars("Cell").Enabled = False
Application.CellDragAndDrop = False
Application.CutCopyMode = False
End Sub

请注意，我也禁用了功能区，因为仍然可以使用“主页”选项卡进行粘贴。令人沮丧的是，似乎没有办法完全禁用复制/粘贴，而不仅仅是从 Excel 到 Excel。

如果需要，您可以将此代码放入模块中，并在需要访问复制/粘贴工具时手动运行：

Sub Enable_CopyPaste()

'Run this sub when you need to access copy/paste tools

Application.CutCopyMode = True
Application.OnKey "^c"
Application.OnKey "^v"
Application.OnKey "^{INSERT}"
Application.OnKey "^{DELETE}"
Application.CommandBars("Cell").Enabled = True
Application.CellDragAndDrop = True
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"

End Sub

Answer 2

感谢 CLR 指出窗口激活。我将此添加到 ThisWorkbook：

Private Sub Workbook_Deactivate()
    Call ToggleCutCopyAndPaste(True)
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
    Call ToggleCutCopyAndPaste(False)
End Sub

虽然它最初并没有解决问题，但它与添加到模块中的这段代码一起解决了：

Dim oData   As New DataObject 'object to use the clipboard

    oData.SetText Text:=Empty 'Clear
    oData.PutInClipboard 'take in the clipboard to empty it

现在用户无法通过从 Outlook、Internet 浏览器等复制/粘贴来替换和重新格式化工作簿的内容。