three simple quick questions about Shapes in VBA;

1. Is there any way to insert a real formula such as "=Sum(A1:A10)" in Shapes? I could find only to insert a linking cell which is not a real formula.

Sub try_shapes()
    With Me.Shapes.AddShape(Type:=msoShapeBalloon, Left:=100, Top:=10, Width:=60, Height:=30)
        .OLEFormat.Object.Formula = "=$A$10" '' only works with a singl linked cell value not a real formula such as "=Sum(A1:A10)"
        .DrawingObject.Formula = "=A10"   '' another way of adding a linked cell with the same limitation
    End With
End Sub

2. How to set a conditional formatting for Shapes in VBA code when linking to a cell?
3. Is there any control tip for Shapes?
   thanks in advance.

CodePudding user response：

Please, try the following way:

1. In a worksheet code module copy the next code. The sheet must be named "ToolT" and must contain an ActiveX button, named "CommandButton1":

Option Explicit

Private Type POINTAPI 'to determine the cursor position
    x As Long
    y As Long
End Type

Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Const myShape As String = "MyBuble Shape", linkedCell As String = "A10", condForm As String = "A9"


Private Sub AddToolTip(ByVal Shp As Shape, ByVal ScreenTip As String)
    Shp.Parent.Hyperlinks.Add Shp, "", "", ScreenTip:=ScreenTip
    Shp.AlternativeText = Shp.AlternativeText & "mYScreenTip"
    Set ThisWorkbook.cmb = Application.CommandBars
End Sub

Sub RemoveToolTip()
    Dim ws As Worksheet, Shp As Shape
    Set Shp = Me.Shapes(myShape)
    Shp.Hyperlink.Delete
    Shp.AlternativeText = Replace(Shp.AlternativeText, "mYScreenTip", "")
End Sub

Private Sub cmb_OnUpdate() 'it is triggered by cursor moving...
    Dim tPt As POINTAPI
    GetCursorPos tPt
    If InStr(1, "RangeNothing", TypeName(ActiveWindow.RangeFromPoint(tPt.x, tPt.y))) = 0 Then
        If ActiveWindow.RangeFromPoint(tPt.x, tPt.y).OnAction <> "" Then
            If GetAsyncKeyState(vbKeyLButton) Then
                Application.Run (ActiveWindow.RangeFromPoint(tPt.x, tPt.y).OnAction)
            End If
        End If
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim sh As Shape
    On Error Resume Next
      Set sh = Me.Shapes(myShape)
    If err.Number = 0 Then sh.Delete 'delete the shape if it exists
    On Error GoTo 0
    With Me.Shapes.AddShape(Type:=msoShapeBalloon, left:=100, top:=10, width:=60, height:=30)
        .OLEFormat.Object.Formula = "=" & linkedCell
        .Name = myShape 'name it
    End With
    Set sh = Me.Shapes(myShape)
    AddToolTip Shp:=sh, ScreenTip:="This is a test tooltip..."
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) = condForm Then
        Dim Shp As Shape: Set Shp = Me.Shapes(myShape)
        If IsNumeric(Target.Value) Then
            If Target.Value > 10 Then
                Shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
                Shp.line.ForeColor.RGB = RGB(0, 0, 255)
                Shp.TextFrame.Characters.Font.color = vbWhite
            ElseIf Target.Value = 10 Then
                Shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
                Shp.line.ForeColor.RGB = RGB(255, 0, 0)
                Shp.TextFrame.Characters.Font.color = vbBlack
            Else
                Shp.Fill.ForeColor.RGB = RGB(0, 0, 0)
                Shp.line.ForeColor.RGB = RGB(255, 255, 255)
                Shp.TextFrame.Characters.Font.color = vbWhite
                Shp.TextFrame.Characters.Font.Bold = True
            End If
        Else
            Shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
            Shp.line.ForeColor.RGB = RGB(255, 0, 0)
            Shp.TextFrame.Characters.Font.color = vbYellow
            Shp.TextFrame.Characters.Font.Bold = False
        End If
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   'for the case of an error when cmb may be lost:
    If ThisWorkbook.cmb Is Nothing Then
        Set ThisWorkbook.cmb = Application.CommandBars
    End If
End Sub

2. Create a Public variable on top of ThisWorkbook code module (its declarations area), by copying the next line:

Public WithEvents cmb As CommandBars 

3. Copy the next event in the same ThisWorkbook code module:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   'it removes the tooltip when workbook is closed (not good to have APIs still hanged to not existing objects)
   Dim sh As Worksheet: Set sh = Worksheets("ToolT")
   Application.Run sh.CodeName & ".RemoveToolTip"
End Sub

a. Click the ActiveX button and create the balloon shape, allocating a tool tip ("This is a test tooltip...");

b. The shape is linked to the cell "A10". This cell may contain a formula. Changing it, the shape text will be changed accordingly

5. Cell "A9" will be the one triggering the shape properties: Fill.ForeColor, line.ForeColor, Font.Color and Bold. There are three conditions, but they can be a lot more: If "A9" value is numeric (value in "A9" > 10, = 10, Else) and if not.

Please, test it and send some feedback. If something unclear, do not hesitate to ask for clarifications...