| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Выдавливание вдоль линии (VBA)

Выдавливание вдоль линии (VBA)

Ответ
Поиск в этой теме
Непрочитано 22.03.2010, 21:13 #1
Выдавливание вдоль линии (VBA)
Markiza-2010
 
Студентка
 
Регистрация: 09.03.2010
Сообщений: 16

Здравствуйте! Как можно выдавить объект вдоль наклонной (или изогнутой) линии. В справке VBA (AutoCAD) приведён следующий пример кода, но в нём используется не AddPolyline, а AddSpline. А если я строю всё-таки линию для выдавливания, то ничего не выдавливается. Помогите, пожалуйста, исправить код!
Код:
[Выделить все]
Sub Example_AddExtrudedSolidAlongPath()
    ' This example extrudes a solid from a region
    ' along a path defined by a spline.
    ' The region is created from an arc and a line.
    
    Dim curves(0 To 1) As AcadEntity
    ' Define the arc
    Dim centerPoint(0 To 2) As Double
    Dim radius As Double
    Dim startAngle As Double
    Dim endAngle As Double
    centerPoint(0) = 5#: centerPoint(1) = 3#: centerPoint(2) = 0#
    radius = 2#
    startAngle = 0
    endAngle = 3.141592
    Set curves(0) = ThisDrawing.ModelSpace.AddArc(centerPoint, radius, startAngle, endAngle)
    
    ' Define the line
    Set curves(1) = ThisDrawing.ModelSpace.AddLine(curves(0).startPoint, curves(0).endPoint)
        
    ' Create the region
    Dim regionObj As Variant
    regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
    
    ' Define the extrusion path (spline object)
    Dim splineObj As AcadSpline
    Dim startTan(0 To 2) As Double
    Dim endTan(0 To 2) As Double
    Dim fitPoints(0 To 8) As Double
    
    ' Define the Spline Object
    startTan(0) = 10: startTan(1) = 10: startTan(2) = 10
    endTan(0) = 10: endTan(1) = 10: endTan(2) = 10
    fitPoints(0) = 0: fitPoints(1) = 10: fitPoints(2) = 10
    fitPoints(0) = 10: fitPoints(1) = 10: fitPoints(2) = 10
    fitPoints(0) = 15: fitPoints(1) = 10: fitPoints(2) = 10
    Set splineObj = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)
    
    ' Create the solid
    Dim solidObj As Acad3DSolid
    Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj(0), splineObj)
    ZoomAll
    
End Sub
Просмотров: 6456
 
Непрочитано 22.03.2010, 21:46
#2
Mikka


 
Регистрация: 05.08.2008
Сообщений: 155


Что конкретно ты выдавливаеш ? Ты хочешь выдавить плоский контур в доль линии ?

Вот, выдавливает контур вдоль полилинии, криволинейные участки тоже понимает, есть 2 ограничения:
1 - первый участок должен быть прямолинейный (сколь угодно маленький, но прямой)
2 - длина линии должна быть меньше 10000 (ограничение акада)

Нарисуй полилинию( понимает разные типы линий), и запусти процедуру test
Код:
[Выделить все]
Attribute VB_Name = "Module2"
Option Explicit

Dim VarProfArr() ' массив вершин выдавливаемого контура
Dim VarBglArr()   ' массив скруглений вершин выдавливаемого контура

Private fUcsObj         As AcadUCS

Sub initPrf()
' процедура создает массивы описания точек профиля

    ' создаем и заполняем массив описания вершин полилинии
    ReDim VarProfArr(7)
    
    VarProfArr(0) = -20 ' x1=-20
    VarProfArr(1) = -40 ' y1=-40
    
    VarProfArr(2) = 20 ' x1=20
    VarProfArr(3) = -40 ' y1=-40
    
    VarProfArr(4) = 20 ' x1=20
    VarProfArr(5) = 40 ' y1=40
    
    VarProfArr(6) = -20 ' x1=-20
    VarProfArr(7) = 40 ' y1=40
    ' в процедуре CrtPrfRegion полилиния замыкается автоматически, т.к. для выдавливания нужем замкнутый профиль
    
    ' массив скруглений полилинии
    ReDim VarBglArr(3)
    VarBglArr(0) = 1    ' номер вершины начала скругления
    VarBglArr(1) = 0.3  ' скругление см. свойство полилинии SetBulge
    
    VarBglArr(2) = 3
    VarBglArr(3) = 0.3
    
