[Clinri]

Пишу скрипт на VBA рисующий разделку с заполнением её валиками.
При их прорисовке нужно чтобы каждый новый валик перекрывал всё нарисованное до этого....
вот так у меня примерно сейчас выглядит (схематически):

а нужно вот так (отредактировал в растровом редакторе):


валик состоит из 2х сплайнов, по 3м и 5ти точкам
может можно ка кто заливать простарство внутри каждого валика?
подскажите пожалуйста.
или это невозможно сделать в AutoCAD? можно ли такое сделать CorelDraw (в нём вроде тоже есть VBA)?

спасибо

[Clinri]

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

Код:

[Выделить все]

'заливка шва
Dim hatchObj As AcadHatch
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
    ' определение и создание заливки
    patternName = "LINEAR"
    PatternType = 1 'AcGradientPatternType
    bAssociativity = True
    Set hatchObj = ThisDrawing.ModelSpace. _
        AddHatch(PatternType, patternName, bAssociativity, acGradientObject)
Dim outerLoop(0 To 1) As AcadEntity 'Массив объектов, формирующих закрытую границу
Set outerLoop(0) = Spline_3(B(0), B(1), Z1(0), Z1(1), A(0), A(1), 0, 0, 0, 0)
Set outerLoop(1) = Spline_5(A(0), A(1), D1(0), D1(1), C(0), C(1), D2(0), D2(1), B(0), _
B(1), Ay1(0) - A(0), Ay1(1) - A(1), Ay2(0) - B(0), Ay2(1) - B(1))
hatchObj.Evaluate 'вычислять линии штриховки или заполнения для границ
ThisDrawing.Regen True 'модифицировать отображение штриховки

' Для построения сплайна по ТРЁМ точкам
Function Spline_3(x1, y1, x2, y2, x3, y3, tn_x1, tn_y1, tn_x2, tn_y2) As AcadSpline
Dim startTan(0 To 2) As Double
Dim endTan(0 To 2) As Double
Dim fitPoints(0 To 8) As Double
    startTan(0) = tn_x1: startTan(1) = tn_y1: startTan(2) = 0
    endTan(0) = tn_x2: endTan(1) = tn_y2: endTan(2) = 0
    fitPoints(0) = x1: fitPoints(1) = y1: fitPoints(2) = 0
    fitPoints(3) = x2: fitPoints(4) = y2: fitPoints(5) = 0
    fitPoints(6) = x3: fitPoints(7) = y3: fitPoints(8) = 0
   Set Spline_3 = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)
  Spline_3.ElevateOrder (26)
  Spline_3.Update
End Function

' Для построения сплайна по ПЯТИ точкам
Function Spline_5(x1, y1, x2, y2, x3, y3, x4, y4, x5, y5, tn_x1, tn_y1, tn_x2, tn_y2) As AcadSpline
Dim startTan(0 To 2) As Double
Dim endTan(0 To 2) As Double
Dim fitPoints(0 To 14) As Double
    startTan(0) = tn_x1: startTan(1) = tn_y1: startTan(2) = 0
    endTan(0) = tn_x2: endTan(1) = tn_y2: endTan(2) = 0
    fitPoints(0) = x1: fitPoints(1) = y1: fitPoints(2) = 0
    fitPoints(3) = x2: fitPoints(4) = y2: fitPoints(5) = 0
    fitPoints(6) = x3: fitPoints(7) = y3: fitPoints(8) = 0
    fitPoints(9) = x4: fitPoints(10) = y4: fitPoints(11) = 0
    fitPoints(12) = x5: fitPoints(13) = y5: fitPoints(14) = 0
   Set Spline_5 = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)
  Spline_5.ElevateOrder (26)
  Spline_5.Update
End Function

можно ли outerLoop массив забивать ссылкой на функцию?
у меня на это подозрения

[Vildar]

Может порядок прорисовки чем-нибудь поможет.
Посмотри в справке про moveabove.

[Кулик Алексей aka kpblc]

Сообщение от Clinri можно ли outerLoop массив забивать ссылкой на функцию?

Теоретически можно, если функция возвращает массив объектов.

[Clinri]

Сообщение от Vildar Может порядок прорисовки чем-нибудь поможет. Посмотри в справке про moveabove.

без примера не соображу как этим воспользоваться..


