Возвращение координат.

Возвращение координат. · 28.03.2007, 16:06

Как в VBA возвратить начальную и конечную точку размерности?

den001 · 28.03.2007, 22:09

Какой размерности-то?? Можно уточнить, о чем речь?

Constructor450 · 29.03.2007, 04:55

AcadDimRotated.

Кулик Алексей aka kpblc · 29.03.2007, 08:14

Через DXF можно (13 и 14 группы), через VBA (он же activex) - не знаю. По-моему, не получится.

Constructor450 · 29.03.2007, 11:14

А другие мнения есть у кого-нибудь?

den001 · 29.03.2007, 20:56

Честно сказать, с размерами возиться не приходилось. При беглом осмотре решения, действительно, не видно. В свойствах есть все, кроме искомого

Constructor450 · 30.03.2007, 08:19

Значит моя программа летит ко всем чертям.
Хотел что-бы с чертежа все выделенные объекты автокада переносились в Excel, а потом их можно было вставить в любой чертеж.Такая своя база данных.

Кулик Алексей aka kpblc · 30.03.2007, 08:31

А нечего было на VBA ставку делать

Шутка

Если серьезно, то можно попробовать сделать примерно так: вызвать лисп, в который (правда, не знаю как - может, проще всего будет передавать через UserS1) передать список хендлов размеров; лиспом взять координаты и сохранить в текстовый файл; лиспом же поднять "флаг выполнения" (например, та же самая UserS1 поменяет значение, а в vba выполнять проверку на изменение); через vba читать файл. Геморройно, но с утра пораньше у меня башка качественно не соображает.

Constructor450 · 30.03.2007, 08:48

А если попробывать модифицировать AcadDimRotated
в AcadDimAligned . Такое возможно?

Кулик Алексей aka kpblc · 30.03.2007, 08:55

Модифицировать - нет. Но вот удалить, а потом создать - да. Только все равно для создания надо знать базовые точки размера...

Constructor450 · 30.03.2007, 08:59

А команда object.Modified(Entity) что может сделать?

Кулик Алексей aka kpblc · 30.03.2007, 09:08

Оффтоп: Блин, чат получается

Это не команда, а событие.

Цитата:

This event will be triggered whenever the object is modified. Modification includes whenever the value of a property is set, even if the new value is equal to the current value.

When coding in VBA, you must provide an event handler for all objects enabled for the Modified event. If you do not provide a handler, VBA may terminate unexpectedly.

No events will be fired while a modal dialog is being displayed.

Как я понимаю, фактически объектный реактор, который прописан просто на VBA. Но оно тут поможет как мертвому припарки - оно начинает работать только в момент модификации примитива. А поскольку это так, то тут есть несколько проблем:
1. Получить координаты все равно невозможно - передается-то объект, а не его ename-представление.
2. Даже если бы не было п.1, все равно - как получить координаты, если объект меняется? Какие координаты ты получишь - до модификации примитива или после?
3. И, наконец, последнее. Как его активировать-то, это событие (хотя тут можно сымитировать изменение - например, цвет; но вопрос - а состояние слоев ты отслеживать не собираешься? При такой работе на заблокированном слое, скорее всего, получишь ошибку).

Constructor450 · 30.03.2007, 12:20

Я понял "Modified" это событие,которе активизируется когда с объектом что-то происходит.
Ну а если банально поменять ObjectName или ObjectID.
Простите за мою простоту, это моя первая программа.

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

Кулик Алексей aka kpblc · 30.03.2007, 12:44

Цитата:

Я понял "Modified" это событие,которе активизируется когда с объектом что-то происходит.

Ага, только его "запустить" надо.

Цитата:

банально поменять ObjectName или ObjectID.

Где поменять? Где там это участвует? Вот пример из справки:

Код:

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