End Sub

Function NuXYZToVrnt(pxDbl, pyDbl, pzDbl) As Variant
' возвращает вариант массив из трех точек
    Dim ResPntDblArr(2) As Double

    ResPntDblArr(0) = pxDbl
    ResPntDblArr(1) = pyDbl
    ResPntDblArr(2) = pzDbl

    NuXYZToVrnt = ResPntDblArr
End Function

Function DrwGetSpase() As AcadBlock
' определяет текущее пространство: лист или модель
    Dim ObjSpace As AcadBlock
    Dim intTILEMODE As Integer
    Dim intCVPORT As Integer

    On Error GoTo Exit_here
        intTILEMODE = CInt(ThisDrawing.GetVariable("TILEMODE"))
        If intTILEMODE = 1 Then
            Set ObjSpace = ThisDrawing.ModelSpace
        Else
            intCVPORT = CInt(ThisDrawing.GetVariable("CVPORT"))
            If intCVPORT = 1 Then
                Set ObjSpace = ThisDrawing.PaperSpace
            Else
                Set ObjSpace = ThisDrawing.ModelSpace
            End If
        End If

Exit_here:
    Set DrwGetSpase = ObjSpace
    Set ObjSpace = Nothing
    Err.Clear
End Function


Private Sub fCrtUcs(ucsName As String)
    ' создает пользовательскую систему координат
    Dim dirx(0 To 2)    As Double
    Dim diry(0 To 2)    As Double
    Dim origin(0 To 2)  As Double
'    Dim ucsObjs         As AcadUCSs

    origin(0) = 0
    origin(1) = 0
    origin(2) = 0
    
    dirx(0) = 1
    dirx(1) = 0
    dirx(2) = 0
    
    diry(0) = 0
    diry(1) = 1
    diry(2) = 0

    ' проверяем наличие UCS с таким именем
'    Set ucsObjs = ThisDrawing.UserCoordinateSystems
'    For Each fUcsObj In ucsObjs
'        If fUcsObj.Name = ucsName Then
'            'fUcsObj.Delete
'            Exit For
'        End If
'    Next

    Set fUcsObj = ThisDrawing.UserCoordinateSystems.Add(origin, dirx, diry, ucsName)
   ' Set fUcsObj = ThisDrawing.ActiveUCS ' = fUcsObj
   ' ThisDrawing.ActiveUCS = fUcsObj
End Sub
Public Sub BeginDrw()
' имитируем мировую систему
    Call fCrtUcs("acTmpUcs")
End Sub

Public Sub EndDrw()
' удаляем UCS
    On Error GoTo Err_Control
    If fUcsObj <> Null Then fUcsObj.Delete
 '   fUcsObj.Delete
Err_Control:
    Err.Clear
End Sub




Private Function CrtPrfRegion(ByVal VcNormal, ByVal p1, ByVal PrfAngle As Double, ByVal GlbAngle As Double, ByVal dx As Double, ByVal dy As Double, mirx As Boolean, tcns As Double, Optional ospDx As Double = 0, Optional ospdy As Double = 0) As AcadRegion

' процедура рисует плоский контур профиля
' разворачивает его
' и возвращает регион готовый для выдавливания
'    Dim VarProfArr                          ' массив точек
'    Dim VarBglArr                           ' массив скруглений

    Dim profArrCnt      As Long             ' кол-во эл. массива точек
    Dim profBglCnt      As Long             ' кол-во эл. массива скруглений