переработал, упростил код для отладки:

Код:

[Выделить все]

Const Pi = 3.1415
'Объявляем глобальные переменные
Dim bp, cp, S, Iw, U, v, de
Sub Razdelka1()
    ThisDrawing.SendCommand "_.erase" & vbCr & "_all" & vbCr & vbCr 'очистка
    H = 4 'глубина проплавления
    e = 4 'ширина шва
    g = 0.5 ' высота усиления
    ygol = 0 ' угол ориентации шва
    mx = 5 'коодината X шва
    my = 5 'коодината Y шва
    tn_x = 10
    tn_y = 1
    p = 1
    q = 1
    Call shov(H, e, g, ygol, mx, my, tn_x, tn_y, p, q)
    mx = 5
    ygol = 40
    Call shov(H, e, g, ygol, mx, my, tn_x, tn_y, p, q)
    'ZoomAll
End Sub
Sub shov(H, e, g, ygol, mx, my, Optional tn_x = 10, Optional tn_y = 1, Optional p = 1, Optional q = 1)
    'описание переменных
        'описание составных объектов валика (сплайнов)
        Dim splineobj1 As AcadSpline
        Dim splineobj2 As AcadSpline
        'точки постороения
        Dim rotationAngle As Double
        Dim A(0 To 2) As Double 'левая точка шва
        Dim B(0 To 2) As Double 'правая точка шва
        Dim C(0 To 2) As Double 'корень шва
        Dim Z0(0 To 2) As Double 'центр построения шва
        Dim Z1(0 To 2) As Double 'верхняя часть усиления
        'вспоогательные точки для постороения сплайна
        Dim D1(0 To 2) As Double
        Dim D2(0 To 2) As Double
        'точки для ориентации концов сплайна
        Dim Ax1(0 To 2) As Double
        Dim Ay1(0 To 2) As Double
        Dim Ax2(0 To 2) As Double
        Dim Ay2(0 To 2) As Double
    'построение
    rotationAngle = ygol * Pi / 180 'пересчёт угола поворота шва в радианы
    A(0) = mx - e / 2: A(1) = my: A(2) = 0 'левая точка шва
    B(0) = mx + e / 2: B(1) = my: B(2) = 0 'правая точка шва
    Z0(0) = mx: Z0(1) = my: Z0(2) = 0 'координаты центра
    Z1(0) = Z0(0): Z1(1) = Z0(1) + g: Z1(2) = Z0(2) ' Верхняя точка усиления
  
    
    tn_x1 = 0
    tn_y1 = 0
    tn_x2 = 0
    tn_y2 = 0
    x1 = B(0): y1 = B(1)
    x2 = Z1(0): y2 = Z1(1)
    x3 = A(0): y3 = A(1)
    Dim startTan1(0 To 2) As Double
    Dim endTan1(0 To 2) As Double
    Dim fitPoints1(0 To 8) As Double
        startTan1(0) = tn_x1: startTan1(1) = tn_y1: startTan1(2) = 0
        endTan1(0) = tn_x2: endTan1(1) = tn_y2: endTan1(2) = 0
        fitPoints1(0) = x1: fitPoints1(1) = y1: fitPoints1(2) = 0
        fitPoints1(3) = x2: fitPoints1(4) = y2: fitPoints1(5) = 0
        fitPoints1(6) = x3: fitPoints1(7) = y3: fitPoints1(8) = 0
    Set splineobj1 = ThisDrawing.ModelSpace.AddSpline(fitPoints1, startTan1, endTan1) ' построение сплайна усиления
    splineobj1.ElevateOrder (26)
    splineobj1.Update
    splineobj1.Rotate Z0, rotationAngle 'поворот
        
    C(0) = Z0(0): C(1) = Z0(1) - H: C(2) = 0 'определение координат точки C
    Ax1(0) = A(0) + tn_x: Ax1(1) = A(1): Ax1(2) = A(2) 'определение координат точки Ax1
    Ay1(0) = Ax1(0): Ay1(1) = Ax1(1) - tn_y: Ay1(2) = 0 'определение координат точки Ay1
    Ax2(0) = B(0) + tn_x: Ax2(1) = B(1): Ax2(2) = B(2) 'определение координат точки Ax2
    Ay2(0) = Ax2(0): Ay2(1) = Ax2(1) + tn_y: Ay2(2) = 0 'определение координат точки Ay2
    'Деление отрезков АС и ВС в заданном соотношении p/q, точками D1 и D2
    D1(0) = (p * A(0) + q * C(0)) / (p + q): D1(1) = (p * A(1) + q * C(1)) / (p + q): D1(2) = 0
    D2(0) = (p * B(0) + q * C(0)) / (p + q): D2(1) = (p * B(1) + q * C(1)) / (p + q): D2(2) = 0

    tn_x1 = Ay1(0) - A(0)
    tn_y1 = Ay1(1) - A(1)
    tn_x2 = Ay2(0) - B(0)
    tn_y2 = Ay2(1) - B(1)
    x1 = A(0): y1 = A(1)
    x2 = D1(0): y2 = D1(1)
    x3 = C(0): y3 = C(1)
    x4 = D2(0): y4 = D2(1)
    x5 = B(0): y5 = B(1)
    Dim startTan2(0 To 2) As Double
    Dim endTan2(0 To 2) As Double
    Dim fitPoints2(0 To 14) As Double
        startTan2(0) = tn_x1: startTan2(1) = tn_y1: startTan2(2) = 0
        endTan2(0) = tn_x2: endTan2(1) = tn_y2: endTan2(2) = 0
        fitPoints2(0) = x1: fitPoints2(1) = y1: fitPoints2(2) = 0
        fitPoints2(3) = x2: fitPoints2(4) = y2: fitPoints2(5) = 0
        fitPoints2(6) = x3: fitPoints2(7) = y3: fitPoints2(8) = 0
        fitPoints2(9) = x4: fitPoints2(10) = y4: fitPoints2(11) = 0
        fitPoints2(12) = x5: fitPoints2(13) = y5: fitPoints2(14) = 0
    Set splineobj2 = ThisDrawing.ModelSpace.AddSpline(fitPoints2, startTan2, endTan2)
    splineobj2.ElevateOrder (26)
    splineobj2.Update
    splineobj2.Rotate Z0, rotationAngle     'Поврот на заданный угол
    
   'заливка шва. создает ассоциативную штриховку градиента в пространстве модели.
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    ' определение заливки (штриховки)
    patternName = "CYLINDER"
    PatternType = acPreDefinedGradient '0
    bAssociativity = True
    ' Создайте ассоциативный объект Hatch в пространстве модели
    Set hatchObj = ThisDrawing.ModelSpace. _
        AddHatch(PatternType, patternName, bAssociativity, acGradientObject)
        Dim col1 As AcadAcCmColor, col2 As AcadAcCmColor
        Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
        Set col2 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
        Call col1.SetRGB(255, 255, 255)
        Call col2.SetRGB(255, 255, 255)
        hatchObj.GradientColor1 = col1
        hatchObj.GradientColor2 = col2
    ' Создайте внешнюю границу для штриховки (2 сплайна)
    Dim outerLoop(0 To 1) As AcadEntity 'Массив объектов, формирующих закрытую границу
    Set outerLoop(0) = ThisDrawing.ModelSpace.AddSpline(fitPoints1, startTan1, endTan1)
    Set outerLoop(1) = ThisDrawing.ModelSpace.AddSpline(fitPoints2, startTan2, endTan2)
    ' Добавьте внешнюю границу к объекту штриховки, и покажите штриховку
    hatchObj.Evaluate 'вычислять линии штриховки или заполнения для границ
    ThisDrawing.Regen True 'модифицировать отображение штриховки
    
