logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
Hatem Eissa hassona229-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة اكسيل مشاريع جاهزه



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





14-09-2017 09:09 صباحاً
معلومات الكاتب ▼
تاريخ الإنضمام : 14-09-2017
رقم العضوية : 477
المشاركات : 13
الجنس :
تاريخ الميلاد : 19-4-1968
قوة السمعة : 112
الاعجاب : 0
من مواضيع :جعفر الطريبق

السلام عليكم

كما تعلمون لا يوجد في الاكسيل حدث مرتبط بالنقر على الخلايا .. هنالك فقط حدث Worksheet_SelectionChange الذي لا يميز بين النقر بالماوس أو التحديد بلوحة الكيبورد Arrow keys
قمت مؤخرا بكتابة هذا الكود و وددت أن أشارككم اياه متمنيا أن يشتغل جيدا على جميع اصدارات الاكسيل وأن يعجبكم

ملف للتحميل


كود في موديول عادي Standard Module:
CODE
Option Explicit

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hwnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "Ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
    Private Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
    Private Declare PtrSafe Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Private Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lparam As Any) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private lMouseHook As LongPtr
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function CLSIDFromString Lib "Ole32" (ByVal lpsz As Long, pclsid As Any) As Long
    Private Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
    Private Declare Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private lMouseHook As Long
#End If


Private Const WH_MOUSE_LL As Long = 14
Private Const HC_ACTION As Long = 0
Private Const WM_LBUTTONUP = &H202

Private bHookIsSet As Boolean
Private oWb As Workbook

Sub Start()
    Dim ClassID(0 To 3) As Long
    Dim lOleId As Long
    Dim oApp As Application
    
    On Error GoTo Xit
    
    If CBool(GetProp(GetDesktopWindow, "OleId")) Then Exit Sub
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
    SetProp GetDesktopWindow, "OleId", lOleId
    Set oApp = New Application
    With oApp
        .Workbooks.Open Filename:=ThisWorkbook.FullName, UpdateLinks:=False, ReadOnly:=True
        .Run "On_Open"
    End With
    Exit Sub
Xit:
    oApp.Quit
    Call Finish
End Sub

Sub Finish()
    Dim pUnk As IUnknown
    Dim Wb As Workbook
    Dim ClassID(0 To 3) As Long

    CoDisconnectObject ThisWorkbook, 0
    RevokeActiveObject CLng(GetProp(GetDesktopWindow, "OleId")), 0
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
    Set Wb = pUnk
    Set pUnk = Nothing
    If Not Wb Is Nothing Then
        On Error Resume Next
        Wb.Parent.Run "On_Close"
        Set Wb = Nothing
    End If
    Call RemoveProp(GetDesktopWindow, "OleId")
End Sub


'\\**********************************************************************************
'\\All of the following routines are executed ONLY in the second excel instance !!!
'\\**********************************************************************************
Private Sub On_Open()
    Dim ClassID(0 To 3) As Long
    Dim lOleId2 As Long

    If ThisWorkbook.ReadOnly Then
        Set oWb = GetWorkBook
        If oWb Is Nothing Then
            ThisWorkbook.Saved = True: Application.Quit
        Else
            Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
            Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId2)
            SetTimer Application.hwnd, 0, 0, AddressOf CallSetHook
        End If
    End If
End Sub

Private Sub On_Close()
    UnInstallMouseHook
    KillTimer Application.hwnd, 0
    RemoveProp GetDesktopWindow, "OleId"
    Set oWb = Nothing
    ThisWorkbook.Saved = True
    DoEvents
    Application.Quit
End Sub

Private Sub CallSetHook()
    If Not bHookIsSet Then
        InstallMouseHook
    End If
    KillTimer Application.hwnd, 0
End Sub

Private Sub InstallMouseHook()
    #If VBA7 Then
        Dim hInstance As LongPtr
        hInstance = Application.HinstancePtr
    #Else
        Dim hInstance As Long
        hInstance = Application.hInstance
    #End If

    If Not bHookIsSet Then
        lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, hInstance, 0)
        bHookIsSet = lMouseHook <> 0
    End If
End Sub

Private Sub UnInstallMouseHook()
    If bHookIsSet Then
        UnhookWindowsHookEx lMouseHook
        lMouseHook = 0
        bHookIsSet = False
    End If
End Sub

#If VBA7 Then
    Private Function MouseProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByRef lparam As MOUSEHOOKSTRUCT) As LongPtr
#Else
    Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lparam As MOUSEHOOKSTRUCT) As Long
#End If

    On Error Resume Next
    If GetWorkBook Is Nothing Then
        Call On_Close
        Exit Function
    End If

    If (ncode = HC_ACTION) Then
        If wParam = WM_LBUTTONUP Then
            Call SetTimer(Application.hwnd, 0, 0, AddressOf CallOnClickEvent)
        End If
    End If
    MouseProc = CallNextHookEx(lMouseHook, ncode, wParam, ByVal lparam)
End Function

