Manipulating shapes with VBA

Option Explicit
Option Base 1

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
' Declare a UDT to store a GUID for the IPicture OLE Interface
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Public Type uPicDesc    ' Declare a UDT to store the bitmap information
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Public Const CF_BITMAP = 2, PICTYPE_BITMAP = 1
Const SPI_SETDESKWALLPAPER = 20

Public Declare Function SystemParametersInfo Lib "user32" _
Alias "SystemParametersInfoA" (ByVal uAction As Long, _
ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Public Type triangle
    x(3) As Single
    y(3) As Single
    t_area As Double
    npar As Integer
    out As Boolean
    gc As Integer
End Type
Public tri() As triangle, i%, j%, n%, m%, svar, miss As Boolean
Dim dv%, p%, rv%, ws As Worksheet, wdir$, estr$

Sub TMaker(x!(), y!())
    Dim ta!(4, 2)
    ta(1, 1) = x(1)
    ta(1, 2) = y(1)
    ta(2, 1) = x(2)
    ta(2, 2) = y(2)
    ta(3, 1) = x(3)
    ta(3, 2) = y(3)
    ta(4, 1) = x(1)
    ta(4, 2) = y(1)
    Worksheets("Canvas").Shapes.AddPolyline ta
End Sub

Sub Gen(need As Boolean)
Dim tpg%, comp%, xstep%, ystep%, st$
miss = False
tpg = n \ 5                 ' triangles per group
comp = n Mod 5              ' remainder joins fifth and last group
xstep = 50
ystep = 30
If need Then
    Eraser
    Sheets("Dat").Range("c3:h104").ClearContents
    For i = 1 To 5
        Gb 3 + (i - 1) * tpg, 2 + (i - 1) * tpg + tpg, 1300 - i * xstep, 600 - i * ystep, _
        i * xstep, i * ystep
    Next
    Gb 3 + 5 * tpg, 2 + 5 * tpg + comp, 1300 - 5 * xstep, 600 - 5 * ystep, 5 * xstep, 5 * ystep
End If
st = "c3:h" & LastRow
If WorksheetFunction.CountBlank(Range(st)) > 0 Then
    MsgBox "Missing data at Dat page", vbCritical
    miss = True
    Exit Sub
End If
For i = 3 To n + 2
    For j = 3 To 5
        tri(i - 2).x(j - 2) = Sheets("Dat").Cells(i, j).Value
    Next j
Next i
For i = 3 To n + 2
    For j = 6 To 8
        tri(i - 2).y(j - 5) = Sheets("Dat").Cells(i, j).Value
    Next j
Next i
End Sub

Sub Gb(start%, endrow%, xi%, yi%, xs%, ys%)
Dim xseed!, yseed!, c%
Randomize
For c = start To endrow                     ' rows
    xseed = xi * Rnd
    yseed = yi * Rnd
    For j = 3 To 5                          ' columns
        Sheets("Dat").Cells(c, j).Value = xseed + xs * Rnd
    Next
    For j = 6 To 8                          ' columns
        Sheets("Dat").Cells(c, j).Value = yseed + ys * Rnd
    Next
Next
End Sub

Sub WhoStays()
Dim k%, m%, ni%, a(), B()
a() = Array(1, 1, 2)
B() = Array(2, 3, 3)
For k = 1 To n - 1
    For m = k + 1 To n
        For i = 1 To 3
            For j = 1 To 3
                If lines_si(tri(k).x(a(i)), tri(k).y(a(i)), tri(k).x(B(i)), tri(k).y(B(i)), _
                tri(m).x(a(j)), tri(m).y(a(j)), tri(m).x(B(j)), tri(m).y(B(j))) Then
                    If tri(k).t_area > tri(m).t_area Then tri(m).out = True
                    If tri(k).t_area < tri(m).t_area Then tri(k).out = True
                End If
            Next
        Next
    Next
Next
ni = 0
For i = 1 To n
    If tri(i).out Then ni = ni + 1
Next

End Sub

Sub AreaCalc()
For i = 1 To n
    tri(i).t_area = TriArea(tri(i).x, tri(i).y)
Next
End Sub

Sub Opening(gv As Boolean)
If gv Then n = Sheets("Controls").Cells(29, 6).Value
If Not gv Then n = LastRow - 2
If n < 1 Then
    MsgBox "Data table is empty!", vbExclamation
    Exit Sub
End If
ReDim tri(n)
For i = 1 To n
    tri(i).out = False
    tri(i).npar = 0
    tri(i).t_area = 0
Next
Gen gv
AreaCalc
If Not miss Then WhoStays
svar = 1
End Sub

Sub Main(gv As Boolean)
Dim k%, m%, nlev%, step!(3), est$
If svar = Empty Or svar = 0 Then Opening gv
If n < 1 Then Exit Sub
If miss Then Exit Sub
Sheets("Canvas").Activate
For i = 1 To n - 1                          ' base
    If Not tri(i).out Then
        For j = i + 1 To n                      ' others to the right
            If Not tri(j).out Then DefPar
        Next
    End If
Next
Sheets("Aux").Range("d1:f100").ClearContents
For i = 1 To n
    Sheets("Aux").Cells(i, 4) = tri(i).t_area
    Sheets("Aux").Cells(i, 5) = i
    Sheets("Aux").Cells(i, 6) = tri(i).out
Next
SortAreas
For i = 1 To n                      ' draw bigger ones first
    j = Sheets("Aux").Cells(i, 5).Value
    TMaker tri(j).x, tri(j).y
Next
nlev = tri(1).npar
For i = 2 To n
    If tri(i).npar > nlev Then nlev = tri(i).npar
Next
step(1) = (0.9 * Range("RedV")) / (nlev + 1)
step(2) = (0.9 * Range("GreenV")) / (nlev + 1)
step(3) = (0.9 * Range("BlueV")) / (nlev + 1)
For i = 1 To n
    j = Sheets("Aux").Cells(i, 5).Value
    ActiveSheet.Shapes(i).Fill.ForeColor.RGB = RGB(Range("RedV") - (tri(j).npar + 1) * step(1), _
    Range("GreenV") - (tri(j).npar + 1) * step(2), Range("BlueV") - (tri(j).npar + 1) * step(3))
Next
est = " "
For i = 1 To n
    est = est & tri(i).npar & "  "
Next
End Sub

Sub DefPar()
Dim xa!(3), ya!(3), ind%, k%, bv As Boolean
bv = tri(i).t_area > tri(j).t_area
Select Case bv
    Case True
        ind = 0
        CClock tri(i).x, tri(i).y, xa, ya
        For k = 1 To 3
            If Inside(xa, ya, tri(j).x(k), tri(j).y(k)) Then ind = ind + 1
        Next
        If ind = 3 Then tri(j).npar = tri(j).npar + 1
    Case False
        ind = 0
        CClock tri(j).x, tri(j).y, xa, ya
        For k = 1 To 3
            If Inside(xa, ya, tri(i).x(k), tri(i).y(k)) Then ind = ind + 1
        Next
        If ind = 3 Then tri(i).npar = tri(i).npar + 1
End Select
End Sub

Sub SortAreas()
Dim es$
If n < 1 Then Exit Sub
ActiveWorkbook.Worksheets("Aux").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Aux").Sort.SortFields.Add Key:=Range("d1"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
es = "d1:f" & n
With ActiveWorkbook.Worksheets("Aux").Sort
    .SetRange Range(es)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

Public Function LastRow() As Long
    Sheets("Dat").Activate
    If WorksheetFunction.CountA(Cells) = 0 Then
        LastRow = 0
        Exit Function
    End If
    LastRow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
End Function
Sub Invisibles()
Application.ScreenUpdating = False

If svar = Empty Or svar = 0 Then Opening False
n = Sheets("Canvas").Shapes.Count
For i = 1 To n
    j = Sheets("Aux").Cells(i, 5).Value
    If tri(j).out Then Sheets("Canvas").Shapes(i).Visible = False
Next
CCopy
Application.ScreenUpdating = True

End Sub

Sub Eraser()
Dim esh As Shape
For Each esh In Sheets("Canvas").Shapes
    esh.Delete
Next
svar = 0
End Sub

Sub ChangeColorSwatch()
    ActiveSheet.Range("RedSwatch").Interior.Color = RGB(Range("RedV"), 0, 0)
    ActiveSheet.Range("GreenSwatch").Interior.Color = RGB(0, Range("GreenV"), 0)
    ActiveSheet.Range("BlueSwatch").Interior.Color = RGB(0, 0, Range("BlueV"))
    ActiveSheet.Range("CombinedColor").Interior.Color = RGB(Range("RedV"), _
    Range("GreenV"), Range("BlueV"))
End Sub

Sub TriTexture()
Sheets("Canvas").Activate
n = ActiveSheet.Shapes.Count
Randomize
For i = 1 To n
    ActiveSheet.Shapes(i).Fill.PresetTextured PresetTexture:=1 + Round(20 * Rnd, 0)
Next
End Sub

Sub TogShadow()
Set ws = Sheets("Canvas")
n = ws.Shapes.Count
If n = 0 Then Exit Sub

For i = 1 To n
    ws.Shapes(i).Shadow.Visible = Not ws.Shapes(i).Shadow.Visible
Next
If ws.Shapes(1).Shadow.Visible Then
    For i = 1 To n
        With ws.Shapes(i).Shadow
            .Transparency = 0.8
            .OffsetX = 30
            .OffsetY = 30
            .Blur = 12
        End With
    Next
End If
End Sub

Sub Tog3D()
Set ws = Sheets("Canvas")
If svar = Empty Or svar = 0 Then Opening False
For i = 1 To n
    ws.Shapes(i).ThreeD.Visible = Not ws.Shapes(i).ThreeD.Visible
Next
If ws.Shapes(1).ThreeD.Visible Then
    For i = 1 To n
        dv = Round(0.002 * tri(i).t_area, 0) + 1
        If dv > 50 Then dv = 50
        With ws.Shapes(i).ThreeD
            .Depth = dv
            .BevelTopDepth = 8
            .RotationY = 10
        End With
    Next
End If
End Sub

Sub TriGrad()
n = Sheets("Canvas").Shapes.Count
Randomize
For i = 1 To n
        
    With Sheets("Canvas").Shapes(i).Fill
        .TwoColorGradient Style:=1 + Round(4 * Rnd, 0), Variant:=2
        .ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
        .BackColor.ObjectThemeColor = 1 + Round(15 * Rnd, 0)
    End With
Next
End Sub

Sub TriPatt()
n = Sheets("Canvas").Shapes.Count
Randomize
For i = 1 To n
    With Sheets("Canvas").Shapes(i).Fill
        .Patterned Pattern:=1 + Round(49 * Rnd, 0)
        .ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
        .BackColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
    End With
Next
End Sub

Sub CCopy()
Dim p As Object, q As Object, t!, L!, w!, h!
Application.ScreenUpdating = False
For Each p In Sheets("Controls").Pictures
    If p.Width > 200 Then p.Delete          ' protect command buttons
Next
Sheets("Canvas").Range("a1:ad43").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Sheets("Controls").Paste
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
For Each p In Sheets("Controls").Pictures
    If p.Width > 200 Then Set q = p
Next
With Sheets("Controls").Range("j2:v21")
        t = .Top
        L = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
End With
q.ShapeRange.LockAspectRatio = msoFalse
q.Placement = xlMoveAndSize
q.Top = t
q.Left = L
q.Width = w
q.Height = h
Set q = Nothing
Sheets("Canvas").Activate
Application.ScreenUpdating = True
End Sub

Sub CImage()
Sheets("Canvas").Range("a1:ad43").CopyPicture
Sheets("Controls").Paste Destination:=Worksheets("Controls").Range("j2:t21")
End Sub
Function TriArea(x!(), y!())
TriArea = 0.5 * Abs((x(1) * (y(2) - y(3)) + x(2) * (y(3) - y(1)) + x(3) * (y(1) - y(2))))
End Function

Sub CClock(x!(), y!(), fx!(), fy!())       ' arranges vertices in counter clockwise order
Dim r%, S%, L%
If x(1) >= x(2) And x(1) >= x(3) Then
    r = 1                       ' first
    If y(2) >= y(3) Then
        S = 2                   ' second
        L = 3                   ' last
    Else
        S = 3
        L = 2
    End If
ElseIf x(2) >= x(1) And x(2) >= x(3) Then
    r = 2
    If y(1) >= y(3) Then
        S = 1
        L = 3
    Else
        S = 3
        L = 1
    End If
ElseIf x(3) >= x(1) And x(3) >= x(2) Then
    r = 3
    If y(1) >= y(2) Then
        S = 1
        L = 2
    Else
        S = 2
        L = 1
    End If
End If
fx(1) = x(r)
fx(2) = x(S)
fx(3) = x(L)
fy(1) = y(r)
fy(2) = y(S)
fy(3) = y(L)
End Sub

Function Inside(x!(), y!(), px!, py!)   ' must receive vertices in counter clockwise order
Inside = False
If ((px - x(1)) * (y(2) - y(1)) - (py - y(1)) * (x(2) - x(1))) > 0 Then Exit Function
If ((px - x(2)) * (y(3) - y(2)) - (py - y(2)) * (x(3) - x(2))) > 0 Then Exit Function
If ((px - x(3)) * (y(1) - y(3)) - (py - y(3)) * (x(1) - x(3))) > 0 Then Exit Function
Inside = True
End Function

Function lines_si(x1!, y1!, x2!, y2!, x3!, y3!, x4!, y4!) As Boolean
Dim x5!, y5!, ival%, u!, v!     ' computes the intersection of two lines
x5 = 0
y5 = 0
Lines_exp_int x1, y1, x2, y2, x3, y3, x4, y4, ival, x5, y5
If ival = 0 Then
    lines_si = False
    Exit Function
End If
Line_seg_contains_point x1, y1, x2, y2, x5, y5, u, v
If u < 0 Or 1 < u Or v > 0.001 Then
    lines_si = False
    Exit Function
End If
Line_seg_contains_point x3, y3, x4, y4, x5, y5, u, v
If u < 0 Or 1 < u Or v > 0.001 Then
    lines_si = False
    Exit Function
End If
lines_si = True
End Function

Sub Lines_exp_int(x1!, y1!, x2!, y2!, x3!, y3!, x4!, y4!, ival%, x!, y!)
Dim point1 As Boolean, point2 As Boolean, a1!, b1!, c1!, a2!, b2!, c2!
ival = 0        ' finds where two explicit lines intersect
x = 0
y = 0
If x1 = x2 And y1 = y2 Then
    point1 = True
Else
    point1 = False
End If
If x3 = x4 And y3 = y4 Then
    point2 = True
Else
    point2 = False
End If
If Not point1 Then line_exp2imp x1, y1, x2, y2, a1, b1, c1
If Not point2 Then line_exp2imp x3, y3, x4, y4, a2, b2, c2
If point1 And point2 Then
    If x1 = x3 And y1 = y3 Then
        ival = 1
        x = x1
        y = y1
    End If
ElseIf point1 Then
    If (a2 * x1 + b2 * y1) = c2 Then
        ival = 1
        x = x1
        y = y1
    End If
ElseIf point2 Then
    If (a1 * x3 + b1 * y3) = c1 Then
        ival = 1
        x = x3
        y = y3
    End If
Else
    lines_imp_int a1, b1, c1, a2, b2, c2, ival, x, y
End If
End Sub

Sub Line_seg_contains_point(x1!, y1!, x2!, y2!, x3!, y3!, u!, v!)
Dim unit!
unit = Sqr((x2 - x1) ^ 2 + (y2 - y1) ^ 2)
If unit = 0 Then
    If x3 = x1 And y3 = y1 Then
        u = 0.5
        v = 0
    Else
        u = 0.5
        v = 1E+20
    End If
Else
    u = ((x3 - x1) * (x2 - x1) + (y3 - y1) * (y2 - y1)) / (unit * unit)
    v = Sqr(((u - 1) * x1 - u * x2 + x3) ^ 2 + ((u - 1) * y1 - u * y2 + y3) ^ 2) / unit
End If
End Sub

Sub line_exp2imp(x1!, y1!, x2!, y2!, a!, B!, c!)
If x1 = x2 And y1 = y2 Then         ' explicit to implicit form
    MsgBox "Fatal error"
    Exit Sub
End If
a = y2 - y1
B = x1 - x2
c = x2 * y1 - x1 * y2
End Sub

Sub lines_imp_int(a1!, b1!, c1!, a2!, b2!, c2!, ival%, x!, y!)
Dim a!(2, 2), B!(2, 2), det!        ' where two implicit lines intersect
x = 0
y = 0
If a1 = 0 And b1 = 0 Then
    ival = -1
    Exit Sub
ElseIf a2 = 0 And b2 = 0 Then
    ival = -2
    Exit Sub
End If
a(1, 1) = a1
a(1, 2) = b1
a(2, 1) = a2
a(2, 2) = b2
Rmat2_inv a, B, det
If det <> 0 Then
    ival = 1
    x = -B(1, 1) * c1 - B(1, 2) * c2
    y = -B(2, 1) * c1 - B(2, 2) * c2
Else
    ival = 0
    If a1 = 0 Then
        If b2 * c1 = c2 * b1 Then ival = 2
    Else
        If a2 * c1 = c2 * a1 Then ival = 2
    End If
End If
End Sub

Sub Rmat2_inv(a, B, det!)       ' inverts a matrix
det = a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1)
If det = 0 Then
    B(1, 1) = 0
    B(1, 2) = 0
    B(2, 1) = 0
    B(2, 2) = 0
    Exit Sub
