منع النسخ والقص واللصق وتغيير اسم المصنف وكليك يمين

منع النسخ والقص واللصق وتغيير اسم المصنف وكليك يمين

من ضمن أمور الحماية المتعددة بالفيجوال بيسك للتطبيقات ، أكواد منع النسخ والقص واللصق وتغيير اسم المصنف واستخدام كليك يمين ومنع الحفظ باسم

سنعرض طريقتين لذلك

الطريقة الأولى

1. اضغط على ALT + F11
2. على يسار نافذة المحرر
3. اضغط كليك يمين
4. اختر Insert Module
5. كتابة الشفرة الخاصة به بداخله
6. ثم اضغط مرتين على ThisWorkbook
7. كتابة الشفرات الخاصة بحدث المصنف بداخله

الأكواد الخاصة بالموديول كالتالي

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com


Sub ToggleCutCopyAndPaste(Allow As Boolean)

    Call EnableMenuItem(21, Allow)    
    Call EnableMenuItem(19, Allow)    
    Call EnableMenuItem(22, Allow)    
    Call EnableMenuItem(755, Allow)   


    Application.CellDragAndDrop = Allow


    With Application
        Select Case Allow
            Case Is = False
                .OnKey "^c", "CutCopyPasteDisabled"
                .OnKey "^v", "CutCopyPasteDisabled"
                .OnKey "^x", "CutCopyPasteDisabled"
                .OnKey "+{DEL}", "CutCopyPasteDisabled"
                .OnKey "^{INSERT}", "CutCopyPasteDisabled"
            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)
    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


Sub MZM_ELSHRIEF()
Application.CommandBars("Cell").Enabled = False
    MsgBox "Sorry!  CommandBars, Cutting, Copying, pasting, And Save As Name have been disabled in this workbook!"
End Sub

الأكواد التى توضع بحدث ThisWorkbook

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com


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

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

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

Private Sub Workbook_Open()
Dim MyFlName As String
'يوضع اسم الملف مع الامتداد الخاص به هنا بين أقواس التنصيص
   MyFlName = "filename.xlsm" 
 
    If ThisWorkbook.Name <> MyFlName Then

      Application.DisplayAlerts = False
      ThisWorkbook.Close
    End If

    Call ToggleCutCopyAndPaste(False)
    MZM_ELSHRIEF
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True Then
    Me.Save
    Cancel = True
End If
End Sub

الطريقة الثانية

1. اضغط على ALT + F11
2. اضغط مرتين على ThisWorkbook
3. ثم قم بكتابة الشفرات التالية

'فضلا عند استخدامك للشفرات البرمجية يجب ذكر المصدر
'https://elshriefacademy.blogspot.com


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_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

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    MsgBox ("Sorry Right Click is Disbaled for this Workbook"),vbInformation, "Attention"
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True Then
    Me.Save
    Cancel = True
End If
End Sub

Private Sub Workbook_Open()
Dim MyFlName As String
'يوضع اسم الملف مع الامتداد الخاص به هنا بين أقواس التنصيص
  
  MyFlName = "filename.xlsm" 
 
    If ThisWorkbook.Name <> MyFlName Then

      Application.DisplayAlerts = False
      ThisWorkbook.Close
    End If
End Sub