'    Dim tcns            As Double           ' толщина профиля
    Dim i               As Long             ' счетчик цикла
    Dim TmpDbl          As Double           ' временные переменные
    Dim tmpLng          As Long
    Dim tmpLng2         As Long
    Dim tmpVar
    Dim DblArrProf()    As Double           ' массив типа double с координатами вершин профиля
    Dim ObjSpc          As AcadBlock        ' текущее пространство (лист или модель)

'    Dim tmpPlineObj     As AcadLWPolyline   ' временная полилиния
    Dim outPlineObj     As AcadLWPolyline   ' полилиния, описывающая объект
    Dim inPlineObj      As AcadLWPolyline   ' полилиния, внутренняя, для труб и им подобных объектов
    Dim RegEnt(0)       As AcadEntity
    Dim OutRegionObj    As AcadRegion       ' основной регион
    Dim inRegionObj     As AcadRegion       ' Внутренний регион
    
    Dim tmpXXDbl        As Double           ' промежуточные координаты
    Dim tmpYYDbl        As Double           ' промежуточные координат
    Dim tmpXXDbl1        As Double           ' промежуточные координаты
    Dim tmpYYDbl1        As Double           ' промежуточные координат

    Dim CosPrfAng       As Double           ' косинусы и синусы
    Dim SinPrfAng       As Double
    Dim CosGlbAng       As Double
    Dim SinGlbAng       As Double

    On Error GoTo Err_Control
        
        profArrCnt = UBound(VarProfArr)
        profBglCnt = UBound(VarBglArr)
        
'        Call ObjBase.GetCurPointsArr(VarProfArr, profArrCnt)
'        Call ObjBase.GetCurBulgeArr(VarBglArr, profBglCnt)
        ' задаем толщину внутреннего контура, если равна 0, то профиль сплошной
      '  tcns = ObjBase.GetCurTicns
        ' копируем из массива variant в массив типа double
        ReDim DblArrProf(profArrCnt)

        ' узнаем косинусы и синусы углов, для последующего поворота точки
        CosPrfAng = Cos(PrfAngle * 3.14159265358979 / 180)
        SinPrfAng = Sin(PrfAngle * 3.14159265358979 / 180)
        CosGlbAng = Cos(-GlbAngle * 3.14159265358979 / 180)
        SinGlbAng = Sin(-GlbAngle * 3.14159265358979 / 180)

        If mirx = True Then tmpLng2 = -1 Else tmpLng2 = 1
        ' не зеркальный
        For i = 0 To profArrCnt - 1 Step 2
            tmpXXDbl = CDbl(VarProfArr(i)) * tmpLng2
            tmpYYDbl = CDbl(VarProfArr(i + 1))
            
            ' поворачиваем точку вокруг 0,0
            tmpXXDbl = tmpXXDbl
            tmpYYDbl = tmpYYDbl

            tmpXXDbl1 = tmpXXDbl * CosPrfAng + tmpYYDbl * SinPrfAng
            tmpYYDbl1 = tmpXXDbl * SinPrfAng - tmpYYDbl * CosPrfAng

            ' поворачиваем точку вокруг 0,0 еще разок
            tmpXXDbl = tmpXXDbl1 * CosGlbAng + tmpYYDbl1 * SinGlbAng
            tmpYYDbl = tmpXXDbl1 * SinGlbAng - tmpYYDbl1 * CosGlbAng

            DblArrProf(i) = tmpXXDbl + ospDx
            DblArrProf(i + 1) = tmpYYDbl + ospdy
        Next i
        
        ' узнаем текущее пространство листа
        Set ObjSpc = DrwGetSpase()
        ' создаем легкий объект polyline в пространстве модели
        Set outPlineObj = ObjSpc.AddLightWeightPolyline(DblArrProf)
        ' замыкаем полилинию на всякий пожарный
        outPlineObj.Closed = True
        ' преобразуем объект МСК
        outPlineObj.TransformBy (fUcsObj.GetUCSMatrix)
        
        'поворачиваем контур перпендикулярно осевой линии
        outPlineObj.Normal = VcNormal '
        '-----------------------------------
        If tcns <> 0 Then
        ' если толщина не равна 0, т.е. если профиль полый
            If mirx = False Then tcns = -tcns
            tmpVar = outPlineObj.Offset(tcns)            ' задаем внутренний конутр (результат полилиния)
            Set inPlineObj = tmpVar(0)
        End If

        'задаем скрукления
        If mirx = True Then tmpLng2 = -1 Else tmpLng2 = 1 ' если профиль зеркальный, то меняем знак скругления
        For i = 0 To profBglCnt - 1 Step 2
            tmpLng = CLng(VarBglArr(i))
            TmpDbl = CDbl(VarBglArr(i + 1)) * tmpLng2
            Call outPlineObj.SetBulge(tmpLng, TmpDbl)
            If tcns <> 0 Then
                Call inPlineObj.SetBulge(tmpLng, TmpDbl)
            End If
        Next i
        
        ' создаем регион
        Set RegEnt(0) = outPlineObj
        tmpVar = ObjSpc.AddRegion(RegEnt)
        Set OutRegionObj = tmpVar(0)                              ' явно определяем тим AcadRegion
        outPlineObj.Delete

        ' если существует внутренний контур
        If tcns <> 0 Then
            Set RegEnt(0) = inPlineObj
            tmpVar = ObjSpc.AddRegion(RegEnt)
            Set inRegionObj = tmpVar(0)                             ' явно определяем тип AcadRegion

            Call OutRegionObj.Boolean(acSubtraction, inRegionObj)   ' вычитаем из первого региона второй
            inPlineObj.Delete    'удаляем регион
        End If
        
        ' перемещаем солид
        Call OutRegionObj.Move(NuXYZToVrnt(0, 0, 0), p1)
        
        ' перемещаем будущий профиль в нужную точку
        Set CrtPrfRegion = OutRegionObj

