Would you like to create Excel charts similar to these presented here? Let me know - I could help...
30 August, 2023
06 June, 2023
Drawing and Connecting Any Graphical Elements
And within Shapes there is a group of Lines. Most of them are Connectors that can be attached to any of the illustrations and connect them with any others. The last three lines in the group, namely Curve, Freeform Shape, and Scribble, are not Connectors, but allow you to enrich the Excel collection of graphical creations with your own customized shapes/drawings.
Here's an example of possibilities offered by precise connections of the shapes. Just a simple idea:
- select appropriate connector from the Lines collection
- click anywhere on the first graphic element; connection points will appear for you to choose one of them and attach the connector line
- drag the cursor to a connection point on the second connection object
- to adjust appearance of the line, you can right-click on it and choose "Format Shape" to modify the line colour, thickness, style etc.
26 May, 2023
Creating Shapes, Graphics, Illustrations - Part 2
Here is yet another way of creating graphics in Excel - using VBA macro, like this one:
Sub DrawDefShape()
'Draws any defined shape representing Bézier curves
Dim x As Integer, y As Integer
Dim pt(1 To 7, 1 To 2) As Single
Dim rng As Range
Set rng = Sheets("Data").Range("A2:B8")
'Fill array of control point coordinates with values
For x = 1 To 7
For y = 1 To 2
pt(x, y) = rng.Cells(x, y).Value
Next y
Next x
Set myDoc = Worksheets("Data")
myDoc.Shapes.AddCurve SafeArrayOfPoints:=pt
Range("A10").Select
'Display the whole 2D array in MsgBox
For i = 1 To UBound(pt)
dPts = dPts & pt(i, 1) & " " & pt(i, 2) & vbNewLine
Next i
MsgBox dPts
End Sub
Before going into the details of the macro structure and its use, let's look at some examples of curves and shapes you can easily create with it. Here they are:
23 January, 2022
Creating Pixel Art - Iterations
You can use Excel to create some work of art. Over 32000 iterations can be utilized, and this allows to produce lots of pixels in your worksheet and, practically, create unlimited number of 2D 'pictures' and 3D 'sculptures'. All you need is to use the two macros presented at the end of this post (one for drawing and the other for erasing) and some creativity, obviously.
To give you an idea what kind of 'art' I'm talking about, here are just couple of examples:
Before starting your creative work you need to determine name for your picture. Go to Formulas > Define Name in your workbook and enter TRI in the Name: field and =Sheet1!$B$2:$ZZ$601 in Refers to: field.
Next, insert and format two Buttons (Form Controls) similar to what you see here:
Goto to Developer > Insert > Button, add the text (Draw..., Erase...) and assign the two macros to them. You'll use the buttons to create and erase the pictures.
Now you can copy the macros listed below to one of the modules inserted in your workbook (VBAProject). At this point you're ready to start experimenting with the pixel art. There are several parameters (variables) plus functions, formulas, equations, colors etc. that can be changed and manipulated at will.
Here are the macros:
Option Explicit
Sub Sculpture()
'Produces graphics: from random mist to well defined pixel art
'Use provided parameters and translations to define "sculptures"
'Takes several seconds to produce some pixel art
Dim cP(3) As Long
Dim wid As Double
Dim myPts As Single
Dim myRange As Range
Dim cx As Double, cy As Double, rC As Double, iC As Double
Dim xUL As Double, xLL As Double, yUL As Double, yLL As Double
Dim y As Double, x As Double, c As Double, d As Double
Dim intW As Integer, intH As Integer, i As Integer, j As Integer
Dim a As Single, b As Single, sPercent As Single, co As Single
'Color palette; change as needed
cP(0) = 65280 'green
cP(1) = 65535 'yellow
cP(2) = 13382400 'blue
cP(3) = 255 'red
On Error GoTo TheEnd
'Set your canvas range for square cells; here set to B2:ZZ601
Set myRange = Application.InputBox("Select a range in which to create square cells", , _"$B$2:$ZZ$601", Type:=8)
On Error Resume Next
If myRange.Cells.Count = 0 Then Exit Sub
GetWidth: 'Set the width of cells (0.08 is my screen pixel size)
wid = Val(InputBox("Input Column Width:", , "0.08"))
If wid < 0.08 Then
MsgBox "Invalid column width value"
GoTo GetWidth
End If
Application.ScreenUpdating = False
myRange.EntireColumn.ColumnWidth = wid
myPts = myRange(1).Width 'Set row height
myRange.EntireRow.RowHeight = myPts
xLL = -1.02: xUL = 3.02: yLL = -1.02: yUL = 2.59
intW = myRange.Columns.Count: intH = myRange.Rows.Count
Application.Goto reference:="TRI" 'TRI is the named range (=Sheet1!$B$2:$ZZ$601")
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 0 'Background color; set to black
End With
Range("A1").Select
x = 0: y = 0
cx = 1: cy = 0.5
a = Rnd() * (-10 - 10) + 10: b = Rnd() * (-10 - 10) + 10 'Random real numbers between -10 & 10
For j = 1 To 4 'Iterate by colors
Select Case j
Case 1
co = cP(0)
Case 2
co = cP(1)
Case 3
co = cP(2)
Case Else
co = cP(3)
End Select
For i = 1 To 30000 'Number of iterations with each of the colors
x = cx: y = cy
c = Sin(a * x): d = Cos(b * y ^ 2) 'Use any other formulas to get desirable results
cx = d + c * c + 0.6: cy = Sin(2 * a * x) - Sin(c) * d + 0.8 'As above
iC = Int(intW * (cx - xLL) / (xUL - xLL)): rC = Int(intH * (cy - yLL) / (yUL - yLL))
myRange.Cells(1 + rC, 1 + iC).Interior.Color = co
If iC < 2 Then iC = 2: If iC > intW Then iC = intW
If rC < 2 Then rC = 2: If rC > intH Then rC = intH
Next i
Next j
Range("Sheet1!B1").Select
myRange.Cells(1, 1).Offset(-1, 0) = "Basic parameters used: a=" & Format(a, "#0.0;-#0.0") & ", b=" & _Format(b, "#0.0;-#0.0")
Application.ScreenUpdating = True
myRange.Cells(1, 1).Offset(-1, -1).Select
TheEnd:
Set myRange = Nothing
If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
End Sub
Sub EraseSculpt()
'Clear the graphic and restore cell size
Dim TRI As Name
Application.ScreenUpdating = False
Application.Goto reference:="TRI"
Selection.Clear
With Selection
.ColumnWidth = 8.43
.RowHeight = 12.75
End With
Range("B1").Select
Selection.ClearContents
Range("A2").Select
Application.ScreenUpdating = True
End Sub
20 January, 2022
Animation - Flying Objects
The following VBA (Visual Basic Application) code makes Excel shapes and some other graphics flying. In this instance I'm shooting a rocket on my worksheet across the computer screen. This shape is based on Excel graphic named "Graphic 4".
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal iMilliseconds As Long)
Sub Flyer()
Sheet1.Shapes("Graphic 4").Left = 1000 'Starting X
Sheet1.Shapes("Graphic 4").Top = 450 'Starting Y
MoveShp Sheet1.Shapes("Graphic 4"), 0!, 0!, #12:00:01 AM# 'Shape inserted
End Sub
Sub MoveShp(shp As Shape, ByVal coLeft As Single, ByVal coTop As Single, t As Date)
' Moves the shape from start to finish over the interval t
Const xch = 0.018
Const n1 As Long = 30 'Accelerate/decelerate steps
Const n2 As Long = 60 'Coast steps
Const n As Long = 2 * n1 + n2 'Total steps
Dim i As Long 'Step index
Dim stpv As Single 'Coasting, pixels/step
Dim v As Single 'Velocity at current step
Dim cLiLeft As Single, cLiTop As Single 'Left and Top num
Dim cMi As Single 'Frctn denom
Dim coLeftPr As Single, coTopPr As Single 'Previous Left and Top position
stpv = 1 / (n - n1)
With shp
coLeft = coLeft - .Left: coTop = coTop - .Top
coLeftPr = .Left: coTopPr = .Top
For i = 1 To n
Select Case i
Case 1 To n1 'Accelerate
v = stpv * (1 + Cos(xch * 180 * (1 + i / n1))) / 2
Case n1 + 1 To n - n1 'Constant velocity
v = stpv
Case Else 'Decelerate
v = stpv * (1 + Cos(xch * 180 * (1 + (n - i) / n1))) / 2
End Select
.Left = .Left + v * (coLeft - cLiLeft) / (1 - cMi)
.Top = .Top + v * (coTop - cLiTop) / (1 - cMi)
cMi = cMi + v
cLiLeft = .Left - coLeftPr: cLiTop = .Top - coTopPr
DoEvents
Sleep t * 86400000# / n
Next i
End With
End Sub
To use the code in Excel on your computer follow these steps:
- find and insert Graphic 4 shape into your worksheet (if you want to use any other Excel graphic, remember to change the shape name in the above code)
- copy the code and paste it into any module of your project (workbook)
- select the "Flyer" macro from Macros in the ribbon to run it.
If you assign the macro to the shape (by right-clicking it and selecting "Assign Macro..." option), then just click on the shape and it will fly...
Try to run it using some other shapes/objects.