Tạo shape với hai kiểu nhấn Click và Double Click

[HeSanbi]

Khi tạo một Đối tượng trong bảng tính Excel để gán một thủ tục (Macro VBA) thì Đối tượng đó chỉ hỗ trợ sự kiện Click chuột, mà không hỗ trợ Double Click chuột như các Đối tượng ActiveX Object, chính vì vậy bài viết này tôi sẽ giúp các bạn một giải thuật để làm điều đó.


Bài viết này tôi sẽ hướng dẫn các bạn tạo Đối tượng thực hiện tác vụ khác nhau khi Click hoặc Double Click vào đối tượng đó.
(Đối tượng bao gồm Shape, Hình ảnh, Button, ... Nói chung là có thể gán vào một Macro)


Giải thuật để bắt được Double Click:
Thường thì quãng giữa thời gian của hai Click tối đa là 1/7 đến 1/5 của Giây, vì vậy ta so sánh từ thời gian click đầu tiên, nếu quãng giữa thời gian tối đa của hai Click cộng cho thời gian click đầu tiên mà vẫn lớn hơn thời gian hiện tại thì đã bắt được Double Click.

Thực hiện giải thuật qua các Ví dụ:

Ví dụ 1. Chỉ thực hiện tác vụ khi Double Click (Rất đơn giản):

Tạo hàm IsDoubleClick và thêm dòng code dưới vào đầu thủ tục:

If Not IsDoubleClick Then Exit Sub

------------------------

Sub OnlyCallWhenDoubleClick()
    If Not IsDoubleClick Then Exit Sub
    MsgBox "OK! DoubleClick"
End Sub
Function IsDoubleClick() As Boolean
  Static EarliestTime As Date
  If EarliestTime + 0.13 > VBA.Timer Then
    EarliestTime = 0: IsDoubleClick = True
  Else
     EarliestTime = VBA.Timer
  End If
End Sub

------------------------

Ví dụ 2. Click và Double Click thực hiện một tác vụ khác nhau:

Để gán hai tác vụ khác nhau vào sự kiện Click và Double Click khá phức tạp, vì vậy tôi chỉ có thể Ví dụ đoạn code bên dưới để các bạn có thể thực hiện.


(*Trong code dưới có chú thích rất rõ ràng, chỉ đọc được chú thích khi dán code vào Module)
------------------------

Option Explicit
''//////////////////////////////////////////////////////////////////////////////////////////
#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
#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
#End If
''//////////////////////////////////////////////////////////////////////////////////////////
#If Win64 Then
  Private Pri_TimerID As LongPtr
#Else
  Private Pri_TimerID As Long
#End If
''//////////////////////////////////////////////////////////////////////////////////////////
Public glb_IsDoubleClick As Boolean
Public oObject As Object, TimeoutTerminate As Date
''//////////////////////////////////////////////////////////////////////////////////////////
''Thủ tục để gán vào Đối tượng (Shape, hình ảnh, ...)
Sub ButtonCall()
  On Error Resume Next
  ''Hủy Giải phóng bộ nhớ khi tác vụ có Đối tượng toàn cục sau 60 giây
  ''Vì thủ tục tiếp tục được gọi lại
  Application.OnTime TimeoutTerminate, "'" & ThisWorkbook.Name & "'!Object_Terminate", , False
  '----------------------------------------
  Static EarliestTime As Date
  If EarliestTime + 0.13 > VBA.Timer Then
    glb_IsDoubleClick = True
    EarliestTime = 0
  Else
    glb_IsDoubleClick = False
    EarliestTime = VBA.Timer
    If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
    Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!Sub_Early"
    Pri_TimerID = SetTimer(0&, 0&, 140, AddressOf MainSub)
  End If
  '----------------------------------------
  ''Giải phóng bộ nhớ khi tác vụ có Đối tượng toàn cục sau 60 giây
  TimeoutTerminate = VBA.Now + VBA.TimeSerial(0, 0, 60)
  Application.OnTime TimeoutTerminate, "'" & ThisWorkbook.Name & "'!Object_Terminate"
End Sub
''//////////////////////////////////////////////////////////////////////////////////////////
Private Sub MainSub()
  ''Thủ tục chính xử lý kết quả cuối
  On Error Resume Next
  If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
  If glb_IsDoubleClick Then
    MsgBox "Double Click Event!"
  Else
    MsgBox "Click Event!"
  End If
  On Error GoTo 0
End Sub
''//////////////////////////////////////////////////////////////////////////////////////////
Sub Sub_Early()
  ''Chỉ là một kĩ thuật xử lý - Không nhất thiết - Nếu cần
  ''Thủ tục này phải có thời gian xử lý nhỏ hơn 140 mili giây
  If Not glb_IsDoubleClick Then
    ''Thực hiện tác vụ nhỏ cho Double Click
  Else
    ''Thực hiện tác vụ nhỏ cho Click
  End If
End Sub
''//////////////////////////////////////////////////////////////////////////////////////////
Sub Object_Terminate()
  ''Chỉ là một kĩ thuật xử lý - Không nhất thiết - Nếu cần
  ''Giải phóng bộ nhớ khi tác vụ có Đối tượng toàn cục sau 60 giây
  ''Kể từ thời điểm cuối gọi thủ thục chính
  Set oObject = Nothing
End Sub

--------------------------


Ở trên tôi đã hướng dẫn cho các bạn tạo sự kiện Double Click thực hiện một tác vụ riêng biệt với Sự kiện Click chuột. Và tôi có những bài viết về VBA các bạn có thể tham khảo thêm bằng cách vào trang cá nhân của tôi trên Giải Pháp Excel này.


Chúc các bạn thành công!