[nolte]

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

Код:

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

 
(defun c:test (/ lst lst_p)
(if(not
     (eq
       (vlax-safearray-get-u-bound
         (setq lst
           (vlax-variant-value
	     (vla-intersectwith
	       (vlax-ename->vla-object(car(entsel)))
	       (vlax-ename->vla-object(car(entsel)))
	       acExtendNone
            ) ;end vla-intersectwith
	  ) ;end vlax-variant-value
	) ;end setq
	1
     ) ;end vlax-safearray-get-u-bound
     '-1
    ) ;end eq
) ;end not
	(setq lst_p(vlax-safearray->list lst))
	(princ "\nNET PERESECHENIY.")
) ;end if
) ;end defun

[VVA]

Пробуй. Идея была взята отсюда Free Stuff
Проблема уже обсуждалась раньше
Почему некорректно работает vla-intersectwith?
как работает vla-IntersectWith ?
Точка пересечения объектов с нулевой координатой Z

Код:

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

 
(defun c:test (/ lst lst_p)
  (if
    (setq lst
	   (lib:GetInters
	     (vlax-ename->vla-object (car (entsel)))
	     (vlax-ename->vla-object (car (entsel)))
	     acExtendNone
	   )
    )
     (princ lst)
     (princ "\nNET PERESECHENIY.")
  )
  (princ)
)

;|============== lib:GetInters ====================
*  Возвращает все пересечения между двумя объектами
*  Один из элементов может быть блоком
   Arguments [Type]:
   FstO = Первый объет  [VLA-OBJECT]
   NxtO = Второй объект [VLA-OBJECT]
   Mde = Тип пересечения [INT]
         Constants:
         - acExtendNone           Does not extend either object.
         - acExtendThisEntity     Extends the FstO object.
         - acExtendOtherEntity    Extends the NxtO object.
         - acExtendBoth           Extends both objects.
  Возвращает [Type]:
   > Список точек '((1.0 1.0 0.0)...[list]
   > Nil если пересечений не найдено
 Notes:
   - Один из элементов должен быть не блок
=======================================================|; 
(defun lib:GetInters (FstO NxtO Mde / IntLst PtLst)
 (cond
   ((and (= (vla-get-ObjectName FstO) "AcDbBlockReference")
	 (not (vlax-property-available-p FstO 'Path))) ;_not Xref
    (setq PtLst (lib:GetBlockInters FstO NxtO Mde)))
   ((and (= (vla-get-ObjectName NxtO) "AcDbBlockReference")
	 (not (vlax-property-available-p NxtO 'Path))) ;_not Xref
    (setq PtLst (lib:GetBlockInters NxtO FstO Mde)))
   ((or ;_Xref
    (vlax-property-available-p FstO 'Path)
    (vlax-property-available-p NxtO 'Path))
    (setq PtLst nil))
   (t
    (setq IntLst (vlax-invoke FstO 'IntersectWith NxtO Mde))
    (if IntLst
      (setq PtLst (lib:group-by-num IntLst 3))
      (setq PtLst nil))
    ))
  PtLst
  )
;|========== Function lib:GetBlockInters =========================
; Returns all intersection points between a Block and an object.
; Copyright:
;   ©2001-2002 MENZI ENGINEERING GmbH, Switzerland
;   http://www.menziengineering.ch/Downloads/Download.htm
; Arguments [Type]:
;   Blk = Block object [VLA-OBJECT]
;   Obj = Object [VLA-OBJECT]
;   Mde = Intersection mode [INT]
;         Constants:
;         - acExtendNone           Does not extend either object.
;         - acExtendThisEntity     Extends the Fst object.
;         - acExtendOtherEntity    Extends the Nxt object.
;         - acExtendBoth           Extends both objects.
; Return [Type]:
;   > list of points '((1.0 1.0 0.0)...[list]
;   > Nil if no intersection found
; Notes:
;   - Because of a (reported) bug in A2k4/A2k5/A2k6, the used explode method
;     will fail on NUS blocks. No limitations in A2k, A2ki and A2k2
      NUS - Non-Uniformly Scaled 
      Масштабированные с разными коэффициентами по разным осям
|; 
(defun lib:GetBlockInters  (Blk Obj Mde / ObjNme PntLst TmpVal)
 (foreach memb (vlax-invoke Blk 'Explode)
  (setq ObjNme (vla-get-ObjectName memb))
  (cond
   ((or
     (not (vlax-method-applicable-p memb 'IntersectWith))
     (and
      (eq ObjNme "AcDbHatch")
      (eq (strcase (vla-get-PatternName memb)) "SOLID")
     )
     (eq ObjNme "AcDb3dSolid")
    )
   )
   ((eq ObjNme "AcDbBlockReference")
    (if (setq TmpVal (lib:GetBlockInters memb Obj Mde))
     (setq PntLst (append PntLst TmpVal))
    )
   )
   (T
    (if (setq TmpVal (lib:GetInters memb Obj Mde))
     (setq PntLst (append PntLst TmpVal))
    )
   )
  )
  (vla-Delete memb)
 )
 PntLst
)

[nolte]

VVA, БОЛЬШОЕ СПАСИБО.
Мысль понял и так как задача у меня простая: плиния пересекает блок или нет, то и решил я ее просто, "БЯЛЫНИЧСКИМ" способом

Код:

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

 
;;;;;;;;;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;;;;;;;;;	ФУНКЦИЯ ПЕРЕСЕЧЕНИЯ ПЛИНИИ С БЛОКОМ
;;;;;;;;;;;
;;;		АРГУМЕНТЫ
;;;	PL	-	VLA-OBJECT PLINE
;;;	BL	- VLA-OBJECT BLOCK
;;;		ПРИМЕР ВЫЗОВА
;;;	(l-int-pl-bl(vlax-ename->vla-object(car(entsel"\nPL :")))(vlax-ename->vla-object(car(entsel"\nBL :"))))
;;;;;;;;;;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun l-int-pl-bl (pl bl / p lst pp)
(vla-getboundingbox bl 'p1 'p2)
(mapcar '(lambda(a b)
		(if (setq p(inters a b (vlax-safearray->list p1)(vlax-safearray->list p2) T)) (setq pp p))
		)
		(setq lst
			(mapcar 'cdr
				(vl-remove-if-not '(lambda(a)
					(eq (car a) 10))(entget(vlax-vla-object->ename pl))
				)
			)
		)
		(cdr lst)
)
pp
)