Err_Control:

    ' высвобождаем память
    Set ObjSpc = Nothing
  '  Set tmpPlineObj = Nothing
    Set outPlineObj = Nothing
    Set inPlineObj = Nothing
    Set RegEnt(0) = Nothing
    Set OutRegionObj = Nothing
    Set inRegionObj = Nothing

    ' обработчик ошибок
    If Err.Number <> 0 Then
     
        Set CrtPrfRegion = Nothing
        Err.Clear
    End If
End Function

Function DrwGetVecNorm(BegPoint, endPoint) As Variant
 ' вычисляем вектор поворота
    Dim origPtDblArr(2)     As Double
    Dim ProcDbl             As Double
    Dim vecNormDblArr(2)    As Double           ' вектор разворота полилинии

    On Error GoTo Err_Control

            origPtDblArr(0) = BegPoint(0) - endPoint(0)
            origPtDblArr(1) = BegPoint(1) - endPoint(1)
            origPtDblArr(2) = BegPoint(2) - endPoint(2)
            ProcDbl = Sqr(origPtDblArr(0) * origPtDblArr(0) + origPtDblArr(1) * origPtDblArr(1) + origPtDblArr(2) * origPtDblArr(2))
       
       If ProcDbl <> 0 Then
            vecNormDblArr(0) = -origPtDblArr(0) / ProcDbl
            vecNormDblArr(1) = -origPtDblArr(1) / ProcDbl
            vecNormDblArr(2) = -origPtDblArr(2) / ProcDbl
        Else
        'если начальная и конечная точка совпадает
            vecNormDblArr(0) = 0
            vecNormDblArr(1) = 0
            vecNormDblArr(2) = -1
        End If
        DrwGetVecNorm = vecNormDblArr
Err_Control:
    ' обработчик ошибок
End Function

Function DrwGetWCSCrdsD2Pl(line As AcadEntity, PntNoom As Long) As Variant
' возвращает мировые координаты указанной вершины плоской полилинии
    Dim WcsPnt  As Variant
    Dim plLine  As AcadEntity
    
    Dim p1              As Variant
    Dim Result          As Variant
    Dim TmpArr(2)       As Double
    
    On Error GoTo Err_Control
    
    If (TypeOf line Is AcadLWPolyline) Or (TypeOf line Is AcadPolyline) Then
        p1 = line.Coordinate(PntNoom)
        TmpArr(0) = CDbl(p1(0))
        TmpArr(1) = CDbl(p1(1))
        TmpArr(2) = CDbl(line.Elevation)
        p1 = TmpArr
        Result = ThisDrawing.Utility.TranslateCoordinates(p1, acOCS, acWorld, False, line.Normal)
    End If
    
