XL 2016 Private Function RowAlternative()

[Simply]

Bonjour

Je l'ai modifié le code avec des références à Ptrsafe in Excel 2016 64 Bit.
Il ne fonctionne pas correctement, demander de l'aide à comprendre comment corriger le code.


Dans un module:

Option Explicit

#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

J'espère votre aide

 

[Staple1600]

Bonsoir à tous

Chez moi, pas de message d'erreur
Mais il ne passe absolument rien de visible sur la feuille.

 

[Simply]

Bonsoir à tous
Je joins le fichier dans l'espoir de comprendre la raison pour laquelle je l'ai signalé.
J'étais certain que le fichier est correct, je n'ai pas besoin pour le travail

Il a le même genre d'erreur avec d'autres codes Bees plus élaborés, j'espérais que quelques lignes vous pouvez comprendre les raisons d'erreurs

Infos

 

[Staple1600]

Re

Sinon, ce code donne presque le même résultat non ?
(à mettre dans le code de la feuille)

Private Sub Worksheet_SelectionChange(ByVal T As Range)
Cells.Interior.ColorIndex = -4142: T.EntireRow.Interior.ColorIndex = 24: T.EntireColumn.Interior.ColorIndex = 24
End Sub

NB: J'ai ouvert ton fichier, et comme je le disais pas de message d'erreur.
Je vais retester en commentant les On error Resume Next

 

[Simply]

Re

I added the code, and I select the row and column.
It remains to understand the error with

SetTimer Application.hWnd, 1, 250, AddressOf RowAlternative

 

[Staple1600]

Re

Simply
[ ] Tu te réponds à toi-même?
[ ] Tu ne lis pas mes messages ?

Cocher la mention utile.

EDITION: Histoire de creuser un peu l'API, le code ci-dessous fonctionne chez moi.

Spoiler: Couleur et caetera

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
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Type POINTAPI
x As Long
Y As Long
End Type

Dim lngCurPos As POINTAPI
Dim TimerOn As Boolean
Dim TimerId As Long
Public oldColor As Long
Dim newRange As Range
Dim oldRange As Range

Sub StartTimer()
If Not TimerOn Then
TimerId = SetTimer(0, 0, 0.01, AddressOf TimerProc)
TimerOn = True
Else
MsgBox "Timer already On !", vbInformation
End If
End Sub

Sub TimerProc()
'Vic Eldridge -05-2005
On Error Resume Next
GetCursorPos lngCurPos
Set newRange = ActiveWindow.RangeFromPoint(lngCurPos.x, lngCurPos.Y)
If newRange.Address <> oldRange.Address Then
oldRange.Interior.ColorIndex = oldColor
Set oldRange = newRange
oldColor = newRange.Interior.ColorIndex
newRange.Interior.ColorIndex = 3
End If
End Sub

Sub StopTimer()
If TimerOn Then
KillTimer 0, TimerId
TimerOn = False
Else
MsgBox "Timer already Off", vbInformation
End If
End Sub
'////////
Dim TrgtColor As Long
Dim oldTarget As Range

Private Sub Worksheet_Change(ByVal Target As Range)
Target.Interior.ColorIndex = TrgtColor
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set oldTarget = Target
TrgtColor = oldColor
End Sub

 

[Simply]

Bonsoir à tous

merci Staple1600 qui il a donné des conseils

Je trouve d'autres descriptions à la question de ce lien
https://support.microsoft.com/fr-fr/kb/2210978

J'ai trouvé comment tester avec d'autres codes avec Api Vba
Je l'ai résolu mes doutes