End If
B(1, 1) = a(2, 2) / det
B(1, 2) = -a(1, 2) / det
B(2, 1) = -a(2, 1) / det
B(2, 2) = a(1, 1) / det
End Sub

Sub hide()
Sheets("Aux").Visible = xlSheetVeryHidden
End Sub
Function DECIMAL2RGB(ColorVal) As Variant
'   Converts a color value to an RGB triplet
'   Returns a 3-element variant array
    DECIMAL2RGB = Array(ColorVal \ 256 ^ 0 And 255, ColorVal \ 256 ^ 1 And 255, ColorVal \ 256 ^ 2 And 255)
End Function

Function RGB2DECIMAL(r, G, B)
    RGB2DECIMAL = RGB(r, G, B)
End Function

Function Round(alpha, beta) As Long
   Round = WorksheetFunction.Round(alpha, beta)
End Function

Sub WriteDir()
    Dim Msg$, f$, r&
    Msg = "Select a location to store the file."
    If Cells(42, 5).Value Then
        wdir = GetDirectory(Msg)
        If wdir = "" Then Exit Sub
        If Right(wdir, 1) <> "\" Then wdir = wdir & "\"
        Sheets("Controls").Cells(22, 22).Value = wdir
    Else
        wdir = Sheets("Controls").Cells(22, 22).Value
    End If