Public WithEvents PLine As AcadLWPolyline    ' Use with Modified Event Example
Sub Example_Modified()
     ' This example creates a lightweight polyline in model space and
     ' references the PolyLine using the public variable (PLine) which
     ' is set up to intercept Modified events.
     '
     ' This example then modifies the new object, triggering the code
     ' in the Modified event.
    
    Dim points(0 To 9) As Double
    
    ' Define the 2D polyline points
    points(0) = 1: points(1) = 1
    points(2) = 1: points(3) = 2
    points(4) = 2: points(5) = 2
    points(6) = 3: points(7) = 2
    points(8) = 4: points(9) = 4
        
    ' Create a lightweight Polyline object in model space
    '
    ' * Note: We are returning the new PolyLine object into a Module
    ' level variable.  This allows us to intercept events associated
    ' with that particular object.
    Set PLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
    
    ThisDrawing.Application.ZoomAll
    
    ' Modify object to trigger event.
    '
    ' * Note: The event code for the PolyLine modification will be triggered
    ' before we move forward and refresh the view, so the line will not
    ' appear blue when the event message box is displayed.
    Dim color As AcadAcCmColor
    Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
    Call color.SetRGB(80, 100, 244)
    PLine.TrueColor = color

    ThisDrawing.Regen acAllViewports
    
End Sub

Private Sub PLine_Modified(ByVal pObject As AutoCAD.IAcadObject)
    ' This example intercepts an object's Modified event.
    '
    ' This event is triggered when an object supporting this event is modified.
    '
    ' To trigger this code: Modify an object connected to this event
    ' * Note: By connected, we mean the object set up to intercept events using
    ' the VBA WithEvents statement

    ' Use the "pObject" variable to determine which object was modified
    MsgBox "You just modified an object with an ID of: " & pObject.ObjectID
    
End Sub

То есть ты передаешь не ObjectName или ObjectID, а напрямую указатели на примитивы. Попытка передать "нештатные" значение вывалит ошибку.

Constructor450 · 30.03.2007, 12:48

Не в "Modified", а в своей программе.

Кулик Алексей aka kpblc · 30.03.2007, 12:53

ну это уж будет определяться твоим кодом. Но! Как бы ты ни крутился, все равно работать сможешь из-под vba с activex-объектом. dxf-представление его ты не получишь.

Constructor450 · 30.03.2007, 14:10

Вот моя недоработанная программа.

Public filename As String

