طريقة لضبط و برمجة حدث النسخ و القص للخلايا ... Cut Copy PseudoEvent

[جعفر الطريبق]

السلام عليكم

كما تعلمون لا يوجد في الاكسيل حدث مرتبط بالنسخ أو القص ... هدا كود يملأ دالك الفراغ

أضف الكود التالي الى ال   ThisWorkbook Module :

تنبيه : لكي يبدأ الكود في الاشتغال يجب أولا تنفيد الكود الموجود داخل ال Private Sub Workbook_Open() أو غلق الملف ثم اعادة فتحه

Option Explicit
Private WithEvents Cmbrs As CommandBars

#If VBA7 Then
    Private Declare PtrSafe Function GetClipboardSequenceNumber Lib "user32" () As Long
#Else
       Private Declare Function GetClipboardSequenceNumber Lib "user32" () As Long
#End If


Private Sub Workbook_Open()
    Set Cmbrs = Application.CommandBars
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set Cmbrs = Nothing
End Sub

Private Sub Cmbrs_OnUpdate()
    Dim bCancel As Boolean
    Dim sClipData As String
    Static lSequenceNumber As Long
    
    On Error Resume Next
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        If lSequenceNumber = GetClipboardSequenceNumber Then Exit Sub
        lSequenceNumber = GetClipboardSequenceNumber
        .GetFromClipboard
         sClipData = .GetText
        sClipData = Left(sClipData, Len(sClipData) - 2)
        Select Case True
            Case Application.CutCopyMode = xlCopy
                Call Workbook_CellCopy(Selection, sClipData, bCancel)
            Case Application.CutCopyMode = xlCut
                Call Workbook_CellCut(Selection, sClipData, bCancel)
        End Select
    End With
    If bCancel Then Application.CutCopyMode = False
End Sub

'pseudoevents :
'============
Private Sub Workbook_CellCopy(ByVal Target As Range, ByVal ClipboardData As String, ByRef Cancel As Boolean)
    If MsgBox("You are about to copy the following text to the clipboard:" & vbCr & _
    vbCr & "'" & ClipboardData & "' " & vbCr & vbCr & "Go ahead ?", vbYesNo + vbQuestion, "Officena") = vbNo Then
        Cancel = True
    End If
End Sub

Private Sub Workbook_CellCut(ByVal Target As Range, ByVal ClipboardData As String, ByRef Cancel As Boolean)
    If MsgBox("You are about to cut the following Range to the clipboard:" & vbCr & _
    vbCr & "'" & Target.Address(external:=True) & "' " & vbCr & vbCr & "Go ahead ?", vbYesNo + vbQuestion, "Officena") = vbNo Then
        Cancel = True
    End If
End Sub

 

[ياسر خليل أبو البراء]

أخي الحبيب جعفر

قمت بتجربة الكود ووضعته في حدث المصنف كما وضحت وحفظت الملف ثم أغلقته ..

قمت بعمل نسخ ولصق مرة ، ثم قمت بعمل قص ولصق مرة .. ولم يحدث أي شيء !!

من المفترض أن أحصل على رسالة تفيد أنني على وشك القيام بنسخ أو لصق ..أليس كذلك؟

 

النسخة لدي أوفيس 2007 32 بت

تقبل تحياتي

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

السلام عليكم

جزاك الله خيرا أستاذى العزيز جعفر

أستاذى العزيز ياسر قمت بتجربة الكود  واشتغل معى   اوفيس 2010

Cut Copy PseudoEvent by jaafar .rar

[ياسر خليل أبو البراء]

بارك الله فيك أخي الغالي مختار

يبدو أن المشكلة كانت عندي في الويندوز ..قمت بإعادة التشغيل للجهاز واشتغل الكود بشكل ممتاز

بارك الله فيك أخي المتميز جعفر على ما تقدمه من كل جديد ومفيد في عالم الإكسيل