End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO, path$, r&, x&, pos%
' Root folder = Desktop
    bInfo.pidlRoot = 0&
' Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
' Type of directory to return
    bInfo.ulFlags = &H1
' Display the dialog
    x = SHBrowseForFolder(bInfo)
' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

Private Sub SaveRangePic(SourceRange As Range, FilePathName$)
    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim IPic As IPicture, hPtr&
    On Error Resume Next
    SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    With IID_IDispatch          ' Create the interface GUID for the picture
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPtr ' Handle to image.
        .hPal = 0 ' Handle to palette (if bitmap).
    End With
   ' Create the Range Picture Object
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    stdole.SavePicture IPic, FilePathName
    If Err.Number <> 0 Then
        MsgBox "Directory not valid.", vbCritical
        Sheets("Controls").Cells(22, 22).Value = " "
    End If
End Sub

Sub SaveImage()
estr = Time
estr = WorksheetFunction.Substitute(estr, ":", "0")
estr = wdir & "wp" & estr & ".bmp"
SaveRangePic Sheets("Canvas").Range("A1:ab41"), estr
End Sub

Public Sub SetWallpaper(ByVal FileName$)
Dim ret&
ret = SystemParametersInfo(20, 0&, FileName, &H2 Or &H1)
End Sub

Sub NewWall()
WriteDir
SaveImage
If Err.Number = 0 Then SetWallpaper (estr)
End Sub