Public Sub SelOnScreen()
Dim objSS As AcadSelectionSet
Dim excelsheet As Object: Dim i As Integer
Dim acCircle As AcadCircle: Dim acline As AcadLine: Dim acArc As AcadArc: Dim AcEllipse As AcadEllipse
Dim AcXline As AcadXline: Dim AcRay As AcadRay: Dim AcPolyline As AcadLWPolyline: Dim acSpline As AcadSpline
Dim acText As AcadText: Dim acMText As AcadMText: Dim acRotDim As AcadDimAligned
Dim retCoord As Variant: Dim x As Long: Dim y As Long
Dim nbr_of_segments As Long: Dim nbr_of_vertices As Long: Dim segment As Long
Dim StartWidth As Double: Dim EndWidth As Double
'Если косяк, пошел в дуню
On Error GoTo Done
'Выбирай объекты
With ThisDrawing.Utility
Set objSS = ThisDrawing.SelectionSets.Add("TestSelectOnScreen")
objSS.SelectOnScreen
objSS.Highlight True
.Prompt vbCr & objSS.Count & " entities selected"
.GetString False, vbLf & "Enter to continue "
objSS.Highlight False
End With
'Если ничего не выбрал, пошел в дуню
If objSS.Count = 0 Then GoTo Done
'Создаем таблицу Excel
Set excelsheet = CreateObject("Excel.Sheet")
excelsheet.Application.Visible = True
With excelsheet.Application
'Заполняем таблицу
For i = 0 To objSS.Count - 1
.cells(i + 1, 1).Value = objSS(i).ObjectName
.cells(i + 1, 2).Value = objSS(i).TrueColor.ColorIndex
.cells(i + 1, 3).Value = objSS(i).Linetype
.cells(i + 1, 4).Value = objSS(i).LinetypeScale
.cells(i + 1, 5).Value = objSS(i).Lineweight
'Данные для круга
If objSS(i).ObjectName = "AcDbCircle" Then
Set acCircle = objSS.Item(i)
.cells(i + 1, 6).Value = acCircle.Center(0)
.cells(i + 1, 7).Value = acCircle.Center(1)
.cells(i + 1, 8).Value = acCircle.Radius
End If
'Данные для линии
If objSS(i).ObjectName = "AcDbLine" Then
Set acline = objSS.Item(i)
.cells(i + 1, 6).Value = acline.StartPoint(0)
.cells(i + 1, 7).Value = acline.StartPoint(1)
.cells(i + 1, 8).Value = acline.EndPoint(0)
.cells(i + 1, 9).Value = acline.EndPoint(1)
End If
'Данные для дуги
If objSS(i).ObjectName = "AcDbArc" Then
Set acArc = objSS.Item(i)
.cells(i + 1, 6).Value = acArc.Center(0)
.cells(i + 1, 7).Value = acArc.Center(1)
.cells(i + 1, 8).Value = acArc.Radius
.cells(i + 1, 9).Value = acArc.StartAngle
.cells(i + 1, 10).Value = acArc.EndAngle
End If
'Данные для элипса
If objSS(i).ObjectName = "AcDbEllipse" Then
Set AcEllipse = objSS.Item(i)
.cells(i + 1, 6).Value = AcEllipse.Center(0)
.cells(i + 1, 7).Value = AcEllipse.Center(1)
.cells(i + 1, 8).Value = AcEllipse.MajorAxis(0)
.cells(i + 1, 9).Value = AcEllipse.MajorAxis(1)
.cells(i + 1, 10).Value = AcEllipse.RadiusRatio
End If
'Данные для бесконечной
If objSS(i).ObjectName = "AcDbXline" Then
Set AcXline = objSS.Item(i)
.cells(i + 1, 6).Value = AcXline.SecondPoint(0)
.cells(i + 1, 7).Value = AcXline.SecondPoint(1)
.cells(i + 1, 8).Value = AcXline.DirectionVector
End If
'Данные для луча
If objSS(i).ObjectName = "AcDbRay" Then
Set AcRay = objSS.Item(i)
.cells(i + 1, 6).Value = AcRay.BasePoint(0)
.cells(i + 1, 7).Value = AcRay.BasePoint(1)
.cells(i + 1, 8).Value = AcRay.SecondPoint(0)
.cells(i + 1, 9).Value = AcRay.SecondPoint(1)
End If
'Данные для полилинии
If objSS(i).ObjectName = "AcDbPolyline" Then
Set AcPolyline = objSS.Item(i)
retCoord = AcPolyline.Coordinates
x = LBound(retCoord)
y = UBound(retCoord)
nbr_of_vertices = (y + 1) \ 2
.cells(i + 1, 6).Value = nbr_of_vertices
If AcPolyline.Closed Then
nbr_of_segments = nbr_of_vertices
.cells(i + 1, 7).Value = nbr_of_segments
Else
nbr_of_segments = nbr_of_vertices - 1
.cells(i + 1, 7).Value = nbr_of_segments
End If
x = 0: segment = 0
'Возвращение точек полилинии
Do While nbr_of_vertices > 0
.cells(i + 1, x + 8).Value = retCoord(x)
.cells(i + 1, x + 9).Value = retCoord(x + 1)
x = x + 2: nbr_of_vertices = nbr_of_vertices - 1
Loop
Do While nbr_of_segments > 0
'Возвращение начальной и конечной ширины полилинии,bulge
AcPolyline.GetWidth segment, StartWidth, EndWidth
.cells(i + 1, x + 8).Value = StartWidth
.cells(i + 1, x + 9).Value = EndWidth
.cells(i + 1, x + 10).Value = AcPolyline.GetBulge(segment)
x = x + 3
segment = segment + 1: nbr_of_segments = nbr_of_segments - 1
Loop
End If
'Данные для сплайна
If objSS(i).ObjectName = "AcDbSpline" Then
Set acSpline = objSS.Item(i)
retCoord = acSpline.fitPoints
x = LBound(retCoord)
y = UBound(retCoord)
nbr_of_vertices = (y + 1) \ 3
.cells(i + 1, 6).Value = nbr_of_vertices
.cells(i + 1, 7).Value = acSpline.StartTangent(0)
.cells(i + 1, 8).Value = acSpline.StartTangent(1)
.cells(i + 1, 9).Value = acSpline.StartTangent(2)
.cells(i + 1, 10).Value = acSpline.EndTangent(0)
.cells(i + 1, 11).Value = acSpline.EndTangent(1)
.cells(i + 1, 12).Value = acSpline.EndTangent(2)
Do While nbr_of_vertices > 0
.cells(i + 1, x + 13).Value = retCoord(x)
.cells(i + 1, x + 14).Value = retCoord(x + 1)
.cells(i + 1, x + 15).Value = retCoord(x + 2)
x = x + 3: nbr_of_vertices = nbr_of_vertices - 1
Loop
End If
'Данные для однострочного текста
If objSS(i).ObjectName = "AcDbText" Then
Set acText = objSS.Item(i)
.cells(i + 1, 6).Value = acText.TextString
.cells(i + 1, 7).Value = acText.InsertionPoint(0)
.cells(i + 1, 8).Value = acText.InsertionPoint(1)
.cells(i + 1, 9).Value = acText.InsertionPoint(2)
.cells(i + 1, 10).Value = acText.Height
.cells(i + 1, 11).Value = acText.ObliqueAngle
.cells(i + 1, 12).Value = acText.Rotation
.cells(i + 1, 13).Value = acText.StyleName
End If
'Данные для многострочного текста
If objSS(i).ObjectName = "AcDbMText" Then
Set acMText = objSS.Item(i)
.cells(i + 1, 6).Value = acMText.InsertionPoint(0)
.cells(i + 1, 7).Value = acMText.InsertionPoint(1)
.cells(i + 1, 8).Value = acMText.InsertionPoint(2)
.cells(i + 1, 9).Value = acMText.Width
.cells(i + 1, 10).Value = acMText.TextString
.cells(i + 1, 11).Value = acMText.StyleName
.cells(i + 1, 12).Value = acMText.Rotation
End If
'Данные для линейной размерности ?????????????????

