[fausto]

Нужен макрос на VBA для расчета площади пересечения выпуклых фигур - то есть выбирается 1 фигура, потом вторая и считается площадь пересечения. С использованием регионов или без них не важно.

[Дима_]

add-region, boolean acIntersection, area - вот в кратце и весь макрос - оформи сам если не знаешь как - опиши что нужно.

[fausto]

После нажатия кнопки на форме, кликом выделяются 2 фигуры и в случае их пересечения выводится площадь в textbox на форме.

[Дима_]

Код:

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

(vl-load-com)
(defun spaceinit (); подготовка для работы с vla пространством
(setq	acadObject (vlax-get-acad-object)
	acadDocument (vlax-get-property acadObject 'ActiveDocument)
	mSpace (vlax-get-property acadDocument 'Modelspace)
);end of setq
);end of spaceinit

(defun makeregion (objlst / sf) ; создает области из объектов списка objlist
(setq objlst (toename objlst))
(setq sf (vl-catch-all-apply
'(lambda (sf)
(setq sf (vlax-make-safearray vlax-vbobject (cons 0 (1- (length objlst)))))
(vlax-safearray-fill sf (mapcar 'vlax-ename->vla-object objlst))
(mapcar 'vlax-vla-object->ename (vlax-safearray->list (vlax-variant-value (vla-addregion mspace sf))))
);end of lambda
(list sf)
));end of catch&setq
(if (= (type sf) 'list) sf nil)
);end of makeregion

(defun tovla (obj); рекурсивно в vla
(if obj
(if (= (type obj) 'ename) (vlax-ename->vla-object obj) 
(if (= (type obj) 'list) (mapcar 'tovla obj)
obj
)));end of if *3
);end of tovla

(defun toename (obj); рекурсивно в Ename
(if obj
(if (= (type obj) 'vla-object) (vlax-vla-object->ename obj) 
(if (= (type obj) 'list) (mapcar 'toename obj)
obj
)));end of if *3
);end of toename

(defun cod (cd obj) ; возращает код cd примитива obj.
(setq obj (toename obj))
(if (and obj (= (type obj) 'ename))
(cdr (assoc cd (entget obj)))
));end of cod

(defun getobjarea (obj)
(if (= (cod 0 obj) "REGION")
(vla-copy (tovla obj))
(tovla (car (makeregion (list obj))))
);end of if
);end of getobjarea

(spaceinit)
;***** сама программа

(defun c:intersectarea ( / obj1 obj2 *error*)
(defun *error* (msg)
(mapcar '(lambda (obj) (if obj (vla-delete obj))) (list obj1 obj2))
);end of *error*
(while (not obj1) (setq obj1 (getobjarea (car (entsel)))))
(while (not obj2) (setq obj2 (getobjarea (car (entsel)))))
(vla-boolean obj1 acintersection obj2)
(sssetfirst nil (ssadd (toename obj1)))
(alert (strcat "Площадь пересечения " (rtos (vla-get-area obj1))))
(vla-delete obj1)
(princ)
);end of intersectarea

запускать INTERSECTAREA

[fausto]

Это LISP, а требуется именно VBA (

[Дима_]

...могу только предложить переписать самому

[fausto]

Спс за макрос, при попытке сделать в VBA столкнулся с вопросом:
Можно ли сделать регион из 1 объекта, делаю:

' выбираю мышью фигуру
ThisDrawing.Utility.GetEntity ObjOne, AnyPnt, "Выберите объект 1"
' делаю регион
regg1 = ThisDrawing.ModelSpace.AddRegion(ObjOne)

выдает ошибку и требует массив для преобразования в область

[Олег (jr.)]

Сообщение от fausto Спс за макрос, при попытке сделать в VBA столкнулся с вопросом: Можно ли сделать регион из 1 объекта, делаю: ' выбираю мышью фигуру ThisDrawing.Utility.GetEntity ObjOne, AnyPnt, "Выберите объект 1" ' делаю регион regg1 = ThisDrawing.ModelSpace.AddRegion(ObjOne) выдает ошибку и требует массив для преобразования в область

Смотри Help там все есть

Код:

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

Option Explicit

Sub GetRegionArea()
Dim pfs As AcadSelectionSet
Dim ftype(1) As Integer
Dim fdata(1) As Variant
Dim dxfCode, dxfValue

ftype(0) = 0: ftype(1) = 70
fdata(0) = "LWPOLYLINE": fdata(1) = 1
dxfCode = ftype: dxfValue = fdata

On Error GoTo Err_Control

Set pfs = ThisDrawing.PickfirstSelectionSet
pfs.Clear
ThisDrawing.Utility.Prompt vbLf & "Select 2 polygons only"
pfs.SelectOnScreen dxfCode, dxfValue
If pfs.Count <> 2 Then
MsgBox "Selected: " & pfs.Count & " objects" & vbCr & _
"Must be 2 polygons selected only!"
Exit Sub
End If

Dim objs1(0) As AcadEntity
Dim objs2(0) As AcadEntity

Set objs1(0) = pfs.Item(0)
Set objs2(0) = pfs.Item(1)
' Create the 2 regions
Dim regobj1 As Variant
Dim regobj2 As Variant
On Error Resume Next
regobj1 = ThisDrawing.ModelSpace.AddRegion(objs1)
Dim reg1 As AcadRegion
Set reg1 = regobj1(0)
regobj2 = ThisDrawing.ModelSpace.AddRegion(objs2)
Dim reg2 As AcadRegion
Set reg2 = regobj2(0)

' perform intersection operation
reg1.Boolean acIntersection, reg2

MsgBox "Area of intersection is: " & Round(reg1.Area, 3) & " drawing units"

Dim resp As VbMsgBoxResult
resp = MsgBox("Do you want to delete intersection region?", vbYesNo, "Answer this question")
If resp = vbYes Then
'delete region if you need
reg1.Delete
End If
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub

~'J'~

[Дима_]

ну так создай массив из 1-го елемента (см. лисповский вариант - makeregion).

[fausto]

Работает, а какой смысл в выражении
pfs.SelectOnScreen dxfCode, dxfValue ?
если можно просто
pfs.SelectOnScreen ,
причем в 1 варианте не выделяются эллипсы, окружности, пололинии, а во 2 выделяется всё

[Олег (jr.)]

Сообщение от fausto Работает, а какой смысл в выражении pfs.SelectOnScreen dxfCode, dxfValue ? если можно просто pfs.SelectOnScreen , причем в 1 варианте не выделяются эллипсы, окружности, пололинии, а во 2 выделяется всё

Ну брат, тебе надо срочно в Help
Это самые азы...

~'J'~