End Sub

после строчки:
Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
выдаёт: "проблемы при загрузке приложения runtime error vba '-2147221005"

Function GetInterfaceObject(ProgID As String) As Object

что делать с этим ProgID не доходит до меня...
работал по примеру от сюда: http://vbamodel.narod.ru/AutoCAD/ex_addhatch.htm

Буду очень благодарен за напутствия, почти решил нужную задачу...

[Олег (jr.)]

Попробуй заменить ProgID:
"AutoCAD.AcCmColor.17"
Какая версия Автокада?

[Clinri]

Сообщение от Олег (jr.) Попробуй заменить ProgID: "AutoCAD.AcCmColor.17" Какая версия Автокада?

сейчас 2008

в институте 2005

спасибо помогло!
но теперь после строчки:
hatchObj.Evaluate
выводит "run-time error отсутствует обязательное поле"

[Олег (jr.)]

Ты забыл добавить границы и пытаешься применить Evaluate!

Код:

[Выделить все]

Sub shov(H, e, g, ygol, mx, my, Optional tn_x = 10, Optional tn_y = 1, Optional p = 1, Optional q = 1)
    'описание переменных
        'описание составных объектов валика (сплайнов)
        Dim splineobj1 As AcadSpline
        Dim splineobj2 As AcadSpline
        'точки постороения
        Dim rotationAngle As Double
        Dim A(0 To 2) As Double 'левая точка шва
        Dim B(0 To 2) As Double 'правая точка шва
        Dim C(0 To 2) As Double 'корень шва
        Dim Z0(0 To 2) As Double 'центр построения шва
        Dim Z1(0 To 2) As Double 'верхняя часть усиления
        'вспоогательные точки для постороения сплайна
        Dim D1(0 To 2) As Double
        Dim D2(0 To 2) As Double
        'точки для ориентации концов сплайна
        Dim Ax1(0 To 2) As Double
        Dim Ay1(0 To 2) As Double
        Dim Ax2(0 To 2) As Double
        Dim Ay2(0 To 2) As Double
    'построение
    rotationAngle = ygol * Pi / 180 'пересчёт угола поворота шва в радианы
    A(0) = mx - e / 2: A(1) = my: A(2) = 0 'левая точка шва
    B(0) = mx + e / 2: B(1) = my: B(2) = 0 'правая точка шва
    Z0(0) = mx: Z0(1) = my: Z0(2) = 0 'координаты центра
    Z1(0) = Z0(0): Z1(1) = Z0(1) + g: Z1(2) = Z0(2) ' Верхняя точка усиления
  
    
    tn_x1 = 0
    tn_y1 = 0
    tn_x2 = 0
    tn_y2 = 0
    x1 = B(0): y1 = B(1)
    x2 = Z1(0): y2 = Z1(1)
    x3 = A(0): y3 = A(1)
    Dim startTan1(0 To 2) As Double
    Dim endTan1(0 To 2) As Double
    Dim fitPoints1(0 To 8) As Double
        startTan1(0) = tn_x1: startTan1(1) = tn_y1: startTan1(2) = 0
        endTan1(0) = tn_x2: endTan1(1) = tn_y2: endTan1(2) = 0
        fitPoints1(0) = x1: fitPoints1(1) = y1: fitPoints1(2) = 0
        fitPoints1(3) = x2: fitPoints1(4) = y2: fitPoints1(5) = 0
        fitPoints1(6) = x3: fitPoints1(7) = y3: fitPoints1(8) = 0
    Set splineobj1 = ThisDrawing.ModelSpace.AddSpline(fitPoints1, startTan1, endTan1) ' построение сплайна усиления
    splineobj1.ElevateOrder (splineobj1.Degree + 1)
    splineobj1.Update
    splineobj1.Rotate Z0, rotationAngle 'поворот
        
    C(0) = Z0(0): C(1) = Z0(1) - H: C(2) = 0 'определение координат точки C
    Ax1(0) = A(0) + tn_x: Ax1(1) = A(1): Ax1(2) = A(2) 'определение координат точки Ax1
    Ay1(0) = Ax1(0): Ay1(1) = Ax1(1) - tn_y: Ay1(2) = 0 'определение координат точки Ay1
    Ax2(0) = B(0) + tn_x: Ax2(1) = B(1): Ax2(2) = B(2) 'определение координат точки Ax2
    Ay2(0) = Ax2(0): Ay2(1) = Ax2(1) + tn_y: Ay2(2) = 0 'определение координат точки Ay2
    'Деление отрезков АС и ВС в заданном соотношении p/q, точками D1 и D2
    D1(0) = (p * A(0) + q * C(0)) / (p + q): D1(1) = (p * A(1) + q * C(1)) / (p + q): D1(2) = 0
    D2(0) = (p * B(0) + q * C(0)) / (p + q): D2(1) = (p * B(1) + q * C(1)) / (p + q): D2(2) = 0

    tn_x1 = Ay1(0) - A(0)
    tn_y1 = Ay1(1) - A(1)
    tn_x2 = Ay2(0) - B(0)
    tn_y2 = Ay2(1) - B(1)
    x1 = A(0): y1 = A(1)
    x2 = D1(0): y2 = D1(1)
    x3 = C(0): y3 = C(1)
    x4 = D2(0): y4 = D2(1)
    x5 = B(0): y5 = B(1)
    Dim startTan2(0 To 2) As Double
    Dim endTan2(0 To 2) As Double
    Dim fitPoints2(0 To 14) As Double
        startTan2(0) = tn_x1: startTan2(1) = tn_y1: startTan2(2) = 0
        endTan2(0) = tn_x2: endTan2(1) = tn_y2: endTan2(2) = 0
        fitPoints2(0) = x1: fitPoints2(1) = y1: fitPoints2(2) = 0
        fitPoints2(3) = x2: fitPoints2(4) = y2: fitPoints2(5) = 0
        fitPoints2(6) = x3: fitPoints2(7) = y3: fitPoints2(8) = 0
        fitPoints2(9) = x4: fitPoints2(10) = y4: fitPoints2(11) = 0
        fitPoints2(12) = x5: fitPoints2(13) = y5: fitPoints2(14) = 0
    Set splineobj2 = ThisDrawing.ModelSpace.AddSpline(fitPoints2, startTan2, endTan2)
    splineobj2.ElevateOrder (splineobj2.Degree + 1)
    splineobj2.Update
    splineobj2.Rotate Z0, rotationAngle     'Поврот на заданный угол
    
   'заливка шва. создает ассоциативную штриховку градиента в пространстве модели.
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    ' определение заливки (штриховки)
    patternName = "CYLINDER"
    PatternType = acPreDefinedGradient '0
    bAssociativity = True
    ' Создайте ассоциативный объект Hatch в пространстве модели
    Set hatchObj = ThisDrawing.ModelSpace. _
        AddHatch(PatternType, patternName, bAssociativity, acGradientObject)
        Dim col1 As AcadAcCmColor, col2 As AcadAcCmColor
        Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17")
        Set col2 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17")

    ' Создайте внешнюю границу для штриховки (2 сплайна)
    Dim outerLoop(0 To 1) As AcadEntity 'Массив объектов, формирующих закрытую границу
    Set outerLoop(0) = ThisDrawing.ModelSpace.AddSpline(fitPoints1, startTan1, endTan1)
    Set outerLoop(1) = ThisDrawing.ModelSpace.AddSpline(fitPoints2, startTan2, endTan2)
    ' Добавьте внешнюю границу к объекту штриховки, и покажите штриховку
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate 'вычислять линии штриховки или заполнения для границ
    
        Call col1.SetRGB(255, 255, 255)
        Call col2.SetRGB(212, 148, 192)
        hatchObj.GradientColor1 = col1
        hatchObj.GradientColor2 = col2
        hatchObj.Update
    ThisDrawing.Regen True 'модифицировать отображение штриховки
    
