VBA – Drawing objects with VBA in Excel

How much time do you need to build something like this in Excel?

At least 20 minutes + a lot of lost nerves for the formatting. Unless you use VBA and you build it within some seconds 🙂

Pretty much the code is quite easy to be understood and modified – what is interesting is the name of the shape and the randomizing function. The name of the shape is taken from the Excel Macro Recorder and in my case I use two forms – msoShapeDownRibbon and msoShapeUpRibbon. The randomizing function is pretty obvious and can be reused in any project.

Something else, quite useful for working with forms – calculating their x and y position. In my case the y is standard, as all the shapes are in line and the x is calculated with the formula x = n * i / k, where n is a constant for the size of the shape, i is the position of the character in the string and k is the total characters of the string. To convert this numbers to points from inches (as far as Excel uses this metric system), we use the build-in function InchesToPoints – press F2 in VBE and write “InchesToPoints” for more information:

Last but not least, we use module calculation in order to select which shape to use – if i mod 2  returns 1, we use the msoShapeUpRibbon, and if it returns 0 we use the msoShapeDownRibbon. And it works! 🙂

Sub DrawName()

    Dim i           As Integer
    Dim x           As Single
    Dim y           As Single
    Dim z           As Single
    Dim rng         As Range
    Dim n           As Single
    Dim k           As Integer
    Dim sSize       As Single
    Dim sh          As Shape
    Dim sName       As String
    Dim StartLeft   As Single
    Dim StartTop    As Single
    
    StartLeft = ActiveCell.Left
    StartTop = ActiveCell.Top
    sName = "Welcome to Vitosh Academy !"
    
    n = 17
    k = Len(sName)
    sSize = Application.InchesToPoints(1)

    For i = 1 To k
        If Mid(sName, i, 1) <> " " Then
        
            x = n * i / k
            x = Application.InchesToPoints(x)
            y = Application.InchesToPoints(z)

            If i Mod 2 = 1 Then
                Set sh = ActiveSheet.Shapes.AddShape(msoShapeUpRibbon, StartLeft + x, StartTop + y, sSize, sSize)
            Else
                Set sh = ActiveSheet.Shapes.AddShape(msoShapeDownRibbon, StartLeft + x, StartTop + y, sSize, sSize)
            End If
            
            sh.Fill.ForeColor.RGB = RGB(GiveRandom(150, 200), GiveRandom(200, 255), GiveRandom)
            sh.Fill.Visible = msoTrue
            
            sh.TextFrame.Characters.text = UCase(Mid(sName, i, 1))
            sh.TextFrame.Characters.Font.Size = 20
            sh.TextFrame.Characters.Font.Name = "Arial"
            sh.TextFrame.Characters.Font.Bold = True
            sh.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
            
            sh.TextFrame2.VerticalAnchor = msoAnchorMiddle
            sh.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        End If
    Next i
End Sub

Function GiveRandom(Optional lowerBound As Integer = 100, Optional upperBound As Integer = 255) As Integer
    Randomize Timer
    GiveRandom = Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
End Function

Enjoy it!