为形状制作真正的公式、条件格式和控制提示

Question

关于 VBA;

中形状的三个简单快速问题

有什么办法可以在Shapes中插入一个真正的公式，比如“=Sum(A1:A10)”？我只能找到一个不是真正公式的链接单元格。

Sub try_shapes()
    With Me.Shapes.AddShape(Type:=msoShapeBalloon, Left:=100, Top:=10, Width:=60, Height:=30)
        .OLEFormat.Object.Formula = "=$A" '' 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

如何在 VBA 代码链接到单元格时为形状 设置条件格式？

是否有形状控制提示？
提前致谢。

Answer 1

请尝试以下方式：

在工作sheet代码模块中复制下一个代码。 sheet 必须命名为“ToolT” 并且 必须包含一个名为“CommandButton1”的 ActiveX 按钮:

Option Explicit

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

Sub TestShapeOnAction() 'a test macro to be assigned by OnAction
    MsgBox "It works..."
End Sub
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 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
        .OnAction = Me.CodeName & ".TestShapeOnAction" 'replace here the macro name with the needed one
        .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 object may be lost:
    If ThisWorkbook.cmb Is Nothing Then
        Set ThisWorkbook.cmb = Application.CommandBars
    End If
End Sub

复制 ThisWorkbook 代码模块中的下一个代码：

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


Public WithEvents cmb As CommandBars 'pentru Add_ShapeToolTip module

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
                 'this part let the shape using its OnAction set macro:
                Application.Run (ActiveWindow.RangeFromPoint(tPt.x, tPt.y).OnAction)
            End If
        End If
    End If
End Sub
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

一个。单击 ActiveX 按钮并创建气球形状，分配工具提示（“这是一个测试工具提示...”）并将 OnAction 宏设置为运行;

b。该形状链接到单元格“A10”。此单元格可能包含（或不包含）公式。更改它，形状文本将相应更改；

单元格“A9”将触发形状属性：Fill.ForeColor、line.ForeColor、Font.Color 和 Bold。存在三个条件，但它们可以更多：如果“A9”值为数字（“A9”中的值 > 10，= 10，Else），如果不是。

请测试它并发送一些反馈。如果有什么不清楚的地方，请不要犹豫，要求澄清...

为形状制作真正的公式、条件格式和控制提示

Make real formula, conditional formatting and control tip for Shapes

excel

vba

excel-formula

shapes