Private Sub CallOnClickEvent()
    On Error Resume Next
    Static oPrevctiveCell As Range
    Dim tPt As POINTAPI
    
    KillTimer Application.hwnd, 0
    GetCursorPos tPt
    
    With oWb.Application
        If TypeName(.ActiveWindow.RangeFromPoint(tPt.x, tPt.Y)) = "Range" Then
            If Not (.ActiveWindow.RangeFromPoint(tPt.x, tPt.Y).Address <> oPrevctiveCell.Address _
            And .ActiveCell.Address = oPrevctiveCell.Address) Then
                .Run "ThisWorkbook.OnCellClick", .ActiveWindow.RangeSelection
            End If
        End If
        Set oPrevctiveCell = .ActiveCell
    End With
End Sub

Private Function GetWorkBook() As Object
    Dim pUnk As IUnknown
    Dim ClassID(0 To 3) As Long
    
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
    Set GetWorkBook = pUnk
End Function




كود في موديول ThisWorkbook
CODE
Option Explicit

'\\===========================
'\\ OnCellClick Pseudo-Event:
'\============================

Private Sub OnCellClick(ByVal Target As Range)

   '\\ Toggle Tick\Cross marks on cell "A1"
    With Target
        If ActiveSheet Is Sheet1 Then
            If .Address = Range("a1").Address Then
                .Font.Color = vbRed
                .Font.Size = 18
                .Font.Name = "Wingdings"
                .Value = IIf(.Value <> Chr(252), Chr(252), Chr(251))
            End If
        End If
    End With

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Finish
End Sub

Public Sub Workbook_Open()
    Call Start
End Sub





look/images/icons/i1.gif انشاء حدث عند النقر على الخلايا
  14-09-2017 09:16 صباحاً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1824
الجنس :
الدعوات : 21
قوة السمعة : 20034
الاعجاب : 12
موقعي : زيارة موقعي
استاذ جعفر انا لم افهم الفكره
الاكسيل يتيح حدث عند الضغط دبل كليلك وكليك يمين وعند التحديد وعند التغيير فهذا الكود هو شئ اخر غير الاربع حالات هذه ؟



توقيع :الصقر

اخى العضو الكريم
اذا كنت ترى ان المنتدى مفيد لك
فكن سفيرا لنا بدعوة الاخرين للانضمام معنا
فالدال على الخير كفاعله


look/images/icons/i1.gif انشاء حدث عند النقر على الخلايا
  14-09-2017 09:20 صباحاً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1824
الجنس :
الدعوات : 21
قوة السمعة : 20034
الاعجاب : 12
موقعي : زيارة موقعي
انا قمت بتجربه الكود ويعمل جيد لكن بس سؤال ما الفرق بينه وبين حدث تغيير التحديد بالاكسيل



توقيع :الصقر

اخى العضو الكريم
اذا كنت ترى ان المنتدى مفيد لك
فكن سفيرا لنا بدعوة الاخرين للانضمام معنا
فالدال على الخير كفاعله


look/images/icons/i1.gif انشاء حدث عند النقر على الخلايا
  14-09-2017 11:25 صباحاً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 14-09-2017
رقم العضوية : 477
المشاركات : 13
الجنس :
تاريخ الميلاد : 19-4-1968
قوة السمعة : 112
الاعجاب : 0
المشاركة الأصلية كتبت بواسطة: الصقر انا قمت بتجربه الكود ويعمل جيد لكن بس سؤال ما الفرق بينه وبين حدث تغيير التحديد بالاكسيل
أستاذي

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

تخيل لو أردت مثلا أن تستعمل احدى الخلايا مثل ال CheckBox حيث ينبغي نقر الخلية بالماوس لتفعيلها .. في هذه الحالة حدث ال Worksheet_SelectionChange لن يجدي لأن تحديد الخلية بالكيبورد ايضا ممكن و يفعل الحدث هو كذلك

هذه الخاصية كثيرا ما يتم طلبها من طرف بعض مستخدمي الاكسيل لكنها غير متاحة




look/images/icons/i1.gif انشاء حدث عند النقر على الخلايا
  14-09-2017 11:31 صباحاً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 2
المشاركات : 1824
الجنس :
الدعوات : 21
قوة السمعة : 20034
الاعجاب : 12
موقعي : زيارة موقعي
تمام وصلت الفكره مجهود رائع استاذ جعفر جزاكم الله خيرا
123



توقيع :الصقر

اخى العضو الكريم
اذا كنت ترى ان المنتدى مفيد لك
فكن سفيرا لنا بدعوة الاخرين للانضمام معنا
فالدال على الخير كفاعله


look/images/icons/i1.gif انشاء حدث عند النقر على الخلايا
  18-09-2017 12:34 صباحاً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10529
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36757
الاعجاب : 185
بارك الله فيك أخي العزيز جعفر ومشكور على الموضوع الرائع
بالفعل صادفتني هذه المشكلة من فترة وبحثت ولم أجد وقتها حلاً لهذا الإشكال
جزاك الله خيراً ولا حرمنا الله من روائعك




اضافة رد جديد اضافة موضوع جديد




الكلمات الدلالية
انشاء ، النقر ، الخلايا ،









اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 02:52 PM