Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oCell As Range
Application.ScreenUpdating = False
' Clear the color of all the cells
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
'Ramène la Target (ByVal) sur la colonne Nom du meuble
If Target.Column <> Me.Range(ColonneNomDuMeuble & "1").Column Then
Set Target = Me.Range(ColonneNomDuMeuble & Target.Row)
'Si cellules fusionnées en colonne Nom du meuble prend la 1ère pour le n° de ligne correct
If Target.MergeCells Then
Set Target = Target.MergeArea(1)
'Recréé la sélection de toutes les lignes du meuble
Application.EnableEvents = True
Target.Select
Application.EnableEvents = False
End If
'MsgBox Target.Address
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
'MsgBox "in cell: " & H.Parent.Address
Case 1
'MsgBox "in shape: " & h.Shape.Name
If Right(H.Name, LenAdresse) = Adresse Then
'MsgBox H.Name & " " & Adresse & " " & H.Shape.Name
NbShapes = NbShapes + 1
'Sélectionne la Shape sur la feuille Plan PE
ThisWorkbook.Worksheets(1).Select
H.Shape.Select
'Place la Shape dans le Visible Range
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
'Fait clignoter une flèche rouge pour visualiser la Shape
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 '80
Const ArrowHeight = 40 '25
Const ArrowName = "ShowArrow"
'Save ScreenUpdating at function entry
ScreenUpdating = Application.ScreenUpdating
'Delete Arrow
If Not Action Then
Arrow.Delete
Set Arrow = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = ScreenUpdating
Exit Sub
End If
'Show Arrow
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
'Couleurs de la flèche
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
