اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

كود منع النسخ واللصق

وائل الاسيوطي

بواسطه وائل الاسيوطي
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

وائل الاسيوطي

وائل الاسيوطي

قام بنشر
  • الكاتب
قام بنشر

انا الحمد لله لقيت الكود دا بس منع النسخ والقص ولم يمنع اللصق

 

 

'*** In a standard module ***
Option Explicit
 
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", "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)
     '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
 
Sub CutCopyPasteDisabled()
     'Inform user that the functions have been disabled
    MsgBox "Sorry!  Cutting, copying and pasting have been disabled in this workbook!"
End Sub
 
 '*** In the ThisWorkbook Module ***
Option Explicit
 
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
 
Private Sub Workbook_Open()
    Call ToggleCutCopyAndPaste(False)
End Sub

                                   

 الملف شغال معايا يا ابو جنا

ومالوش مدى محدد عموما جرب كدة

DisableCopyPaste.rar

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

رابط هذا التعليق
شارك
وائل احمد المصري

وائل احمد المصري

قام بنشر
قام بنشر

يعني نسخة الموديول وبعدين نسخت 

Option Explicit
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

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

في thisworkbook

 

رابط هذا التعليق
شارك
عبد العزيز البسكري

عبد العزيز البسكري

قام بنشر
قام بنشر (معدل)

السّلام عليكم و رحمة الله و بركاته

زيادة لكود الأخ الكريم ABO JANA14 و كود الأستاذ الفاضل وائل أحمد المصري .. هذا كود مختصر يتم وضعه في حدث الشيت المقصود منع النسخ و اللّصق به ..

خالص احتراماتي

 

 

 

 

 

 

منع النسخ و اللصق.rar

منع النسخ و اللصق.rar

معذرة أخي الكريم ABO JANA14 .. تكتب مشاركة و تريد التّعديل فتجد مشاركتك الخاطئة و التي تريد تعديلها تزاحم في الملف و تلصق غصبًا عنك ..إذا وجدت كود في الذيس وورك بوك قم رجاء بحذفه..أترك الموجود في حدث الشيت فقط

 

منع النسخ و اللصق.rar

تم تعديل بواسطه عبد العزيز البسكري
رابط هذا التعليق
شارك
وائل الاسيوطي

وائل الاسيوطي

قام بنشر
  • الكاتب
قام بنشر

السّلام عليكم و رحمة الله و بركاته

زيادة لكود الأخ الكريم ABO JANA14 و كود الأستاذ الفاضل وائل أحمد المصري .. هذا كود مختصر يتم وضعه في حدث الشيت المقصود منع النسخ و اللّصق به ..

خالص احتراماتي

 

 

 

 

 

 

منع النسخ و اللصق.rar

منع النسخ و اللصق.rar

معذرة أخي الكريم ABO JANA14 .. تكتب مشاركة و تريد التّعديل فتجد مشاركتك الخاطئة و التي تريد تعديلها تزاحم في الملف و تلصق غصبًا عنك ..إذا وجدت كود في الذيس وورك بوك قم رجاء بحذفه..أترك الموجود في حدث الشيت فقط

 

منع النسخ و اللصق.rar

تلميذ مبتدئ يخطئ اكثر مما يصيب  ومن اساتذتنا نتعلم

انا بالفعل جربت الكود بس فعلا بيعطل النسخ والقص من الماوس ولكن لا يعطلها من الكيبورد ولا يعطل نهائيا اللصق سواء من الماوس او من الكيبورد

orders.rar

رابط هذا التعليق
شارك
عبد العزيز البسكري

عبد العزيز البسكري

قام بنشر
قام بنشر

السّلام عليكم و رحمة الله و بركاته

أخي الكريم ABO JANA14 بإذن الله تاهتْ و لقيناها .. جرّب أخي الكريم هذا الملف ..

 

 

ممنوع النسخ و القص و اللصق.rar

رابط هذا التعليق
شارك
وائل الاسيوطي

وائل الاسيوطي

قام بنشر
  • الكاتب
قام بنشر

جرب كدة 

orders3.rar

اخي وائل بالفعل الكود منع النسخ والقص من الماوس والكيبورد ولكنه لم يمنع اللصق من خلال الماوس

السّلام عليكم و رحمة الله و بركاته

أخي الكريم ABO JANA14 بإذن الله تاهتْ و لقيناها .. جرّب أخي الكريم هذا الملف ..

 

 

ممنوع النسخ و القص و اللصق.rar

اخي عبدالعزيز بالفعل الكود منع النسخ والقص من خلال الماوس والكيبورد ولكنه لم يمنع اللصق من خلال الماوس

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر

مشكورين على الكود الجميل لكن للتدكير فقط أن هدا الكود صالح فقط للاكسيل 2003/2000/97  و لا يمنع من النسخ و اللصق من ال  Ribbon Controls  في اصدارت اكسيل 2007 و ما فوق

