Excel+Autocad+VBA

[Nicolas_46]

дорогие товарищи програмисты!
вопрос назрел у меня может и не совсем в тему, но спросить решил
именно у вас.

Настроил я передачу данных из excel в autocad.
все работает как надо, данные отображаются в каде в виде таблицы)))

вопрос вот в чем, как связать обьект построенный в автокаде с данными в таблице, например при изменении значений в таблице (в каде), менялся радиус и длина цилиндра.

[doober]

Если я правильно понял,то вы пишете процедуру построения вашего цилиндра.Данные берете с таблицы.
Есть в документе такое событие

Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
    
End Sub

После ввода данных проверяете команду(определите сами),только не нарвитесь на повтор последней команды.
При изменении данных объект сотрете ,по новым данных создадите процедурой построения новый.

[Nicolas_46]

Почти, Пишу процедуру построения ротора. В коде задаются координаты построения.
на данный момент код выглядит так:

Sub Ротор()

Dim LineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double

startPoint(0) = 0: startPoint(1) = 20: startPoint(2) = 0
endPoint(0) = 0: endPoint(1) = 83: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 0: startPoint(1) = 83: startPoint(2) = 0
endPoint(0) = 145: endPoint(1) = 83: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 145: startPoint(1) = 83: startPoint(2) = 0
endPoint(0) = 145: endPoint(1) = 120: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 145: startPoint(1) = 120: startPoint(2) = 0
endPoint(0) = 200: endPoint(1) = 120: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
        
startPoint(0) = 200: startPoint(1) = 120: startPoint(2) = 0
endPoint(0) = 200: endPoint(1) = 280: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
        
startPoint(0) = 200: startPoint(1) = 280: startPoint(2) = 0
endPoint(0) = 220: endPoint(1) = 280: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 220: startPoint(1) = 280: startPoint(2) = 0
endPoint(0) = 220: endPoint(1) = 120: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 220: startPoint(1) = 120: startPoint(2) = 0
endPoint(0) = 255: endPoint(1) = 120: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 255: startPoint(1) = 120: startPoint(2) = 0
endPoint(0) = 255: endPoint(1) = 280: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 255: startPoint(1) = 280: startPoint(2) = 0
endPoint(0) = 275: endPoint(1) = 280: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
ZoomAll

startPoint(0) = 275: startPoint(1) = 280: startPoint(2) = 0
endPoint(0) = 275: endPoint(1) = 120: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 275: startPoint(1) = 120: startPoint(2) = 0
endPoint(0) = 350: endPoint(1) = 120: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 350: startPoint(1) = 120: startPoint(2) = 0
endPoint(0) = 350: endPoint(1) = 83: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 350: startPoint(1) = 83: startPoint(2) = 0
endPoint(0) = 500: endPoint(1) = 83: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 500: startPoint(1) = 83: startPoint(2) = 0
endPoint(0) = 500: endPoint(1) = 20: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 0: startPoint(1) = 20: startPoint(2) = 0
endPoint(0) = 500: endPoint(1) = 20: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
endPoint(0) = 500: endPoint(1) = 0: endPoint(2) = 0:
Set LineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
ZoomAll
End Sub

код строит ротор см. рис 1.

я настроил импорт данных из excel в autocad в результате там появилась таблица рис. 2.
но не знаю как привязать значеня в таблице к значения которые задаются в макросе.
и еще роблема в том что участков в таблице может быть больше например 30, соответственно изменится число элементов ротора.


вопрос еще такой возник, как сделать 3D Фигуру вращеня во круг оси програмно, весь google перерыл, не где не нашел(((( не могу получить из первой картинки 3-ю
заранее спасибо)

[doober]

весь google перерыл, не где не нашел

искать надо в папке Help файл справки acad_dev

Построил с Excel.

Ссылка на Автокад 2008

[Nicolas_46]

Сергей, вы реально професиионал и отлично знаете свое дело)))

Есть вопросы по коду, кое что понятно в нем но не все, можно вас попросить сделать коментарии к нему, хочется попробовать адаптировать его для других задач.

еще хотел спросить. что в нем нужно поменять чтобы код использовал не значения длина участка, диаметр, а координаты точек (Х;У) тоесть для отрезка 4 значения.

где можно найти примеры других команд autocad, например как строить ruleserf или extrude
заранее благодарю.

[doober]

Коменты напишу позже и отправлю вам.
Ваш способ подачи данных был самый неудобный.
Если есть набор точек с координатами,то легче всего построить замкнутую область и крутонуть ее.
Алгоритм вы наверное полностью и не поняли.
Я создавал отрезки ,создал область и получил тело вращения.
Надо было за собой прибраться.удалить примитивы.
Во вложении видео.открывайте файл справки .там много примеров есть,в т.ч. и на вычитание тел,выдавливание и т.д.
если у вас нет такой спрвки.напишите в личку,я вам вышлю полный комплект.Полная справка весит в архиве 120 метров

Добавил файл с примерами кодов

[Nicolas_46]