Err_Control:
    DrwGetWCSCrdsD2Pl = Result
    If Err.Number <> 0 Then
        Err.Clear
    End If

End Function

Public Function GetP1AndNormal(lnObj As AcadEntity, ByRef p1, ByRef VcNormal) As Boolean
    ' возвращает первую точку обекта, и нормальнь для солида
    ' всего 4 типа, AcadLine, AcadLWPolyline, AcadPolyline, Acad3DPolyline
    Dim Result          As Boolean
     Dim p2              As Variant
    
    Result = False
    
     On Error GoTo Err_Control
        ' если это линия
        If TypeOf lnObj Is AcadLine Then
            VcNormal = DrwGetVecNorm(lnObj.StartPoint, lnObj.endPoint)
            p1 = lnObj.StartPoint
            p2 = lnObj.endPoint
            Result = True
        End If
        
        ' если это плоская полилиния полилиния
        If (TypeOf lnObj Is AcadLWPolyline) Or (TypeOf lnObj Is AcadPolyline) Then
            p1 = DrwGetWCSCrdsD2Pl(lnObj, 0)
            p2 = DrwGetWCSCrdsD2Pl(lnObj, 1)
            VcNormal = DrwGetVecNorm(p1, p2)
            Result = True
        End If
        
        ' если это 3d полилиния, не проверял должно работать
        If TypeOf lnObj Is Acad3DPolyline Then
            p1 = lnObj.Coordinate(0)
            p2 = lnObj.Coordinate(1)
            VcNormal = DrwGetVecNorm(p1, p2)
            Result = True
        End If
        
Err_Control:
    GetP1AndNormal = Result
End Function

Public Function fCrtPrfFrmLine(lnObj As AcadEntity, ProfAngle As Double, GlbAngle As Double, dx As Double, dy As Double, mirx As Boolean, tcns As Double, Optional ospDx As Double = 0, Optional ospdy As Double = 0) As String  ', ByRef ProfDataVar, ByRef BglDataVar, ProfDataCnt As Long, BglDataCnt As Long, Tcs As Double) As String
' процедура создает профиль по линии
   
    Dim Region          As AcadRegion       ' регион, из которого выдавливается солид
    Dim ObjSpc          As AcadBlock        ' переменная типа acadBlock указывающая на текущее рабочее пространство
    Dim VcNormal        As Variant          ' Вектор ориентации региона
    Dim p1              As Variant          ' Начальная
    Dim p2              As Variant          ' и конечная точка профиля
    Dim Prf3dHandle     As String           ' хэндл профиля
    Dim TmpArr(2)       As Double
    Dim ObjColor        As New AcadAcCmColor
    Dim ColorIndex      As Long
    Dim fProf3d         As Acad3DSolid
       
    On Error GoTo Err_Control
        
        ' узнаем текущее пространство листа
       
        Set ObjSpc = DrwGetSpase()
        If GetP1AndNormal(lnObj, p1, VcNormal) = True Then
        
            If lnObj.Length > 0 Then
                ' обрабатываем ошибку выдавливания солида
                On Error GoTo Err_addSolid
                    
                    If lnObj.Length < 100000 Then
                        ' если длина линии больше 0 и меньше 100000, чертим регион, и выдавливаем солид (ограничение акада на длину выдавливания солида)
                        Set Region = CrtPrfRegion(VcNormal, p1, ProfAngle, GlbAngle, dx, dy, mirx, ospDx, ospdy)
                        'Set Region = CrtPrfRegion(p1, p2, ProfAngle, GlbAngle, osnap, dx, dy, mirx)
                        Set fProf3d = ObjSpc.AddExtrudedSolidAlongPath(Region, lnObj)
  
                        Region.Delete                       ' удаляем регион
                        Prf3dHandle = fProf3d.Handle        ' хэндл профиля

                    Else
                        Prf3dHandle = ""
                        'ObjErr.ErrAddCmdLine ("Слишком длинная линия!")
                    End If
