VBA Excel - método e propriedade de Shape

Question

Prezados

Tenho numa spreadsheet com vários shapes (free form) com diferentes nomes.

Gostaria que, ao passar o mouse sobre cada shape, fosse acionado uma macro comum a todas shapes mostrando o nome da respectiva shape onde o mouse estiver passando. Isso é algo parecido com os comandos das Label da ActiveX.

Grato

Answer 1

https://social.msdn.microsoft.com/Forums/pt-BR/918db0c3-8cbd-434f-a200-64eb7f519122/mouseupmousemove-em-shape-no-excel?forum=vbapt

---

A MELHOR FORMA DE AGRADECER E VOTAR COMO UTIL OU MARCAR COMO RESPOSTA Anderson Diniz [e-mail]

Answer 2

Yes, my code only works on a user form!
Only the UserForm has a Mouse Over Event!
There is no Mouse-Over" Event for a Sheet or ThisWorkbook!

---

A MELHOR FORMA DE AGRADECER E VOTAR COMO UTIL OU MARCAR COMO RESPOSTA Anderson Diniz [e-mail]

Answer 3

Option Explicit 

Private Declare Function GetCursorPos Lib "user32" _ 
(lpPoint As POINTAPI) As Long ' Declare API 

Private Type POINTAPI ' Declare types 
x As Long 
y As Long 
End Type 

Public Event ShapeEnter(Sh As Shape) 
Public Event ShapeExit(Sh As Shape) 

Private pEnableEvents As Boolean 
Private pPreviousObjectsName As String 
Private pInHover As Boolean 
Private pInHoverShape As Shape 
Private ws As Worksheet 

Public Property Let EnableEvents(Value As Boolean) 
pEnableEvents = Value 
If pEnableEvents Then Tracking 
End Property 

Public Property Get EnableEvents() As Boolean 
EnableEvents = pEnableEvents 
End Property 


Private Sub Tracking() 
Dim pt As POINTAPI 
Dim o As Object 
Dim CurrentObjectsName As String 
'On Error Resume Next
Do Until Not pEnableEvents 
DoEvents 

GetCursorPos pt 
Set o = ActiveWindow.RangeFromPoint(pt.x, pt.y) 


Select Case TypeName(o) 

Case "Range", "Nothing" 
pPreviousObjectsName = "" 
If pInHover Then 
RaiseEvent ShapeExit(pInHoverShape) 
pInHover = False 
End If 

Case Else 
CurrentObjectsName = o.Name 
If CurrentObjectsName <> pPreviousObjectsName Then 
If pInHover Then RaiseEvent ShapeExit(ws.Shapes(pPreviousObjectsName)) 
pPreviousObjectsName = CurrentObjectsName 
Set pInHoverShape = ws.Shapes(CurrentObjectsName) 
RaiseEvent ShapeEnter(pInHoverShape) 
pInHover = True 
End If 

End Select 

Loop 

End Sub 

Private Sub Class_Initialize() 
Set ws = ActiveSheet 
End Sub 

Private Sub Class_Terminate() 
pEnableEvents = False 
End Sub 

---

A MELHOR FORMA DE AGRADECER E VOTAR COMO UTIL OU MARCAR COMO RESPOSTA Anderson Diniz [e-mail]

Answer 4

Option Explicit 

Private WithEvents MyShapeEvents As ShapeEvents 

Private Sub MyShapeEvents_ShapeEnter(Sh As Shape) 
Select Case Sh.Name 
Case "Rectangle 1" 
Sh.Fill.ForeColor.SchemeColor = 10 
Sh.TextFrame.Characters.Text = "Click Me!" 
Sh.TextFrame.HorizontalAlignment = xlCenter 
Sh.TextFrame.VerticalAlignment = xlCenter 
With Sh.TextFrame.Characters(Start:=1, Length:=9).Font 
.FontStyle = "Bold" 
.Size = 16 
.Underline = xlUnderlineStyleSingle 
.ColorIndex = 6 
End With 
Sh.Line.Weight = 6# 
Sh.Line.ForeColor.SchemeColor = 40 

'Case "Some Other shape here"

End Select 
End Sub 

Private Sub MyShapeEvents_ShapeExit(Sh As Shape) 
Select Case Sh.Name 
Case "Rectangle 1" 
Sh.Fill.ForeColor.SchemeColor = 64 
Sh.TextFrame.Characters.Text = "" 
Sh.Line.Weight = 1# 
Sh.Line.ForeColor.SchemeColor = 64 
End Select 
End Sub 

Sub Rectangle1_Click() 
MsgBox "Your macros code here..." 
End Sub 

Private Sub Workbook_Open() 
Set MyShapeEvents = New ShapeEvents 
MyShapeEvents.EnableEvents = True 
End Sub 

Private Sub Workbook_SheetActivate(ByVal Sh As Object) 
Set MyShapeEvents = New ShapeEvents 
MyShapeEvents.EnableEvents = True 
End Sub 

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object) 
On Error Resume Next 
MyShapeEvents.EnableEvents = False 
Set MyShapeEvents = Nothing 
End Sub 

---

A MELHOR FORMA DE AGRADECER E VOTAR COMO UTIL OU MARCAR COMO RESPOSTA Anderson Diniz [e-mail]

Answer 5

Private Sub Class_Initialize() 
Application.CellDragAndDrop = False 
Set ws = ActiveSheet 
End Sub 

Private Sub Class_Terminate() 
pEnableEvents = False 
Application.CellDragAndDrop = True 
End Sub 

---

A MELHOR FORMA DE AGRADECER E VOTAR COMO UTIL OU MARCAR COMO RESPOSTA Anderson Diniz [e-mail]