انشاء حدث عند النقر على الخلايا

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

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