Err_addSolid:
'                ' пишем данные в базовую линию

            Else

                lnObj.Delete
            End If
        Else
'            Call ObjErr.ErrOutLog("Не правильный тип линии! ", True, 2)
        End If
        
        fCrtPrfFrmLine = Prf3dHandle

Err_Control:
    
'    Set SldXdtList = Nothing
    Set Region = Nothing
    Set ObjSpc = Nothing
    
'    If Err.Number <> 0 Then
'        Call SldXdtList.WriteList(fProf3d)
'        fCrtPrfFrmLine = ""
'        ObjErr.ErrOutLog ("clsProf3d_fCrtPrfFrmLine_:_err_" + str(Err.Number) + "_" + Err.Description)
'    End If
End Function


Sub test()

    Dim objSel      As AcadEntity
    Dim p1
    
    On Error GoTo ErrControl
    
        Call ThisDrawing.Utility.GetEntity(objSel, p1, "Выберите профиль:")
        

    If (TypeOf objSel Is AcadLine) Or (TypeOf objSel Is AcadPolyline) Or (TypeOf objSel Is AcadLWPolyline) Or (TypeOf objSel Is Acad3DPolyline) Then
        Call initPrf
        Call BeginDrw
        
        Call fCrtPrfFrmLine(objSel, 34, 0, 0, 0, False, 6)
        
        Call EndDrw
    End If
 
    
ErrControl:
    ' мусор убираем
    Set objSel = Nothing

End Sub
Вложения
Тип файла: zip Module2.zip (4.5 Кб, 134 просмотров)

Последний раз редактировалось Mikka, 22.03.2010 в 22:43.
Mikka вне форума  
 
Автор темы   Непрочитано 23.03.2010, 00:20
#3
Markiza-2010

Студентка
 
Регистрация: 09.03.2010
Сообщений: 16


Спасибо за ответ! Но, честно говоря, для меня не совсем понятно то, что вы написали (я только недавно начила заниматься программированием). Мне вообще нужно выдавить звёздочку по наклонной линии. Помогите, пожалуйста, исправить мой код.
Код:
[Выделить все]
Sub StarRegion()
    Dim lineObj() As AcadEntity 'динамический массив
    Dim startPoint(0 To 2) As Double
    Dim endPoint(0 To 2) As Double
    Const p As Double = 3.141592654
    Dim n As Integer 'количество сторон звезды
    Dim i As Integer
    Dim a As Integer
    Dim k As Integer
    Dim r11 As Double 'радиус внутренних точек
    Dim r22 As Double 'радиус внешних точек звезды
    Dim RotateAngle As Double
    
    k = InputBox("Введите количество углов звёздочки", "Ввод данных", " ")
    n = k * 2
    a = 360 / n
    r11 = 10
    r22 = 20
    ReDim lineObj(n - 1) 'переопределение динамического массива
    RotateAngle = a * p / 180
For i = 1 To n
 If (i Mod 2) = 1 Then
    startPoint(0) = r11 * Cos(RotateAngle)
    startPoint(1) = r11 * Sin(RotateAngle)
    startPoint(2) = 0
    endPoint(0) = r22 * Cos(RotateAngle + a * p / 180)
    endPoint(1) = r22 * Sin(RotateAngle + a * p / 180)
    endPoint(2) = 0
    Set lineObj(i - 1) = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    RotateAngle = RotateAngle + a * p / 180
 ElseIf i = n Then 'соединение последней точки с первой
    startPoint(0) = r22 * Cos(RotateAngle)
    startPoint(1) = r22 * Sin(RotateAngle)
    startPoint(2) = 0
    endPoint(0) = r11 * Cos(a * p / 180)
    endPoint(1) = r11 * Sin(a * p / 180)
    endPoint(2) = 0
    Set lineObj(i - 1) = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
 Else
    startPoint(0) = r22 * Cos(RotateAngle)
    startPoint(1) = r22 * Sin(RotateAngle)
    startPoint(2) = 0
    endPoint(0) = r11 * Cos(RotateAngle + a * p / 180)
    endPoint(1) = r11 * Sin(RotateAngle + a * p / 180)
    endPoint(2) = 0
    Set lineObj(i - 1) = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    RotateAngle = RotateAngle + a * p / 180
 End If
