কোনও ঘর কীভাবে লক করার কোনও উপায় আছে যাতে কোনও ব্যবহারকারী এতে কোনও মান কপি / পেস্ট করতে পারে তবে এতে ফর্ম্যাটটি অনুলিপি করে না? ওয়ার্কশিটটি লক করা ব্যবহারকারীকে অনুলিপি / পেস্টের মাধ্যমে ঘরের বিন্যাস পরিবর্তন করতে বাধা দেয় না।
আমি দূষিত ব্যবহারকারীর বিরুদ্ধে সুরক্ষা খুঁজছি না, কেবল নিষ্পাপ ব্যবহারকারীদের জন্য মানগুলি অনুলিপি করা এবং আটকানো সহজ করে তুলছি।
উত্তর:
এই ভিবিএর উত্স এখানে । আমি কোন ক্রেডিট নিতে ।
Alt+ +F11 Insert - module
'Written by Aaron Bush 08/06/2007
'Free for private Use, provided "As-Is" with no warranties express or implied.
'Please retain this notice.
Option Explicit
Option Private Module
Option Compare Binary
Private m_oPasteFile As Object
Private Const m_sFSO_c As String = "Scripting.FileSystemObject"
Private Const m_sPasteProcedure_c As String = "PasteSpecial"
Private Const m_sUbndoProcedure_c As String = "UndoPasteSpecial"
Private Const m_sCutWarningProcedure_c As String = "CutWarning"
Private m_oWS As Excel.Worksheet
'Microsoft Scripting Runtime Constants:
Private Const TristateTrue As Long = -1
Private Const ForReading As Long = 1
Private Const ForWriting As Long = 2
Private Const TemporaryFolder As Long = 2
'Error Handling Constants:
Private Const m_sTitle_c As String = "Error Number: "
Private Const m_lButtons_c As Long = vbExclamation + vbMsgBoxSetForeground + vbMsgBoxHelpButton
'Interface Control Constants:
Const m_sTag_c As String = "ForcePaste"
Public Sub ForcePasteSpecial()
LockInterface
Excel.Application.OnKey "^v", m_sPasteProcedure_c
Excel.Application.OnKey "+{INSERT}", m_sPasteProcedure_c
Excel.Application.OnKey "^x", m_sCutWarningProcedure_c
ReplacePasteButtons
CutButtonsEnable False
Exit_Proc:
On Error Resume Next
UnlockInterface
Exit Sub
Err_Hnd:
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
Resume Exit_Proc
End Sub
Public Sub ReleasePasteControl()
On Error GoTo Err_Hnd
LockInterface
Excel.Application.OnKey "^v"
Excel.Application.OnKey "+{INSERT}"
Excel.Application.OnKey "^x"
RestorePasteButtons
CutButtonsEnable True
Exit_Proc:
On Error Resume Next
m_oPasteFile.Delete True
UnlockInterface
Exit Sub
Err_Hnd:
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
Resume Exit_Proc
End Sub
Private Sub PasteSpecial()
On Error GoTo Err_Hnd
Dim bRunOnce As Boolean
Dim oFSO As Object
Dim oTS As Object
Dim oCll As Excel.Range
Dim oDataRng As Excel.Range
Dim lLstRow As Long
Dim sTmpPth As String
Const lPasteError_c As Long = 1004
Const lFNFError_c As Long = 53
LockInterface
If Excel.ActiveWorkbook Is Excel.ThisWorkbook Then
Set oFSO = VBA.CreateObject(m_sFSO_c)
If m_oPasteFile Is Nothing Then
CreateFile:
sTmpPth = oFSO.BuildPath(oFSO.GetSpecialFolder(TemporaryFolder), oFSO.GetTempName)
Else
sTmpPth = m_oPasteFile.ShortPath
End If
If oFSO.FileExists(sTmpPth) Then oFSO.DeleteFile sTmpPth, True
oFSO.CreateTextFile sTmpPth, True, True
Set m_oPasteFile = oFSO.GetFile(sTmpPth)
Set oTS = m_oPasteFile.OpenAsTextStream(ForWriting, TristateTrue)
Set oDataRng = Excel.ActiveSheet.UsedRange
lLstRow = oDataRng.Row
oTS.WriteLine oDataRng.Address
For Each oCll In oDataRng.Cells
If lLstRow <> oCll.Row Then
lLstRow = oCll.Row
oTS.Write vbNewLine
End If
oTS.Write oCll.Formula & vbTab
Next oCll
Set m_oWS = Excel.ActiveSheet
Excel.Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False
Excel.Application.OnUndo "&Undo Paste", m_sUbndoProcedure_c
Else
Excel.ActiveSheet.Paste
End If
Exit_Proc:
On Error Resume Next
oTS.Close
UnlockInterface
Exit Sub
Err_Hnd:
Select Case VBA.Err.Number
Case lPasteError_c
If Not bRunOnce Then
bRunOnce = True
VBA.Err.Clear
If Excel.Application.Dialogs(xlDialogPasteSpecial).Show Then
Resume Next
Else
Resume Exit_Proc
End If
End If
Case lFNFError_c
Resume CreateFile
End Select
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
Resume Exit_Proc
Resume
End Sub
Private Sub UndoPasteSpecial()
On Error GoTo Err_Hnd
Dim oTS As Object
Dim lRow As Long
Dim lCol As Long
Dim vLine As Variant
Dim sAddress As String
Dim lColOffset As Long
Const lLimit_c As Long = 256
Const lStep_c As Long = 1
Const lZero_c As Long = 0
Const lOffset_c As Long = 1
LockInterface
If m_oPasteFile Is Nothing Then
VBA.Err.Raise vbObjectError, m_sUbndoProcedure_c, "Cannot find stored paste data. Procedure cannot be reveresed."
End If
Set oTS = m_oPasteFile.OpenAsTextStream(ForReading, TristateTrue)
If Not oTS.AtEndOfStream Then
sAddress = oTS.ReadLine
With m_oWS.Range(sAddress)
lColOffset = .Column
lRow = .Row
End With
End If
m_oWS.UsedRange.ClearContents
Do Until oTS.AtEndOfStream
vLine = VBA.Split(oTS.ReadLine, vbTab, lLimit_c, vbBinaryCompare)
For lCol = lZero_c To UBound(vLine)
If VBA.IsNumeric(vLine(lCol)) Then
m_oWS.Cells(lRow, lCol + lColOffset).Formula = CDbl(vLine(lCol))
Else
m_oWS.Cells(lRow, lCol + lColOffset).Formula = vLine(lCol)
End If
Next
lRow = lRow + lStep_c
Loop
Exit_Proc:
On Error Resume Next
oTS.Close
UnlockInterface
Exit Sub
Err_Hnd:
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
Resume Exit_Proc
Resume
End Sub
Private Sub ReplacePasteButtons()
On Error GoTo Err_Hnd
Dim oPasteBtns As Office.CommandBarControls
Dim oPasteBtn As Office.CommandBarButton
Dim oNewBtn As Office.CommandBarButton
Const lIDPaste_c As Long = 22
RestorePasteButtons
Set oPasteBtns = Excel.Application.CommandBars.FindControls(ID:=lIDPaste_c)
For Each oPasteBtn In oPasteBtns
Set oNewBtn = oPasteBtn.Parent.Controls.Add(msoControlButton, Before:=oPasteBtn.Index, Temporary:=True)
oNewBtn.FaceId = lIDPaste_c
oNewBtn.Caption = oPasteBtn.Caption
oNewBtn.TooltipText = oPasteBtn.TooltipText
oNewBtn.Style = oPasteBtn.Style
oNewBtn.BeginGroup = oPasteBtn.BeginGroup
oNewBtn.Tag = m_sTag_c
oNewBtn.OnAction = m_sPasteProcedure_c
oPasteBtn.Visible = False
Next
Exit Sub
Err_Hnd:
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub RestorePasteButtons()
On Error GoTo Err_Hnd
Dim oBtns As Office.CommandBarControls
Dim oBtn As Office.CommandBarButton
Const lIDPaste_c As Long = 22
Const m_sTag_c As String = "ForcePaste"
Set oBtns = Excel.Application.CommandBars.FindControls(ID:=lIDPaste_c)
For Each oBtn In oBtns
oBtn.Visible = True
Next
Set oBtns = Excel.Application.CommandBars.FindControls(Tag:=m_sTag_c)
If Not oBtns Is Nothing Then
For Each oBtn In oBtns
oBtn.Delete
Next
End If
Exit Sub
Err_Hnd:
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub CutButtonsEnable(EnableButton As Boolean)
On Error GoTo Err_Hnd
Dim oCutBtns As Office.CommandBarControls
Dim oCutBtn As Office.CommandBarButton
Const lIDCut_c As Long = 21
Set oCutBtns = Excel.Application.CommandBars.FindControls(ID:=lIDCut_c)
For Each oCutBtn In oCutBtns
oCutBtn.Enabled = EnableButton
Next
Exit Sub
Err_Hnd:
VBA.MsgBox VBA.Err.Description, m_lButtons_c, m_sTitle_c & CStr(VBA.Err.Number), VBA.Err.HelpFile, VBA.Err.HelpContext
End Sub
Private Sub CutWarning()
On Error Resume Next
VBA.MsgBox "The clipboard action ""Cut"" is not available for this workbook.", vbInformation + vbMsgBoxSetForeground, "Cut Disabled"
End Sub
Private Sub LockInterface()
With Excel.Application
.EnableEvents = False
.ScreenUpdating = False
.Cursor = xlWait
.EnableCancelKey = xlErrorHandler
End With
End Sub
Private Sub UnlockInterface()
With Excel.Application
.EnableEvents = True
.ScreenUpdating = True
.Cursor = xlDefault
.EnableCancelKey = xlInterrupt
End With
End Subতারপরে ThisWorkbookঅবজেক্টে ডাবল ক্লিক করুন এবং প্রবেশ করুন
Option Explicit
Private Sub Workbook_Activate()
Debug.Print "Workbook_Activate"
ForcePasteSpecial
End Sub
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Debug.Print "Workbook_BeforeClose"
' ReleasePasteControl
'End Sub
'
Private Sub Workbook_Deactivate()
Debug.Print "Workbook_Deactivate"
ReleasePasteControl
End Subতারপরে আপনি যে পত্রকটি প্রয়োগ করতে চান তাতে ডাবল ক্লিক করুন এবং এতে প্রবেশ করুন
Option Explicit
এখন Debug - Compile VBAProject
সেই শীটগুলিতে যান এখন কেবল পেস্ট-মান হবে।