[AutoCAD] Построение 2D сетки по координатам из эксель

Sub Create3DMesh()
  
    Dim AP As Excel.Application
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim LastRow As Long
 
'Подключение и поиск файла Эксель
 
    Set AP = Excel.Application
    fldr = InputBox("Укажите адрес файла")
    Excel.Workbooks.Open filename:=fldr
    Set wb = AP.Workbooks.Open(fldr)
    Set ws = wb.Worksheets("Лист1")
  
    Dim meshObj As AcadPolygonMesh
    Dim mSize, nSize, Count As Integer
  
    Dim points() As Double
    ReDim points(0 To (Worksheets.Item("Лист1").Cells(2, 2).End(xlDown).Row - 1) * 3 - 1) As Double
  
    For i = LBound(points) To Worksheets.Item("Лист1").Cells(2, 2).End(xlDown).Row - 2
    points(i * 3) = Worksheets.Item("Лист1").Cells(2 + i, 2).Value
    points(i * 3 + 1) = Worksheets.Item("Лист1").Cells(2 + i, 3).Value
    points(i * 3 + 2) = Worksheets.Item("Лист1").Cells(2 + i, 4).Value
 
     mSize = 3: nSize = 3
 
    Next i
 
    Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, points)
    ZoomAll
    Set meshObj = Nothing
    Set xlApp = Nothing
    Set docXl = Nothing
 
 
    R = R + 1
 
 
End Sub

Sub Create3DMesh_two_dimensional()
 
Const fStart As String = "D:\"              'Папка по умолчанию для выбора файлов
Const R0 As String = "B2"                   'Адрес первой верхней левой ячейки с координатами
Const Sh As String = "Лист1"
 
Dim AP As Object
Dim fldr As String
Dim points, i0 As Long, irow As Long, icol As Long
 
Set AP = CreateObject("Excel.Application")
 
If Not FileName(AP, fldr, fStart) Then
    MsgBox "Excel-файл с координатами не выбран"
    Exit Sub
End If
 
With AP
    .Visible = False 'True  '  False
    .Application.DisplayAlerts = False
    .Application.ScreenUpdating = False
    .Workbooks.Open (fldr)
    
    points = .Sheets(Sh).Range(R0).Resize(.Range(R0).End(-4121).Row - .Range(R0).Row + 1, 3)
        
    .ActiveWorkbook.Close
    .Application.DisplayAlerts = True
    .Application.ScreenUpdating = True
End With
Set AP = Nothing
 
i0 = LBound(points, 1): irow = UBound(points, 1): icol = UBound(points, 2)
 
MsgBox CStr(points(i0, i0)) + vbTab + CStr(points(i0, i0 + 1)) + vbTab + CStr(points(i0, i0 + 2)) + vbCr + _
        CStr(points(irow, i0)) + vbTab + CStr(points(irow, i0 + 1)) + vbTab + CStr(points(irow, i0 + 2))
 
'    Dim meshObj As AcadPolygonMesh
'    Dim mSize, nSize, Count As Integer
'    Set meshObj = Nothing
'    Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, points)
'    ZoomAll
End Sub
 
Sub Create3DMesh_one_dimensional()
 
Const fStart As String = "D:\"              'Папка по умолчанию для выбора файлов
Const R0 As String = "B2"                   'Адрес первой верхней левой ячейки с координатами
Const Sh As String = "Лист1"
 
Dim AP As Object
Dim fldr As String
Dim points, i0 As Long, irow As Long, icol As Long, i As Long
Dim Rpoints As Object, xyz As Object
 
Set AP = CreateObject("Excel.Application")
 
If Not FileName(AP, fldr, fStart) Then
    MsgBox "Excel-файл с координатами не выбран"
    Exit Sub
End If
 
With AP
    .Visible = False 'True  '  False
    .Application.DisplayAlerts = False
    .Application.ScreenUpdating = False
    .Workbooks.Open (fldr)
    
    
    Set Rpoints = .Sheets(Sh).Range(R0).Resize(.Range(R0).End(-4121).Row - .Range(R0).Row + 1, 3)
    i0 = 0: icol = Rpoints.Count
    
    ReDim points(i0 To icol - 1)
    i = i0
    For Each xyz In Rpoints
        points(i) = xyz
        i = i + 1
    Next
    .ActiveWorkbook.Close
    .Application.DisplayAlerts = True
    .Application.ScreenUpdating = True
End With
Set AP = Nothing
 
i0 = LBound(points, 1): icol = UBound(points, 1)
 
MsgBox CStr(points(i0)) + vbTab + CStr(points(i0 + 1)) + vbTab + CStr(points(i0 + 2)) + vbCr + _
        CStr(points(icol - 2)) + vbTab + CStr(points(icol - 1)) + vbTab + CStr(points(icol))
 
'    Dim meshObj As AcadPolygonMesh
'    Dim mSize, nSize, Count As Integer
'    Set meshObj = Nothing
'    Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, points)
'    ZoomAll
End Sub
 
 
Function FileName(AP As Object, FileXls As String, StartF As String) As Boolean
 
With AP.FileDialog(3)
    .AllowMultiSelect = False
    .Title = "Выбирайте файл с координатами"        'заголовок окна диалога
    .Filters.Clear                                  'очищаем установленные ранее типы файлов
    .Filters.Add "Файлы Excel", "*.xls*", 1         'устанавливаем возможность выбора только файлов Excel
    .FilterIndex = 1                                'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
    .InitialFileName = StartF                       'назначаем папку отображения и имя файла по умолчанию
    .InitialView = 2                                'вид диалогового окна(доступно 9 вариантов)
 
    FileName = Not .Show = 0
    If FileName Then FileXls = .SelectedItems(1) Else FileXls = ""
End With
End Function