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

وائل الاسيوطي · أكتوبر 3, 2015

دا مثال فيه كود يمنع النسخ بس راضي يشتغل معاي لما نقلته لملف تاني ياتري هو ليه مدي معين ولا بيقفل الصفحه كلها

DisableCopyPaste.zip

**وائل احمد المصري** · أكتوبر 3, 2015

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

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

DisableCopyPaste.rar

وائل الاسيوطي · أكتوبر 3, 2015

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

'*** 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

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

**وائل احمد المصري** · أكتوبر 3, 2015

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

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

وائل الاسيوطي · أكتوبر 3, 2015

عملت كدا فعلا ومااشتغلش

**وائل احمد المصري** · أكتوبر 3, 2015

طب ما ترفق الملف

**عبد العزيز البسكري** · أكتوبر 3, 2015

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

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

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

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

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

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

تم تعديل أكتوبر 3, 2015 بواسطه عبد العزيز البسكري

وائل الاسيوطي · أكتوبر 3, 2015

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

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

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

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

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

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

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

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

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

orders.rar

**وائل احمد المصري** · أكتوبر 3, 2015

جرب كدة

orders3.rar

**عبد العزيز البسكري** · أكتوبر 3, 2015

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

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

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

وائل الاسيوطي · أكتوبر 3, 2015

جرب كدة

orders3.rar

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

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

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

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

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

**جعفر الطريبق** · أكتوبر 4, 2015

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

**مختار حسين محمود** · أكتوبر 4, 2015

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

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

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

صالح للاصدارات الحديثة من 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

وائل الاسيوطي · أكتوبر 4, 2015

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

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

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

صالح للاصدارات الحديثة من 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

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

**وائل احمد المصري** · أكتوبر 4, 2015

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

**عبد العزيز البسكري** · أكتوبر 4, 2015

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

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

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

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

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

وائل الاسيوطي · أكتوبر 4, 2015

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

وائل الاسيوطي · أكتوبر 14, 2015

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

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

**مختار حسين محمود** · أكتوبر 14, 2015

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

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

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

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

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

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

وائل الاسيوطي · أكتوبر 15, 2015

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

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

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

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

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

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

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

تسجيل الدخول

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

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

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

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

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

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

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

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

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

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

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

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

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

جعفر الطريبق

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

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

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

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

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

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

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

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

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information