Next
End With
'Вызов формы сохранения
Frmsv.Show
'Сохраняем таблицу
excelsheet.SaveAs "C:\Program Files\AutoCAD 2004\VBA\" & Trim$(filename) & ".XLS"
excelsheet.Application.Quit
'Дуня
Done:
If Not objSS Is Nothing Then
objSS.Delete
End If
End Sub

Кулик Алексей aka kpblc · 30.03.2007, 14:49

Если честно, то мне интересна конечная цель этого кода. Что надо сделать-то?

Constructor450 · 30.03.2007, 15:08

Это только часть кода.
В этой части все что попало под выделение должно быть переведено в Excel.
В данном случае я застопорился на acaddimrotated.Нужно перенести в excel (XLine1Point, XLine2Point, DimLineLocation, RotationAngle) как минимум.
В другой части,которая еще несделана идет обратный процесс.Но это еще не все. Появляется форма в которой предлагается заменить значения всех размеров (text.Measurement) на требуемое значение пользователем.Получается в какой-то степени "слепыш", кто конструктор тот поймет.

Constructor450 · 02.04.2007, 10:52

Решил дополнительно учить LISP.
Может кто-нибудь поможет перевести с VBA некоторые фрагменты моего кода? Касательно технологии передачи ячейкам excelя значений.

Кулик Алексей aka kpblc · 02.04.2007, 12:06

Дело вот в чем (уж прости, снова влезу). У тебя нет прямой необходимости сразу открывать Excel и работать в него (это во-первых). Вполне достаточно просто создавать текстовый файл (дав ему расширение xls), разделяя данные тэгом табуляции. А потом уже можно будет попробовать и Excel на него натравить (хотя на фига, не очень понимаю).
Теперь по коду. У тебя не все данные учитываются - в частности, нет данных по вектору выдавливания (normal, она же группа 210). А так... Вот примерный вариант вывода на лиспе в текстовый файл:

Код:

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