Сергей,огромное спасибо за справку, буду разбираться.
Хочу спросить что нужно добавить в данном макросе чтобы сделать расточку в роторе, грубо говоря, чтобы в центре было отверстие заданного диаметра из Excel. пытался самостоятель разобраться но пока безуспешно(

[doober]

Постройте правильно область.

Sub CreateSolid()
    Set AcadApp = New AcadApplication
    Set MainDoc = AcadApp.Documents.Add
    AcadApp.Visible = True
    Set MS = MainDoc.ModelSpace
    
    Dim NewDirection(0 To 2) As Double
    NewDirection(0) = 1
    NewDirection(1) = -1
    NewDirection(2) = 1
    MainDoc.ActiveViewport.Direction = NewDirection
    MainDoc.ActiveViewport = MainDoc.ActiveViewport
    
    Dim Sh As Worksheet
    Set Sh = ThisWorkbook.Sheets("Лист1")
    Dim linOb As AcadLine
    Dim sPoint(0 To 2) As Double
    Dim ePoint(0 To 2) As Double
    lLastRowMY = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
    dd = Sh.Range("B4:C" & lLastRowMY)
    Count = UBound(dd) * 2 + 1
    Dim curves() As AcadEntity
    ReDim curves(Count)
    Count = 0
    For n = 1 To UBound(dd)
        If n = 1 Then
            sPoint(0) = 0
            sPoint(1) = 40 ' Вместо 0
            ePoint(0) = 0
            ePoint(1) = dd(n, 2)
            Set curves(Count) = MS.AddLine(sPoint, ePoint)
            Count = Count + 1
            sPoint(0) = ePoint(0)
            sPoint(1) = ePoint(1)
            ePoint(0) = dd(n, 1)
            ePoint(1) = dd(n, 2)
            Set curves(Count) = MS.AddLine(sPoint, ePoint)
            Count = Count + 1
        Else
            sPoint(0) = ePoint(0)
            sPoint(1) = ePoint(1)
            ePoint(0) = sPoint(0)
            ePoint(1) = dd(n, 2)
            Set curves(Count) = MS.AddLine(sPoint, ePoint)
            Count = Count + 1
            sPoint(0) = ePoint(0)
            sPoint(1) = ePoint(1)
            ePoint(0) = sPoint(0) + dd(n, 1)
            ePoint(1) = dd(n, 2)
            Set curves(Count) = MS.AddLine(sPoint, ePoint)
            Count = Count + 1

        End If

    Next
    sPoint(0) = ePoint(0)
    sPoint(1) = ePoint(1)
    ePoint(0) = sPoint(0)
    ePoint(1) = 40 ' Вместо 0

    Set curves(Count) = MS.AddLine(sPoint, ePoint)
    Count = Count + 1
    sPoint(0) = ePoint(0)
    sPoint(1) = ePoint(1)
    ePoint(0) = 0
    ePoint(1) = 40 ' Вместо 0
    Set curves(Count) = MS.AddLine(sPoint, ePoint)

    Dim axisPt(0 To 2) As Double
    Dim axisDir(0 To 2) As Double
    Dim angle As Double
    axisPt(0) = 0: axisPt(1) = 0: axisPt(2) = 0
    axisDir(0) = 11: axisDir(1) = 0: axisDir(2) = 0
    angle = 6.28
    Dim regionObj As Variant
    regionObj = MS.AddRegion(curves)
    
    Dim solidObj As Acad3DSolid
    Set solidObj = MS.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle)
    
    
    AcadApp.ZoomAll
    
End Sub

[Nicolas_46]

Понял), тут нужно задавать в ручную диаметр, а к ячейке, например E2, привязать значение как? чтобы диаметр задавался там.

вопрос еще возник такой

Dim axisPt(0 To 2) As Double
    Dim axisDir(0 To 2) As Double
    Dim angle As Double
    axisPt(0) = 0: axisPt(1) = 0: axisPt(2) = 0
    axisDir(0) = 11: axisDir(1) = 0: axisDir(2) = 0
    angle = 6.28

'Я так понял, блок меняет оси координат

Dim regionObj As Variant
    regionObj = MS.AddRegion(curves)
    
    Dim solidObj As Acad3DSolid
    Set solidObj = MS.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle)

этот блок прокручивает во круг оси 0,0,0

я стою примитив, круг, таким образом:

Sub Example_AddCircle()
    Dim circleObj As AcadCircle
    Dim centerPoint(0 To 2) As Double
    Dim radius As Double
    
   centerPoint(0) = 300#: centerPoint(1) = 0#: centerPoint(2) = 0#
    radius = 100#
    Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)
    ZoomAll
    
End Sub

добовляю те блоки в последний код. почему не прокручивается окружность?

[doober]

Dim axisPt(0 To 2) As Double
    Dim axisDir(0 To 2) As Double
    Dim angle As Double
    axisPt(0) = 0: axisPt(1) = 0: axisPt(2) = 0
    axisDir(0) = 11: axisDir(1) = 0: axisDir(2) = 0
    angle = 6.28

Это задается ось вращения в качестве линии.
Угол вращения 360 градусов

Если вы покрутите окружность.получите ТОР.
попробуйте сделать все руками,потом переложите на код.