none
VBA Excel - método e propriedade de Shape RRS feed

  • Pergunta

  • 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

    domingo, 17 de dezembro de 2017 19:04

Todas as Respostas

  • 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 diniabr2011@gmail.com

    • Sugerido como Resposta AndersonFDiniz2 domingo, 17 de dezembro de 2017 19:48
    domingo, 17 de dezembro de 2017 19:48
  • 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 diniabr2011@gmail.com

    domingo, 17 de dezembro de 2017 19:51
  • 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 diniabr2011@gmail.com

    • Sugerido como Resposta AndersonFDiniz2 domingo, 17 de dezembro de 2017 19:53
    domingo, 17 de dezembro de 2017 19:52
  • 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 diniabr2011@gmail.com

    • Sugerido como Resposta AndersonFDiniz2 domingo, 17 de dezembro de 2017 19:53
    domingo, 17 de dezembro de 2017 19:52
  • 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 diniabr2011@gmail.com

    • Sugerido como Resposta AndersonFDiniz2 domingo, 17 de dezembro de 2017 19:53
    domingo, 17 de dezembro de 2017 19:53