excel - 防止用户从外部源粘贴到 Excel
问题描述
我想阻止我的用户将值复制、粘贴和剪切到我的工作表中。
下面的代码运行良好,除了它允许用户从另一个源(即 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
解决方案
这是我几年前写的一段代码,也许它对你有用?
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()
高温高压
推荐阅读
- spring-kafka - 带有 enable.auto.commit = false 的 Kafka 消费者仍在提交偏移量
- react-native - react-native 无法达到我想要的边界半径结果
- java - 无法处理自定义 JSON 反序列化程序中引发的异常
- sql - 仅从数据库中提取 CA 中需要的那些项目
- mongodb - 具有特定 Upsert 行为的 MongoDB UpdateOne
- reactjs - 类型“{}”缺少“IFilteredProjectionTableProps”类型的以下属性:
- python - 使用 python 在终端上进行固定打印?
- delphi - 从 Indy 的 IdTCPServer 获取大量“读取超时”异常
- python - 如何在 seaborn 热图中设置绝对颜色范围?
- tensorflow - 如何在 Tensorflow 自定义层中为输出张量初始化 None 形状?