رابط هذا التعليق
شارك
مختار حسين محمود

مختار حسين محمود

قام بنشر
قام بنشر

السلام عليكم ورحمة الله

اليكم الكود المميز التالى

أعتقد أنه للأستاذ عبدالله باقشير

 صالح للاصدارات الحديثة  من 2007 فما فوق

يمنع النسخ والقص واللصق من خلال الماوس والكيبورد معا

ومن خلاله تستطيع تعطيل و تفعيل النسخ والقص واللصق  بالرقم السرى 123 ( يمكن تعديله )

Public xx As Integer
Public x As Integer
Sub Auto_Open()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

kh_wVisible True
Application.ScreenUpdating = False
ActiveWindow.DisplayWorkbookTabs = False
Application.DisplayFormulaBar = False

Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)"
Call ToggleCutCopyAndPaste(False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic


End Sub

Sub Auto_Close()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim i As Integer
kh_wVisible False
ThisWorkbook.Close Not CBool(ThisWorkbook.Saved)
Application.DisplayFormulaBar = True
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
Call ToggleCutCopyAndPaste(True)


Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub kh_wVisible(ibol As Boolean)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim nBook As String
nBook = ThisWorkbook.Name
With Windows(nBook)
    If .Visible = Not ibol Then .Visible = ibol
End With


Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub EnableCutcopypaste()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

xx:
Dim x
x = InputBox("لتفعيل النسخ يتطلب" & Chr(13) & "الرجاء ادخال كلمة المرور", "كلمة مرور")
If IsNull(x) Or x = "" Then GoTo xx


If x = "123" Then
Call ToggleCutCopyAndPaste(True)

Else
MsgBox "كلمة مرور غير صحيحة" & Chr(13) & " الرجاء اعادة ادخال كلمة المرور ", vbOKOnly
End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Sub DisableCutcopypaste()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Call ToggleCutCopyAndPaste(False)

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Sub ToggleCutCopyAndPaste(Allow As Boolean)

Application.ScreenUpdating = False
Application.DisplayAlerts = False


'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", "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
    
    
  Application.ScreenUpdating = True
Application.DisplayAlerts = True
    
End Sub

Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
     
  Application.ScreenUpdating = False
Application.DisplayAlerts = False
   
     
     
     '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
    
    Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Sub CutCopyPasteDisabled()

 Application.ScreenUpdating = False
Application.DisplayAlerts = False
   
'Inform user that the functions have been disabled
    MsgBox "نأسف تم تعطيل النسخ والقص واللصق  فى هذا الملف!"

 Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

المرفق

Disable Enable Cut copy paste .rar

  • Like 3
رابط هذا التعليق
شارك
وائل الاسيوطي

وائل الاسيوطي

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم ورحمة الله

اليكم الكود المميز التالى

أعتقد أنه للأستاذ عبدالله باقشير

 صالح للاصدارات الحديثة  من 2007 فما فوق

يمنع النسخ والقص واللصق من خلال الماوس والكيبورد معا

ومن خلاله تستطيع تعطيل و تفعيل النسخ والقص واللصق  بالرقم السرى 123 ( يمكن تعديله )

Public xx As Integer
Public x As Integer
Sub Auto_Open()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

kh_wVisible True
Application.ScreenUpdating = False
ActiveWindow.DisplayWorkbookTabs = False
Application.DisplayFormulaBar = False

Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)"
Call ToggleCutCopyAndPaste(False)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic


End Sub

Sub Auto_Close()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim i As Integer
kh_wVisible False
ThisWorkbook.Close Not CBool(ThisWorkbook.Saved)
Application.DisplayFormulaBar = True
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
Call ToggleCutCopyAndPaste(True)


Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub kh_wVisible(ibol As Boolean)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim nBook As String
nBook = ThisWorkbook.Name
With Windows(nBook)
    If .Visible = Not ibol Then .Visible = ibol
End With


Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub EnableCutcopypaste()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

xx:
Dim x
x = InputBox("لتفعيل النسخ يتطلب" & Chr(13) & "الرجاء ادخال كلمة المرور", "كلمة مرور")
If IsNull(x) Or x = "" Then GoTo xx


If x = "123" Then
Call ToggleCutCopyAndPaste(True)

Else
MsgBox "كلمة مرور غير صحيحة" & Chr(13) & " الرجاء اعادة ادخال كلمة المرور ", vbOKOnly
End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Sub DisableCutcopypaste()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Call ToggleCutCopyAndPaste(False)

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Sub ToggleCutCopyAndPaste(Allow As Boolean)

Application.ScreenUpdating = False
Application.DisplayAlerts = False


'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", "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
    
    
  Application.ScreenUpdating = True
Application.DisplayAlerts = True
    
End Sub

Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean)
     
  Application.ScreenUpdating = False