End Sub

[Clinri]

Сообщение от Олег (jr.) Ты забыл добавить границы и пытаешься применить Evaluate!

Точно! и с самого начала такая ошибка шла... невнимательно копировал.
Огромное спасибо! Теперь дело сдвинулось с мёртвой точки.

и кстати применил на полной версии программы, с разделкой, где объекты задаются функциями - работает.

Но в окошке AutoCAD'a выглядит результат страшновато, много закрашенных объектов, но при печати очень неплохо.
и на печать дико долго обрабатывает...
не рациональный немного способ...


алгоритм заполнения разделки ещё не отработан, но это уже решаемо...
самое нереальное сделано

[Олег (jr.)]

Может обойтись без градиента только солидом и применить DrawOrder по порядку наложения объектов
будет меньше весить плюс обнуляй AcCmColor в конце

Код:

[Выделить все]

Set col1=Nothing

и кстати задавать 2 AcCmColor это излишне
обойдешься одним:

Код:

[Выделить все]

Call col1.SetRGB(255, 255, 255)
hatchObj.GradientColor1 = col1
Call col1.SetRGB(212, 148, 192)
 hatchObj.GradientColor2 = col1

Пища для размышлений

Код:

[Выделить все]

Sub OrderToTop()
' This example creates a SortentsTable object and
' changes the draw order of selected object(s) to top.
     Dim oSset As AcadSelectionSet
     Dim oEnt
     Dim i As Integer
     Dim setName As String

     setName = "$Order$"
     'Make sure selection set does not exist
     For i = 0 To ThisDrawing.SelectionSets.Count - 1
          If ThisDrawing.SelectionSets.Item(i).Name = setName Then
               ThisDrawing.SelectionSets.Item(i).Delete
               Exit For
          End If
     Next i
     Set oSset = ThisDrawing.SelectionSets.Add(setName)
     oSset.SelectOnScreen

     If oSset.Count > 0 Then
          ReDim arrObj(0 To oSset.Count - 1) As AcadObject
          'Process each object
          i = 0
          For Each oEnt In oSset
               Set arrObj(i) = oEnt
               i = i + 1
          Next
     End If

     On Error GoTo Err_Control
     'Get an extension dictionary and, if necessary, add a SortentsTable object
     Dim eDictionary As Object
     Set eDictionary = ThisDrawing.ModelSpace.GetExtensionDictionary
     
     ' Prevent failed GetObject calls from throwing an exception
     On Error Resume Next
     Dim sentityObj As Object
     Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")

     On Error GoTo 0
     
     If sentityObj Is Nothing Then
          ' No SortentsTable object, so add one
          Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
     End If

     'Move selected object(s) to the top
     sentityObj.MoveToTop arrObj
     Application.Update

     Exit Sub
