Fait apparaître un commentaire au survol d'une image
le nom du shape commentaire est le nom de l'image+"Commentaire"
Public Declare Function GetCursorPos Lib "user32" (lpPoint
As POINT) As Long
Public Type POINT
x As Long
y As Long
End Type
Public p As POINT
Public boucle
Public Ogauche, OHaut, EchX, EchY
Sub OnMouseOver(ShapeP)
ShapeCmt = ShapeP & "commentaire"
GetCursorPos p
If (p.y - OHaut) / EchY > ActiveSheet.Shapes(ShapeP).Top And
_
(p.y - OHaut) / EchY < ActiveSheet.Shapes(ShapeP).Top
+ ActiveSheet.Shapes(ShapeP).Height And _
(p.x - Ogauche) / EchX > ActiveSheet.Shapes(ShapeP).Left
And _
(p.x - Ogauche) * EchX < ActiveSheet.Shapes(ShapeP).Left
+ ActiveSheet.Shapes(ShapeP).Width Then
ActiveSheet.Shapes(ShapeCmt).Visible = True
ActiveSheet.Shapes(ShapeCmt).Left = ActiveSheet.Shapes(ShapeP).Left
ActiveSheet.Shapes(ShapeCmt).Width = ActiveSheet.Shapes(ShapeP).Width
ActiveSheet.Shapes(ShapeCmt).Top = _
ActiveSheet.Shapes(ShapeP).Top + ActiveSheet.Shapes(ShapeP).Height
+ 2
Else
ActiveSheet.Shapes(ShapeCmt).Visible = False
End If
End Sub
Sub auto_open()
boucle = True
EchY = 1.3
EchX = 0.8
Do While boucle
OHaut = 140 - Cells(ActiveWindow.ScrollRow, 1).Top *
EchY
Ogauche = 50 - Cells(ActiveWindow.ScrollColumn, 1).Left
* EchX
ShapeP = "Image1"
OnMouseOver ShapeP
ShapeP = "Image2"
OnMouseOver ShapeP
DoEvents
Loop
End Sub
Sub auto_close()
boucle = False
End Sub
Sub fin()
boucle = False
End Sub