(defun seltofile (/ selset file_name file_handle *error* res)
  (defun *error* (msg)
    (vl-catch-all-apply '(lambda () (close file_handle)))
    (princ msg)
    (princ)
    ) ;_ end of defun

  (if (and (setq selset (ssget))
	   (setq file_name (getfiled "Файл результата:" "" "xls" 1))
	   ) ;_ end of and
    (progn
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
	(setq
	  res
	   (append res
		   (list (cons (assoc 100
				      (cdr (vl-member-if
					     '(lambda (x) (= (car x) 100))
					     (entget ent)
					     ) ;_ end of vl-member-if
					   ) ;_ end of cdr
				      ) ;_ end of assoc
			       (vl-remove-if
				 '(lambda (x)
				    (or	(member (car x) '(-1 0 5 330 102 100))
					(member (cdr x) '("AcDbEntity"))
					) ;_ end of or
				    ) ;_ end of lambda
				 (entget ent)
				 ) ;_ end of vl-remove-if
			       ) ;_ end of cons
			 ) ;_ end of list
		   ) ;_ end of append
	  ) ;_ end of setq
	) ;_ end of foreach
      (setq file_handle (open file_name "w"))
      (foreach item res
	(write-line
	  (vl-string-trim
	    "()"
	    (vl-string-trim
	      "\t"
	      (apply
		'strcat
		(mapcar
		  '(lambda (x)
		     (strcat (vl-string-trim "()" (vl-princ-to-string x)) "\t")
		     ) ;_ end of LAMBDA
		  (mapcar 'cdr item)
		  ) ;_ end of mapcar
		) ;_ end of apply
	      ) ;_ end of vl-string-trim
	    ) ;_ end of vl-string-trim
	  file_handle
	  ) ;_ end of WRITE-LINE
	) ;_ end of foreach
      (close file_handle)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

Constructor450 · 02.04.2007, 12:19

Даа...Силен лисп.
Попробую разобраться. Спасибо!

Кулик Алексей aka kpblc · 02.04.2007, 12:21

Блин, там пара строк лишние... Вроде особо режущее глаза снес:

Код:

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

(defun seltofile (/ selset file_name file_handle *error* res)
  (defun *error* (msg)
    (vl-catch-all-apply '(lambda () (close file_handle)))
    (princ msg)
    (princ)
    ) ;_ end of defun

  (if (and (setq selset (ssget))
      (setq file_name (getfiled "Файл результата:" "" "xls" 1))
      ) ;_ end of and
    (progn
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
   (setq
     res
      (append res
         (list (cons (assoc 100
                  (cdr (vl-member-if
                    '(lambda (x) (= (car x) 100))
                    (entget ent)
                    ) ;_ end of vl-member-if
                  ) ;_ end of cdr
                  ) ;_ end of assoc
                (vl-remove-if
             '(lambda (x)
                (member (car x) '(-1 0 5 330 102 100))
                ) ;_ end of lambda
             (entget ent)
             ) ;_ end of vl-remove-if
                ) ;_ end of cons
          ) ;_ end of list
         ) ;_ end of append
     ) ;_ end of setq
   ) ;_ end of foreach
      (setq file_handle (open file_name "w"))
      (foreach item res
   (write-line
     (vl-string-trim
       "()"
       (vl-string-trim
         "\t"
         (apply
      'strcat
      (mapcar
        '(lambda (x)
           (strcat (vl-string-trim "()" (vl-princ-to-string x)) "\t")
           ) ;_ end of LAMBDA
        (mapcar 'cdr item)
        ) ;_ end of mapcar
      ) ;_ end of apply
         ) ;_ end of vl-string-trim
       ) ;_ end of vl-string-trim
     file_handle
     ) ;_ end of WRITE-LINE
   ) ;_ end of foreach
      (close file_handle)
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of defun

Constructor450 · 11.04.2007, 08:48

(progn
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))

Чего-то не пойму почему здесь (mapcar 'cadr (ssnamex selset))), можно наверно просто:
(progn
(foreach ent (vl-remove-if 'listp (ssname selset))
:?:

Кулик Алексей aka kpblc · 11.04.2007, 08:49

Код:

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

_$ (vl-remove-if 'listp (ssname (ssget)))
ERRNO # 0: too few arguments

Добавлено:

Код:

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

_$ (vl-remove-if 'listp (ssnamex (ssget)))
nil

---
Добавлено 2: Естественно, что (ssget) возвращает у меня набор. Чтобы не быть совсем голословным:

Код:

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

_$ (setq selset (ssget))
<Selection set: c>
_$ (SSLENGTH selset)
10
_$ (vl-remove-if 'listp (ssname selset))
ERRNO # 0: too few arguments
_$ (vl-remove-if 'listp (ssnamex selset))
nil

Constructor450 · 11.04.2007, 09:37

Я разобрался вроде бы, почему ошибки небыло, надобыло презагрузить приложение.
Этот язык сведет меня с ума.
Жду книгу Полещука.

28.03.2007, 16:06		#1
Возвращение координат. Constructor450 был КМДистом, сейчас ЖБКист Регистрация: 28.03.2007 Сообщений: 241 Как в VBA возвратить начальную и конечную точку размерности?
Просмотров: 8218