Err_Control:
     If Err.Number <> 0 Then MsgBox Err.Description
End Sub

[Clinri]

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

[Clinri]

Сообщение от Олег (jr.) Может обойтись без градиента только солидом и применить DrawOrder по порядку наложения объектов будет меньше весить

у Solid не нашёл свойства DrawOrder (кроме AcadSortentsTable)

или я что то не понимаю..
подскажете?
ибо градиентом програмка очень медленно работает, особенно когда их около 100 штук, скорость по экспоненте при построении падает

и как на рисунке выше видно заливка немного перекрывает линию, и она становится не чёткой, пробовал переместить код отрисовки сплайнов после заливки, но тогда заливка ругается что нечего заливать, ибо сплайнов нет... Update к сплайнам в конце применял, в надежде что он перерисуется и окажется сверху, не помогло
Помогло рисование 2ой раз в том же месте такого же сплайна, но это черезчур много объектов выходит, ещё медленне работает.
Увеличил толщину линий сплайна - тоже помогло, но только при печати, на экране выглядит всё как еле видные прерывистые линии
как я понимаю в AutoCAD объект нарисованный последним рисуется поверх, а можно ли поднимать наверх объекты которые были нарисованы раньше?
Спасибо

[Clinri]

В общем работа продолжается...
одна из проблем которая терзает: как програмно определить версию AutoCAD? Ибо например в коде:

