Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oCell As Range
Application.ScreenUpdating = False
Cells.Interior.ColorIndex = 0
Target.Interior.ColorIndex = 8
For Each oCell In Target
Me.Rows(oCell.Row).Interior.ColorIndex = 8
Next oCell
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim H As Hyperlink
Dim Adresse As String
Dim LenAdresse As Integer
Dim i As Integer
Dim NbShapes As Integer
Const ColonneNomDuMeuble As String = "B"
Application.EnableEvents = False
If Target.Column <> Me.Range(ColonneNomDuMeuble & "1").Column Then
Set Target = Me.Range(ColonneNomDuMeuble & Target.Row)
If Target.MergeCells Then
Set Target = Target.MergeArea(1)
Application.EnableEvents = True
Target.Select
Application.EnableEvents = False
End If
End If
Adresse = Me.Name & "!" & ColonneNomDuMeuble & Target.Row
LenAdresse = Len(Adresse)
NbShapes = 0
For Each H In ThisWorkbook.Worksheets(1).Hyperlinks
Select Case H.Type
Case 0
Case 1
If Right(H.Name, LenAdresse) = Adresse Then
NbShapes = NbShapes + 1
ThisWorkbook.Worksheets(1).Select
H.Shape.Select
If Intersect(H.Shape.TopLeftCell, ActiveWindow.VisibleRange) Is Nothing _
Or Intersect(H.Shape.BottomRightCell, ActiveWindow.VisibleRange) Is Nothing _
Then
ActiveWindow.ScrollRow = Application.Max(1, H.Shape.TopLeftCell.Row - ActiveWindow.VisibleRange.Rows.Count / 2)
End If
For i = 1 To 4
Call ShowDeleteArrow(True, H.Shape)
Sleep (150)
DoEvents
Call ShowDeleteArrow(False, H.Shape)
Sleep (150)
DoEvents
Next i
End If
End Select
Next H
Application.EnableEvents = True
If NbShapes = 0 Then MsgBox "Shape non trouvée !"
End Sub
Private Sub ShowDeleteArrow(Action As Boolean, Sh As Excel.Shape)
Dim ScreenUpdating As Boolean
Static Arrow As Excel.Shape
Const ArrowWidth = 100
Const ArrowHeight = 40
Const ArrowName = "ShowArrow"
ScreenUpdating = Application.ScreenUpdating
If Not Action Then
Arrow.Delete
Set Arrow = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = ScreenUpdating
Exit Sub
End If
On Error Resume Next
If Not Arrow Is Nothing Then
Arrow.Delete
Set Arrow = Nothing
Else
ActiveSheet.Shapes(ArrowName).Delete
End If
On Error GoTo 0
Set Arrow = ActiveSheet.Shapes.AddShape(msoShapeLeftArrow, _
Sh.Left + Sh.Width + 5, _
Application.Max(0, Sh.Top + (Sh.Height / 2) - (ArrowHeight / 2)), _
ArrowWidth, _
ArrowHeight)
Arrow.Name = ArrowName
With Arrow.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
With Arrow.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 112, 192)
.Transparency = 0
End With
Application.ScreenUpdating = True
Application.ScreenUpdating = ScreenUpdating
End Sub