Next i
    'Создание области (в форме звезды)
    Dim regionObj As Variant
    regionObj = ThisDrawing.ModelSpace.AddRegion(lineObj)
    Dim height As Double
    Dim taperAngle As Double
    height = 15
    taperAngle = 0
    'Выдавливание области
    Dim solidObj As Acad3DSolid
    Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionObj(0), height, taperAngle)
End Sub
Вместо AddExtrudedSolid нужно использовать AddExtrudedSolidAlongPath.
Markiza-2010 вне форума  
 
Непрочитано 23.03.2010, 09:18
1 | #4
Mikka


 
Регистрация: 05.08.2008
Сообщений: 155


Вот Ваш доработанный пример ...

Код:
[Выделить все]
Option Explicit

Function DrwGetVecNorm(BegPoint, endPoint) As Variant
 ' вычисляем вектор поворота
    Dim origPtDblArr(2)     As Double
    Dim ProcDbl             As Double
    Dim vecNormDblArr(2)    As Double           ' вектор разворота полилинии

    On Error GoTo Err_Control

            origPtDblArr(0) = BegPoint(0) - endPoint(0)
            origPtDblArr(1) = BegPoint(1) - endPoint(1)
            origPtDblArr(2) = BegPoint(2) - endPoint(2)
            ProcDbl = Sqr(origPtDblArr(0) * origPtDblArr(0) + origPtDblArr(1) * origPtDblArr(1) + origPtDblArr(2) * origPtDblArr(2))
       
       If ProcDbl <> 0 Then
            vecNormDblArr(0) = -origPtDblArr(0) / ProcDbl
            vecNormDblArr(1) = -origPtDblArr(1) / ProcDbl
            vecNormDblArr(2) = -origPtDblArr(2) / ProcDbl
        Else
        'если начальная и конечная точка совпадает
            vecNormDblArr(0) = 0
            vecNormDblArr(1) = 0
            vecNormDblArr(2) = -1
        End If
        DrwGetVecNorm = vecNormDblArr
Err_Control:
    ' обработчик ошибок
End Function

