للقراءه عمل ملف للقراءه فقط

[رورو محمد]

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

تحياتي لكل الموجودين 

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

ولكم جزيل الشكر

[الصـقر]

الاخت الكريمة جربى الملف المرفق هل هو طلبك

ملحوظه هذا الملف من مكتبة الموقع

تقبلى تحياتى

منع النسخ واللصق ومنع حفظ بأسم.zip

[الصـقر]

لتطبيق فكرة الملف على الملف الخاص بك

اتبعى الخطوات التالية

الخطوه الاولى :-

فتح محرر الاكواد من خلال Alt+f11

هتظهر معاك الصورة التالية

فى الصورة دائرة حمراء صغيرة بداخلها Insert  اضغطى عليها

هتفتح معك قائمة اختارى منها 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 "النسخ واللصق والحفظ باسم غير مسموح به فى هذا الملف"
End Sub

Sub n()
Call ToggleCutCopyAndPaste(True)
End Sub

الخطوه الثانية

فى هذه الصورة يوجد دائره حمراء بداخلها ThisWorkbook

اضغطى عليها هتظهر معك الصوره التالية

فى الشاشة البيضه المسماه ThisWorkbook

انسخى الكود التالى وقمى بصلقه فى هذا الشاشة ( حدث المصنف ) 

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

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

 

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

الخطوه الثالثه :- 

 

الخطوة الرابعه :-

يتم تحديد الزر بالوقوف عليه ثم الضغط كليك يمين  شاهدى الصورة

الخطوه الخامسه :-

هى حفظ الملف بضيغه Xlsm شاهد الصورة

ارجوا ان يكون شرح تطبيق نقل الكود واضح

تقبلوا تحياتى

تم تعديل أكتوبر 10, 2015 بواسطه الصـقـر