Код:

[Выделить все]

Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17")

для autocad 2005 это число 16, а для 2008-17, иначе ошибка, или можно опертор IF использовать и в случает ошибки пробовать другое значение? только я не знаю можно ли так делать.
кто уже сталкивался с подобными трудностями, подскажите пожалуйста

[Олег (jr.)]

Сообщение от Clinri В общем работа продолжается... одна из проблем которая терзает: как програмно определить версию AutoCAD? Ибо например в коде: Код: [Выделить все] Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.17") для autocad 2005 это число 16, а для 2008-17, иначе ошибка, или можно опертор IF использовать и в случает ошибки пробовать другое значение? только я не знаю можно ли так делать. кто уже сталкивался с подобными трудностями, подскажите пожалуйста

Смотри сюда

Код:

[Выделить все]

 version=Left(ThisDrawing.GetVariable("ACADVER"), 2)

и добавь к строке

Код:

[Выделить все]

"AutoCAD.AcCmColor. " & version

[Clinri]

Сообщение от Олег (jr.) Смотри сюда Код: [Выделить все] version=Left(ThisDrawing.GetVariable("ACADVER"), 2) и добавь к строке Код: [Выделить все] "AutoCAD.AcCmColor." & version

спасибо! так и сделал:

Код:

[Выделить все]

Dim Version As String
Version = Left(ThisDrawing.GetVariable("ACADVER"), 2) 'для autocad 2005-16 2008-17
Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor." & Version)

работает корректно

теперь выглядит вот так: