為形狀制作真正的公式、條件格式和控制提示

關于 VBA 中形狀的三個簡單快速問題；

1. 有沒有辦法在形狀中插入一個真正的公式，比如“=Sum(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. 形狀有什么控制提示嗎？
   提前致謝。

uj5u.com熱心網友回復：

請嘗試以下方法：

1. 在作業表代碼模塊中復制下一個代碼。該作業表必須命名為“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

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

一個。單擊 ActiveX 按鈕并創建氣球形狀，分配工具提示（“這是一個測驗工具提示...”）并設定OnAction要運行的宏；

灣 該形狀鏈接到單元格“A10”。此單元格可能包含公式（或不包含）。更改它，形狀文本將相應更改；

5. 細胞“A9”將是一個觸發形狀屬性：Fill.ForeColor，line.ForeColor，Font.Color和Bold。有三個條件，但它們可以更多：如果“A9”值是數字（“A9”中的值 > 10, = 10, Else），如果不是。

請測驗它并發送一些反饋。如果有不清楚的地方，請不要猶豫，要求澄清......

標籤：擅长 vba excel-公式 形状

上一篇：同列前一行的參考值

下一篇：不屬于排除串列的唯一值的Excel公式