Question

我想防止我的用户将值复制，粘贴和剪切到我的工作表中。

下面的代码运行良好，不同之处在于它允许用户从其他来源（例如Web浏览器）复制内容并将其粘贴到工作表中。

如何调整代码以防止这种情况？

Private Sub Workbook_Activate()
Application.CutCopyMode = False
Application.OnKey "^c", ""
Application.CellDragAndDrop = False
End Sub

Private Sub Workbook_Deactivate()
Application.CellDragAndDrop = True
Application.OnKey "^c"
Application.CutCopyMode = False
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
Application.CutCopyMode = False
Application.OnKey "^c", ""
Application.CellDragAndDrop = False
End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
Application.CellDragAndDrop = True
Application.OnKey "^c"
Application.CutCopyMode = False
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Cancel = True
MsgBox "Right click menu deactivated." & vbCrLf & _
"Cannot copy or ''drag & drop''.", 16, "For this workbook:"
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.CutCopyMode = False
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.OnKey "^c", ""
Application.CellDragAndDrop = False
Application.CutCopyMode = False
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Application.CutCopyMode = False
End Sub

Answer 1

这是几年前我写的一段代码，也许对您有用？

Option Explicit

'+-----------------------------------------------------------------+
'| Code to selectively prevent Paste operations to specified areas |
'| of a Worksheet.                                                 |
'| Programmed by: RetiredGeek (Windows Secrets Lounge)             |
'|                aka: The Computer Mentor                         |
'|                With a little help from my friend Zeddy (WSL)    |
'| Version:  3.0                                                   |
'| Updated:  04 Jul 2015                                           |
'+-----------------------------------------------------------------+

'*** Global Variables ***
  Public rngPreventPaste As Range
  Public lSrcRows        As Long
  Public lSrcCols        As Long

Sub Auto_Open()

'+----------------------------------------------------+
'|   Remember when using OnKey the NORMAL key ACTION  |
'|   does NOT Take Place!!!                           |
'+----------------------------------------------------+

    With Application
        .OnKey "^v", "CheckCopyMode"      'Capture Ctrl+v
        .OnKey "{Enter}", "CheckCopyMode" 'Capture NumPad Enter
        .OnKey "~", "CheckCopyMode"       'Standard Enter
        .CellDragAndDrop = False          '*** Kill drag and drop! ***
    End With 'Application
    
    '*** Set parameters for initial sheet ***
'+----------------------------------------------------+
'| Next two lines only necessary if initial sheet is  |
'| a Protected sheet as it's Activate event will NOT  |
'| fire!  Change sheet name to the sheet you want to  |
'| have as the default opening sheet and set the      |
'| rngPreventPaste variable to the appropriate range. |
'| If your initial sheet is not Paste Protected use   |
'| Set rngPreventPaste = NOTHING                      |
'+----------------------------------------------------+
    
    Sheets("PasteProtectedSheet").Activate      '*** Change as necessary ***
    Set rngPreventPaste = Range("A1:C3, E5:G8") '*** Change as necessary ***
    Application.EnableEvents = True
    Application.CutCopyMode = False
    
End Sub    'Auto_Open()

Sub CheckCopyMode()

   Dim rngPasteTarget As Range

   If Application.CutCopyMode = False Then Exit Sub '*** Nothing to copy ***!
   
   If rngPreventPaste Is Nothing Then               '*** Unprotected Sheet ***
     ActiveSheet.Paste

   Else                                         '*** Protected Range Sheet ***
   
     '*** Set Paste target Range ***
     Set rngPasteTarget = Range(ActiveCell.Address, _
                  ActiveCell.Offset(lSrcRows - 1, lSrcCols - 1).Address)

     '*** Check to make sure paste won't overlap a protected area ***
     If Not Intersect(rngPasteTarget, rngPreventPaste) Is Nothing Then
       KillPaste             'Paste overlaps protected area kill it!
       Application.CutCopyMode = False
     Else
       ActiveSheet.Paste     'Safe to paste do it!
     End If
   End If
   
End Sub    'CheckCopyMode()

Sub KillPaste()
'+-----------------------------------------------------------------+
'| You can change the message below to fit your needs or you can   |
'| delete it entirely. I don't recommend deleting it though as the |
'| User will have no Idea why the paste didn't work.               |
'+-----------------------------------------------------------------+

  If rngPreventPaste Is Nothing Then Exit Sub
  
  MsgBox "This range: " & rngPreventPaste.Address(, , xlA1) & vbCrLf & _
         " on Sheet  : " & ActiveSheet.Name & _
         " is protected from pasting!" & vbCrLf & vbCrLf & _
         "The operation has been cancelled.", _
         vbOKOnly + vbCritical, _
         "Paste operation Probited:"
         
  '*** The following statement is optional and can savely ***
  '*** be deleted I prefer it for the visual cleanup.     ***
  [A1].Select    '*** Kills the destination selection outline ***
  
End Sub      'KillPaste()

HTH

防止用户从外部源粘贴到Excel

1 个答案: