xlCAD (II)

In the previous post we had detailed how to get a basic CAD support inside Excel. Shapes can get drawn in the worksheet, or there is even the possibility to draw them inside a UserForm using calls to API functions -it would gain “a lot” in perfomance if done this way-.
In this post I will show how to convert a worksheet shape (even a FreeForm) to a macro procedure, so it can be replicated elsewhere.
I experienced some problems replicating the exact location, as Excel refuses “negative” coordinates, but finally got it to work.
Another thing that was left was to get the Type of shape, AutoShapeType (if a primitive one -not freeform-, one of those in msoShapeType enumeration).

Option Explicit

Private Sub sShpToMacro()
' Procedure that replicates a shape as macro code
    Dim oShp As Excel.Shape
    Dim oShpSrc As Excel.FreeformBuilder
    Dim oNode As Excel.ShapeNode
    Dim lgNode As Long
    Dim lgRefresh As Long
    Dim PtArray() As Single
    Dim PtArrayF() As Single
    Dim PtArrayB() As Single
    Dim strNode As String
    Dim strSegment As String
    Dim strEditing As String
    Dim bMove As Boolean
    Dim IncrementTop As Single
    Dim IncrementLeft As Single

    Set oShp = ActiveSheet.Shapes(Selection.ShapeRange.Name)
    'Set oShpSrc = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, PtArray(1,1), PtArray(1,2))
    'With oShpSrc
    '    .AddNodes msoSegmentLine, msoEditingAuto, PtArray(1,1), PtArray(1,2)
    '    Set oShp = oShpSrc.ConvertToShape
    'End With
    
    'With oShp.Fill
    '    .Visible = msoTrue
    '    .PresetTextured msoTexturePapyrus
    '    .TextureTile = msoTrue
    '    .TextureOffsetX = 0
    '    .TextureOffsetY = 0
    '    .TextureHorizontalScale = 1
    '    .TextureVerticalScale = 1
    '    .TextureAlignment = msoTextureTopLeft
    '
    '    '.UserPicture "...\file.jpg"
    '    '.TextureTile = msoFalse
    'End With

    With oShp
        'Application.ScreenUpdating = False
        'For lgRefresh = 1 To 1
            'If .AutoShapeType <> msoShapeNotPrimitive Then
            '    ' If shape is a primitive Shape Type, first convert to a NotPrimitive (add a node and remove it)
            '    .Nodes.Insert .Nodes.Count, msoSegmentLine, msoEditingCorner, 100, 100
            '    .Nodes.Delete .Nodes.Count + 1
            'End If
                
            'Set oNode = .Nodes(2)
            '.Nodes.SetPosition 2, oNode.Points(1, 1) + Int(Rnd() * 10), oNode.Points(1, 2) + Int(Rnd() * 10)
            'Set oNode = .Nodes(4)
            '.Nodes.SetPosition 4, oNode.Points(1, 1) + Int(Rnd() * 10), oNode.Points(1, 2) + Int(Rnd() * 10)
        'Next lgRefresh
        'Application.ScreenUpdating = True
        
        ' For first node
        With .Nodes(1)
            Debug.Print "Private Sub sShp_" & oShp.Name & "_ToMacro()"
            Debug.Print vbTab & "Dim oShp as Excel.shape"
            PtArray() = oShp.Nodes(1).Points
            Debug.Print vbTab & "With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") & ")"
        End With
        
        For lgNode = 2 To .Nodes.Count - 1
        ' via SegmentType property:
        ' • If it is msoSegmentLine(0), actual nodes = x;
        ' • if it is msoSegmentCurve, actual nodes = 2 + 2 + (x-2)*3
        ' X is the nodes we can see directly.
            
            Set oNode = .Nodes(lgNode)
            With .Nodes(lgNode)
                On Local Error Resume Next
                Select Case .EditingType
                    Case 0: strEditing = "msoEditingAuto"
                    Case 1: strEditing = "msoEditingCorner"
                    Case 2: strEditing = "msoEditingSmooth"
                    Case 3: strEditing = "msoEditingSymmetric"
                End Select
                On Local Error GoTo 0
                
                Select Case .SegmentType
                    Case 1: strSegment = "msoSegmentCurve"
                        PtArrayB() = oShp.Nodes(lgNode + 0).Points
                        PtArray() = oShp.Nodes(lgNode + 1).Points
                        PtArrayF() = oShp.Nodes(lgNode + 2).Points
                        Debug.Print VBA.String(2, vbTab) & _
                                    ".AddNodes " & strSegment & ", " & strEditing _
                                                              & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 2), 1), ",", ".") _
                                                              & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") _
                                                              & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 2), 1), ",", ".") '& vbCrLf
                        lgNode = lgNode + 2
                    Case 0: strSegment = "msoSegmentLine"
                        PtArray() = .Points
                        Debug.Print VBA.String(2, vbTab) & _
                                    ".AddNodes " & strSegment & ", " & strEditing & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") '& vbCrLf
                End Select
            End With
        Next lgNode
        
        ' For last node
        Select Case oShp.Nodes(oShp.Nodes.Count).SegmentType
            Case 1: strSegment = "msoSegmentCurve"
                If fDistance2DNode(oShp.Nodes(oShp.Nodes.Count - 1), oShp.Nodes(1)) = 0 Then
                    PtArrayB() = oShp.Nodes(oShp.Nodes.Count - 2).Points
                    PtArray() = oShp.Nodes(oShp.Nodes.Count - 1).Points
                    PtArrayF() = oShp.Nodes(1).Points
                    Debug.Print VBA.String(2, vbTab) & _
                                ".AddNodes " & strSegment & ", " & strEditing _
                                                          & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 2), 1), ",", ".") _
                                                          & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") _
                                                          & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 2), 1), ",", ".") '& vbCrLf
                End If
            Case 0: strSegment = "msoSegmentLine"
                PtArray() = oShp.Nodes(oShp.Nodes.Count).Points
                Debug.Print VBA.String(2, vbTab) & _
                            ".AddNodes " & strSegment & ", " & strEditing & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") '& vbCrLf
        End Select
        Debug.Print VBA.String(2, vbTab) & "Set oShp = .ConvertToShape"
    
        For Each oNode In .Nodes
            If oNode.Points(1, 1) < 0 Then bMove = True If IncrementLeft > oNode.Points(1, 1) Then IncrementLeft = oNode.Points(1, 1)
            End If
            If oNode.Points(1, 2) < 0 Then bMove = True If IncrementTop > oNode.Points(1, 2) Then IncrementTop = oNode.Points(1, 2)
            End If
        Next oNode
        If bMove Then
            Debug.Print VBA.String(1, vbTab) & "With oShp"
            Debug.Print VBA.String(2, vbTab) & ".IncrementLeft " & VBA.Replace(VBA.Round(IncrementLeft, 1), ",", ".")
            Debug.Print VBA.String(2, vbTab) & ".IncrementTop " & VBA.Replace(VBA.Round(IncrementTop, 1), ",", ".")
            Debug.Print VBA.String(1, vbTab) & "End With"
        End If
        Debug.Print VBA.String(1, vbTab) & "End With"
        Debug.Print "End Sub"
    End With
End Sub

Private Function fDistance2DNode(ByVal oNode1 As Excel.ShapeNode, ByVal oNode2 As Excel.ShapeNode) As Double
    fDistance2DNode = VBA.Sqr((oNode1.Points(1, 1) - oNode2.Points(1, 1)) ^ 2 + (oNode1.Points(1, 2) - oNode2.Points(1, 2)) ^ 2)
End Function

With this basic structure done, we can modify code to get the fill and contour of the shape, and any other property as Comments,…

Leave a Reply

Your email address will not be published. Required fields are marked *