Sub StarRegion(line As AcadLine)
' процедура выдавливания "ЗВЕЗДОЧКИ"
    Const p         As Double = 3.141592654
    
    Dim ObjList(0)  As AcadEntity 'массив c элементами чертежа, т.к. у нас замкнутая полилиния, нам достаточно 1 эл.
    Dim regionObj   As Variant
    Dim PlnObj      As AcadLWPolyline ' легкая полилиния
    Dim solidObj    As Acad3DSolid
    
    Dim n           As Integer 'количество сторон звезды
    Dim i           As Integer
    Dim a           As Integer
    Dim k           As Integer
    Dim r11         As Double 'радиус внутренних точек
    Dim r22         As Double 'радиус внешних точек звезды
    Dim RotateAngle As Double
    
    Dim PntsArr()   As Double ' динамический массив с вершинами звезды (полилинии)
    Dim PntsArrCnt  As Long   ' счетчик динамического массива
    
    Dim pnt1(2)     As Double
    
    k = InputBox("Введите количество углов звёздочки", "Ввод данных", " ")
    n = k * 2
    a = 360 / n
    r11 = 10
    r22 = 20
    RotateAngle = a * p / 180
    
    ReDim lineObj(n - 1) 'переопределение динамического массива
    ReDim PntsArr(k * 4 + 1) ' переопределяем размерность
    
    PntsArrCnt = 0
    
    ' высчитываем двухмерные координаты звезды и заносим их в массив
    
    PntsArr(PntsArrCnt) = r11 * Cos(RotateAngle)
    PntsArr(PntsArrCnt + 1) = r11 * Sin(RotateAngle)
    PntsArrCnt = PntsArrCnt + 2
    
    For i = 1 To n
        If (i Mod 2) = 1 Then
        
            PntsArr(PntsArrCnt) = r22 * Cos(RotateAngle + a * p / 180)
            PntsArr(PntsArrCnt + 1) = r22 * Sin(RotateAngle + a * p / 180)
            
            ' увеличиваем счетчик
            PntsArrCnt = PntsArrCnt + 2

            RotateAngle = RotateAngle + a * p / 180
        Else
        
            PntsArr(PntsArrCnt) = r11 * Cos(RotateAngle + a * p / 180)
            PntsArr(PntsArrCnt + 1) = r11 * Sin(RotateAngle + a * p / 180)
            
            PntsArrCnt = PntsArrCnt + 2
            
            RotateAngle = RotateAngle + a * p / 180
        End If
    Next i
    
    On Error GoTo Err_Control
    ' создаем легкую полилинию
        Set PlnObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(PntsArr)
        PlnObj.Closed = True     ' на всякий пожарный замыкаем ее
        
        ' теперь необходимо повернуть плоский контур повернуть перпендикулярно линии выдавливания,
        ' для этого вычилсяем вектор и поворачиваем
        ' т.к. непосредственно сам регион таким образом повернуть нельзя
        PlnObj.Normal = DrwGetVecNorm(line.startPoint, line.endPoint)
        
        'Создание области (в форме звезды)
        Set ObjList(0) = PlnObj
        regionObj = ThisDrawing.ModelSpace.AddRegion(ObjList)
        
        'Выдавливание области
        pnt1(0) = 0
        pnt1(1) = 0
        pnt1(2) = 0
        Call solidObj.Move(pnt1, line.startPoint)

        Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj(0), line)
        
'        ' или так
'        Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionObj(0), 10, 0)
        
Err_Control:
    'в любом случае убираем мусор после себя
    ' удаляем не нежные контуры с чертежа
    PlnObj.Delete
    ObjList(0).Delete
    
    ' освобождаем переменные
    Set ObjList(0) = Nothing
    Set regionObj = Nothing
    Set PlnObj = Nothing
    Set solidObj = Nothing
End Sub

Sub test()
    Dim line As AcadLine
    Dim objSel      As AcadEntity
    Dim p1
    
    On Error GoTo ErrControl
        ' запрашиваем у пользователя примитив
        Call ThisDrawing.Utility.GetEntity(objSel, p1, "Выберите профиль:")
        
        ' проверяем линия ли это
        If (TypeOf objSel Is AcadLine) Then
            ' отправляем в процедуру линию (нужна для выдавливания звезды, 
            ' а ее начальная и конечные точки для вычисления
            ' вектора поворота плоскости звезды) как то так ;)))
            Call StarRegion(objSel)
        End If
 
ErrControl:
    ' мусор убираем
    Set objSel = Nothing

End Sub

Последний раз редактировалось Mikka, 23.03.2010 в 15:07.
Mikka вне форума  
 
Автор темы   Непрочитано 29.03.2010, 02:36
#5
Markiza-2010

Студентка
 
Регистрация: 09.03.2010
Сообщений: 16


Спасибо!
Markiza-2010 вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Выдавливание вдоль линии (VBA)

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Создание нового типа линий Apelsinov AutoCAD 915 08.07.2022 12:36
Как при помощи лиспа нарисовать цепочку окружностей вдоль воображаемой линии Serge_BN LISP 8 18.03.2010 20:32
Как пустить текст вдоль изогнутой линии? Shaft AutoCAD 47 01.06.2009 16:13
как с помощью vba начертить две линии... vasyavip Программирование 1 12.04.2009 13:11
VBA, Масштаб типа линии для текста? Vildar Программирование 1 28.07.2008 16:40