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