là kết hợp giữa các hàm Window API Bugs 2016 64 bit (1 người xem)

[Giancarlo]

Xin chào

Tôi tải về ví dụ từ các liên kết:
http://www.giaiphapexcel.com/diendan/threads/111933.Highlight-hàng-khi-di-chuyển-chuột

Để sử dụng nó, tôi nói thêm với excel 2016 Pro 64 Bit báo cáo Ptrsafe

Trong Modulo1

Option Explicit
'http://www.cpearson.com/excel/WaitFunctions.aspx
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
    Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Public Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) 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
    Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
#End If


Public curCell As Range


Public Type POINTAPI
    X As Long
    Y As Long
End Type


Private CursorPos As POINTAPI
Private CursorCell As Range
Public bActive As Boolean


Sub Active()
    On Error Resume Next
    If bActive Then Exit Sub
    SetTimer Application.hWnd, 1, 250, AddressOf RowAlternative
    bActive = True
End Sub


Sub DeActive()
    On Error Resume Next
    bActive = False
    KillTimer Application.hWnd, 1
    ActiveSheet.Rows(curCell.Row).FormatConditions(1).Delete
End Sub


Private Function RowAlternative()
    On Error Resume Next
    
    Dim RetVal As Long
    RetVal = GetCursorPos(CursorPos)
    RetVal = WindowFromPoint(CursorPos.X, CursorPos.Y)
    
    If (Application.Name <> "Microsoft Excel") Then Exit Function
    Set CursorCell = Application.Windows(1).RangeFromPoint(CursorPos.X, CursorPos.Y)
    
    If Err.Number = 0 Then
        If CursorCell.Address <> curCell.Address Then
            ActiveSheet.Rows(curCell.Row).FormatConditions(1).Delete
            Set curCell = CursorCell
            ActiveSheet.Rows(curCell.Row).FormatConditions.Add xlExpression, , "=true"
            ActiveSheet.Rows(curCell.Row).FormatConditions(1).Interior.ColorIndex = 24
        End If
    End If
End Function

Tôi lưu ý báo lỗi

[COLOR=#ff0000]Sub Active()[/COLOR]
    On Error Resume Next
    If bActive Then Exit Sub
    SetTimer Application.hWnd, 1, 250, [COLOR=#ff0000]AddressOf RowAlternative[/COLOR]
    bActive = True
End Sub

Tìm kiếm một giải pháp, cảm ơn bạn trước

 

[HeSanbi]

Xin chào Mr. Giancarlo,
Tôi thấy bài viết đăng đã lâu nhưng không có câu trả lời.
Nếu một ngày nào đó Ông có quay trở lại Diễn đàn này thì sẽ thấy câu trả lời phía dưới.

Vấn đề nó nằm ở hàm API SetTimer, ở win64 một thủ tục hàm gọi lại thì Kiểu giá trị nó phải là 8 byte tức là LongLong Hoặc là LongPtr (4 byte và 8 byte ) Hoặc Any (bất kỳ Kiểu giá trị nào).

Với code ở trên: AddressOf RowAlternative
AddressOf là một toán tử , trả về độ dài Long/Any (32) , LongLong/ LongPtr/ Any (64)
AddressOf sẽ truyền địa chỉ hàm RowAlternative (Lúc này RowAlternative trở thành một thủ tục cho Hàm API) dưới dạng con trỏ (Khái niệm con trỏ trỏ đến một địa chỉ vùng nhớ) vào hàm SetTimer và SetTimer tiếp tục thực hiện gọi lại. Giúp cho việc gọi lại nhanh hơn.
Lúc này biến lpTimerFunc gọi thủ tục RowAlternative phải là lpTimerFunc As LongLong / LongPtr/ Any (64).

Ông cần rút ngắn thời gian gọi lại:
250 miliseconds - càng nhỏ thì thay đổi với cells sẽ nhanh hơn.
SetTimer Application.hWnd, 1, 100, AddressOf RowAlternative

Chúc Ông nhiều sức khỏe!
"I Know You is a foreigner"

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongLong) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) 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

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

Tham khảo thêm: Kĩ thuật lập trình VBA đa nền tảng và lập trình tương tác Window