none
Problem with adding shapes using VBA macro RRS feed

  • Question

  • Hello! My name is Jenny and I am working on some code that will insert 6 rectangle shapes based on corresponding length and width values that are in 12 separate cells. I got the code figured out to do this, but the calculation doesn't seem to 100% be working. I realized that VBA reads things in pts. Therefore, I used a formula to transition the length/width values that were in inches into points (I just multiplied the value by 72). The problem is that it isn't inserting shapes that are the correct size. You can really see this when I make all 6 shapes into what should be perfect squares. When the shapes are inserted, not all 6 squares are "perfect". In the file attached, you will see that when you click on Rectangles 1-4, their heights are .01 off. Rectangle 5 and 6 seem to be fine. 

    Do the inches to pts conversation work differently for width and length?

    Can anyone help me fix this? I welcome any ideas and suggestions. Thank you!

    Link to file: https://drive.google.com/file/d/1vXf...ew?usp=sharing

    Monday, December 18, 2017 7:11 PM

All replies

  • Your link results in:

    Sorry, the file you have requested does not exist.

    Make sure that you have the correct URL and the file exists.

    Monday, December 18, 2017 7:20 PM
  • Hi Jenny,

    In advance, sorry if I misunderstand what you want to do.
    (Please share your code or picture.)

    I made a sample:
    [image]
        
    [code]
    ' ---[Add Shapes] button
    Private Sub btn_AddShapes_Click()
        Application.ScreenUpdating = False
        Dim myRow, myCol As Integer
        Dim cellWidth, cellHeight As Single
        Dim cellLeft, cellTop As Single
        ' --- Rows:4, Columns:3
        For myRow = 1 To 4
            For myCol = 1 To 3
                Cells(myRow + 11, myCol + 2).Select
                ' ---
                cellLeft = Selection.Left
                cellTop = Selection.Top
                cellWidth = Selection.Width
                cellHeight = Selection.Height
                ' ---
                ActiveSheet.Shapes.AddShape _
                    (Type:=msoShapeRectangle, _
                    Left:=cellLeft, Top:=cellTop, Width:=cellWidth, Height:=cellHeight).Select
                ' ---
                Selection.ShapeRange.Fill.ForeColor.RGB = RGB(myRow * 30, myCol * 40, myRow * myCol)
            Next
        Next
        ' ---
        Application.ScreenUpdating = True
    End Sub
    ' ---[Create Shapes] button
    Private Sub btn_CreateShapes_Click()
        Dim cnt As Integer
        For cnt = 1 To 6
            Call prc_CreateShape(cnt)
        Next
    End Sub
    ' ---
    Private Sub prc_CreateShape(ByVal cnt As Integer)
        Dim shapeName As String
        Dim locationX, locationY, sizeW, sizeH As Integer
        ' ---
        shapeName = Cells(cnt + 10, 1).Value
        locationX = CInt(Cells(cnt + 10, 2).Value)
        locationY = CInt(Cells(cnt + 10, 3).Value)
        sizeW = CInt(Cells(cnt + 10, 4).Value)
        sizeH = CInt(Cells(cnt + 10, 5).Value)
        ' ---
        ActiveSheet.Shapes.AddShape _
            (Type:=msoShapeRectangle, _
            Left:=locationX, Top:=locationY, Width:=sizeW, Height:=sizeH).Select
        ' ---
        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(cnt * 30, cnt * 40, cnt * 50)
    
    End Sub
    ' ---[Delete Shapes] button
    Private Sub btn_DeleteShapes_Click()
        Dim shp As Shape
        For Each shp In ActiveSheet.Shapes
            If (shp.AutoShapeType = msoShapeRectangle) Then
                shp.Delete
            End If
        Next
    End Sub
    I hope this would be helpful.

    Regards,

    Ashidacchi

    Tuesday, December 19, 2017 6:02 AM