Треугольная сетка

Option Explicit
Sub DrawTriangleGrid()
     Dim recArr1 As Variant
     Dim recArr2 As Variant
     Dim oPline As AcadLWPolyline
     Dim oLine1 As AcadLine, oLine2 As AcadLine
     Dim varpt As Variant
     Dim oEnt As AcadEntity
     Dim dblElev As Double
     Dim numX As Long
     Dim numY As Long
     Dim dblXAng As Double
     Dim dblYAng As Double
     Dim pi As Double
     pi = Atn(1) * 4
     ThisDrawing.StartUndoMark
     On Error GoTo Err_Control
     With ThisDrawing.Utility
          .GetEntity oEnt, varpt, vbCr & "Select rectangular contour"
          Set oPline = oEnt
     End With
     numX = CDbl(InputBox("Number of division by X axis: ", "Parameter Input"))
     numY = CDbl(InputBox("Number of division by Y axis: ", "Parameter Input", CStr(numX)))
     dblElev = oPline.Elevation
     Dim minPt As Variant
     Dim maxPt As Variant
     oEnt.GetBoundingBox minPt, maxPt
     Dim dblXSize As Double
     Dim dblYSize As Double
     dblXSize = Abs(maxPt(0) - minPt(0)) / numX
     dblYSize = Abs(maxPt(1) - minPt(1)) / numY
     dblXAng = Atn(dblYSize / dblXSize)
     dblYAng = (pi / 2) - dblXAng
     Dim stPt(2) As Double
     Dim endPt(2) As Double
     stPt(0) = minPt(0) + Cos(dblXAng): stPt(1) = minPt(1): stPt(2) = dblElev
     endPt(0) = minPt(0): endPt(1) = minPt(1) + Sin(dblXAng): endPt(2) = dblElev
     Set oLine1 = ThisDrawing.ModelSpace.AddLine(stPt, endPt)
     oLine1.color = 30
     stPt(0) = maxPt(0) - Cos(dblXAng): stPt(1) = minPt(1): endPt(2) = dblElev
     endPt(0) = maxPt(0): endPt(1) = minPt(1) + Sin(dblXAng): endPt(2) = dblElev
     Set oLine2 = ThisDrawing.ModelSpace.AddLine(stPt, endPt)
     oLine2.color = 30
     Dim dblSize As Long
     Dim lngRows As Long
     Dim lngCols As Long
     lngRows = 1
     lngCols = numX
     Set oLine1 = ExtendLine(oLine1, oPline)
     Set oLine2 = ExtendLine(oLine2, oPline)
     recArr1 = oLine1.ArrayRectangular(numY * 2, 1, 1, dblYSize, 0, 0)
     recArr2 = oLine2.ArrayRectangular(numY * 2, 1, 1, dblYSize, 0, 0)
     ThisDrawing.Utility.Prompt vbCr & "Wait..."
     Dim i As Integer, j As Integer
     '//
     ' iterate thorough all lines in array
     For i = 0 To UBound(recArr1)
          Set oLine1 = ExtendLine(recArr1(i), oPline)
     Next i
     For j = 0 To UBound(recArr2)
          Set oLine2 = ExtendLine(recArr2(j), oPline)
     Next j
     ZoomWindow minPt, maxPt
     ThisDrawing.EndUndoMark
Err_Control:
     MsgBox Err.Description
End Sub
Private Function ExtendLine(ByVal ln As AcadLine, ByVal pl As AcadLWPolyline) As AcadLine
     Dim stPnt(2) As Double
     Dim endPnt(2) As Double
     Dim varpt As Variant
     ' get intersection between line and polyline
     varpt = ln.IntersectWith(pl, acExtendBoth)
     If IsEmpty(varpt) = False Then
          If UBound(varpt) = 2 Then
               stPnt(0) = varpt(0): stPnt(1) = varpt(1): stPnt(2) = varpt(2)
               ln.StartPoint = stPnt
               ln.Update
          ElseIf UBound(varpt) = 5 Then
               stPnt(0) = varpt(0): stPnt(1) = varpt(1): stPnt(2) = varpt(2)
               endPnt(0) = varpt(3): endPnt(1) = varpt(4): endPnt(2) = varpt(5)
               ln.StartPoint = stPnt
               ln.EndPoint = endPnt
               ln.Update
          Else
               ln.Delete
          End If
     End If
     Set ExtendLine = ln
End Function