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

Question

关于VBA中的形状的三个简单快捷问题；

1. 有没有办法插入一个真正的公式，比如"=求和(A1:A10("；在形状中？我只能插入一个链接单元格，它不是一个真正的公式

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. 链接到单元格时，如何在VBA代码中为形状设置条件格式
3. 有形状的控制技巧吗
   提前感谢

Answer 1

请尝试以下方法：

1. 在工作表代码模块中复制下一个代码。表必须命名为"；工具T">和必须包含一个名为"的ActiveX按钮；命令按钮1">：

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

2. 复制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

a。单击ActiveX按钮并创建气球形状，分配一个工具提示("这是一个测试工具提示…"(并设置要运行的OnAction宏；

b。该形状被链接到单元格"；A10"；。此单元格可能包含公式(或不包含公式(。更改后，形状文本将相应更改；

5. 细胞"A9"；将是触发形状属性的Fill.ForeColor、line.ForeColor、Font.Color和Bold。有三个条件，但它们可以更多：；A9"；值是数字("A9"中的值>10，＝10，Else(，如果不是

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