使用按钮在当前单元格的右侧添加并偏移形状

Question

在下面的VBA代码中，代码的目标是每次在当前单元格的右侧添加形状。我也在下面添加了一个GIF，因此您可以准确地看到我想做什么。我的代码现在立即导致运行时错误。我知道我必须以某种方式使用偏移命令。

Sub FormButtonClick()

Set myDocument = Worksheets(1)
myDocument.Shapes.AddShape msoShapeRectangle, 50, 50, 100, 200
myDocument.Left


End Sub

Answer 1

您的解决方案必须有几次检查才能按照您的要求添加形状：

1. 仅查看给定单元的行内的形状
2. ，确定给定单元的右侧是否有任何形状
3. ，确定哪种形状是最后（最右）形状

您必须在下面的示例代码中进行一些细节，但是您应该能够扩展示例以满足您的需求。

该示例做出以下假设：

• 形状将是当前行的高度，
• 形状将是其列的宽度
• （基本上，形状将是单元格的大小！）

代码：

Option Explicit

Sub test()
    DeleteAllShapes   'for testing
    AddShape Range("B4"), ShapeText:="+"
    AddShape Range("B4"), ShapeColor:=RGB(255, 0, 0), ShapeText:="-"
    AddShape Range("B4"), ShapeColor:=RGB(0, 255, 0), ShapeText:="aaa"
    AddShape Range("B4"), ShapeColor:=RGB(0, 0, 255), ShapeText:="bbb"
    AddShape ActiveCell, ShapeText:="xxx"
End Sub

Sub DeleteAllShapes()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next shp
End Sub

Sub AddShape(ByRef currentCell As Range, _
             Optional ShapeColor As Long = -1, _
             Optional ShapeText As String = vbNullString)
    '--- starts with the given cell and checks to find ANY shape
    '    immediately to the right of that cell, then adds another
    '    rectangle to the right of the right-most shape
    Dim thisWS As Worksheet
    Set thisWS = currentCell.Parent
    
    Dim shp As Shape
    Dim rightmostShape As Shape
    For Each shp In thisWS.Shapes
        If ShapeInlineWith(currentCell, shp) Then
            If rightmostShape Is Nothing Then
                Set rightmostShape = shp
            Else
                If shp.Left > rightmostShape.Left Then
                    Set rightmostShape = shp
                End If
            End If
        End If
    Next shp
    
    Dim newShape As Shape
    If rightmostShape Is Nothing Then
        '--- add the first shape one column to the right,
        '    using the width of that column
        With currentCell
            Set newShape = thisWS.Shapes.AddShape(Type:=msoShapeRectangle, _
                                                  Left:=.Left + .Width, _
                                                  Top:=.Top, _
                                                  Width:=.Offset(0, 1).Width, _
                                                  Height:=.Height)
        End With
    Else
        With rightmostShape
            '--- first, find out which column we're using and
            '    get that width
            Dim col As Range
            Set col = currentCell
            Dim i As Long
            For i = 1 To thisWS.Columns.Count
                Set col = currentCell.Offset(0, i)
                If ((rightmostShape.Left >= col.Left) And _
                    (rightmostShape.Left < (col.Left + col.Width))) Then
                    Exit For
                End If
            Next i
            '--- now use the column width to add the shape
            Set newShape = thisWS.Shapes.AddShape(Type:=msoShapeRectangle, _
                                                  Left:=.Left + .Width, _
                                                  Top:=.Top, _
                                                  Width:=col.Width, _
                                                  Height:=.Height)
        End With
    End If
    
    If ShapeColor <> -1 Then
        newShape.Fill.ForeColor.RGB = ShapeColor
    End If
    
    If ShapeText <> vbNullString Then
        newShape.TextFrame.Characters.Text = ShapeText
    End If
End Sub

Private Function ShapeInlineWith(ByRef currentCell As Range, _
                                 ByRef thisShape As Shape) As Boolean
    '--- IF the given shape is in the same row and somewhere to the right
    '    of the current cell, returns TRUE
    
    '--- same row means TOP is between the cell's top and bottom
    If ((thisShape.Top >= currentCell.Top) And _
        (thisShape.Top < (currentCell.Top + currentCell.Height))) Then
        ShapeInlineWith = True
    Else
        ShapeInlineWith = False
    End If
End Function