Application.DisplayAlerts = False
   
     
     
     '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
    
    Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Sub CutCopyPasteDisabled()

 Application.ScreenUpdating = False
Application.DisplayAlerts = False
   
'Inform user that the functions have been disabled
    MsgBox "نأسف تم تعطيل النسخ والقص واللصق  فى هذا الملف!"

 Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub

المرفق

Disable Enable Cut copy paste .rar

جعله الله في ميزان حسناتك يااستاذ مختار بس ارجو منك ان تشرحه لي لانه ليه اكتر من وظيفه لاني لما استخدمته اخفي شريط الادوات وشريط الصفحات من اسفل فكيف اظهرهم مره اخريوهل يمكن ان تجعله يخفي شريط الادوات فقط ولا يخفي شريط الصفحات السفلي

رابط هذا التعليق
شارك
وائل احمد المصري

وائل احمد المصري

قام بنشر
قام بنشر

اخفاء ازرار الصفحات
ActiveWindow.DisplayWorkbookTabs = False
اخفاء شريط القوائم العلوي
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)"
اخفاء شريط المعادلات
Application.DisplayFormulaBar = False
ولاعادة اظهارهم يتم استبدال كلمة false بكلمة True

 

  • Like 3
رابط هذا التعليق
شارك
عبد العزيز البسكري

عبد العزيز البسكري

قام بنشر
قام بنشر

السّلام عليكم و رحمة الله و بركاته

بارك الله فيك أستاذنا الغالي مختار حسين محمود على الكود الرائع و الفعّال .. و من أساتذتنا الكبار نستفيد .. جزاك الله خيرًا و زادها بميزان حسناتك و زادك من علمه و فضله

                                                                                                                        فائق احتراماتي

56116b1b8eeb1____.thumb.gif.36358e2a22be

اخفاء ازرار الصفحات
ActiveWindow.DisplayWorkbookTabs = False
اخفاء شريط القوائم العلوي
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)"
اخفاء شريط المعادلات
Application.DisplayFormulaBar = False
ولاعادة اظهارهم يتم استبدال كلمة false بكلمة True

 

ألف شكر أخي الكريم .. مجموعة أكواد بسيطة و مختصرة .. بارك الله فيك و زادها بميزان حسناتك

 

  • Like 1
رابط هذا التعليق
شارك
  • 2 weeks later...
وائل الاسيوطي

وائل الاسيوطي

قام بنشر
  • الكاتب
قام بنشر

 

اخي هل يمكن ربط كل عمل لهذا الكود بزر مثلا 

زر لتفعيل الغاء النسخ واخر لالغاءه وزر لاخفاء شريط القوائم واخر لالغاءها وهكذا لباقي الكود

رابط هذا التعليق
شارك
مختار حسين محمود

مختار حسين محمود

قام بنشر
قام بنشر

أخى الكريم الكود ككل مكون من عدة أكواد وليس كل الاكواد تربط بزر

الكود    Auto_Open     و Auto_Close    و kh_wVisible   و ToggleCutCopyAndPaste   و   EnableMenuItem  و CutCopyPasteDisabled

لا تربط بأى أزرار   فالكود مصمم بطريقة متشابكة  يعنى كود يستدعى كود آخر

فمثلا عند فتح الملف Auto_Open   يشتغل لاخفاء القوائم لكى لا نستعمل القوائم فى القص والنسخ واللصق وعند غلقه  Auto_Close  يشتغل ليرجع الحال كما كان

وكلاهما يستدعى ToggleCutCopyAndPaste  لتعطيل عمليات النسخ والقص واللصق بلوحة المفاتيح

ما يربط بزر كودان فقط EnableCutcopypaste    و DisableCutcopypaste     تحياتى

  • Like 2
رابط هذا التعليق
شارك
وائل الاسيوطي

وائل الاسيوطي

قام بنشر
  • الكاتب
قام بنشر

أخى الكريم الكود ككل مكون من عدة أكواد وليس كل الاكواد تربط بزر

الكود    Auto_Open     و Auto_Close    و kh_wVisible   و ToggleCutCopyAndPaste   و   EnableMenuItem  و CutCopyPasteDisabled

لا تربط بأى أزرار   فالكود مصمم بطريقة متشابكة  يعنى كود يستدعى كود آخر

فمثلا عند فتح الملف Auto_Open   يشتغل لاخفاء القوائم لكى لا نستعمل القوائم فى القص والنسخ واللصق وعند غلقه  Auto_Close  يشتغل ليرجع الحال كما كان

وكلاهما يستدعى ToggleCutCopyAndPaste  لتعطيل عمليات النسخ والقص واللصق بلوحة المفاتيح

ما يربط بزر كودان فقط EnableCutcopypaste    و DisableCutcopypaste     تحياتى

وهذان هما عز الطلب اخي الاسيوطي الحبيب مختار

رابط هذا التعليق
شارك
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept