LISP. Построение перпендикуляров к любым линейным примитивам (Страница 1 из 2)

Кажется мне, что и такая программа:

(defun C:PPER (/ osm tper)
(setq osm (getvar "OSMODE"))
(setvar "OSMODE" 512)
(setq tper (getpoint "\n Укажите точку: "))
(vl-cmdf "_xline" "_per" tper tper "")
(setvar "OSMODE" osm)
(princ)
)

строит перпендикуляр к отрезкам, полилиниям, дугам, окружностям, эллипсам, эллиптическим дугам, кольцам, сплайнам, лучам и х-линиям в указанной точке. Перепендикуляр к мультилинии не строит, а к 3D-полилинии строит как попало.

Да так действительно проще.

Примерно так, хоть возможно немного коряво. Можно строить как перпендикуляры, так и касательные нужной длинны. Код особо не тестировал:

(defun c:per(/ oldEcho oldOsm uPnt sSet oldOrt
        sCurve Dr Ang1 Ang2 pt1 pt2 *error*)
  (vl-load-com)
  (defun *error* (msg)
    (setvar "ORTHOMODE" oldOrt)
    (command "_.ucs" "_p")
    (command "_.ucs" "_p")
    (setvar "CMDECHO" oldEcho)
    (setvar "OSMODE" oldOsm)
    (princ)
    ); end of *error*
  (setq oldEcho(getvar "CMDECHO")
        oldOsm(getvar "OSMODE")
        oldOrt(getvar "ORTHOMODE")
   ); end setq
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 819)
  (command "_.ucs" "_w")
  (if
    (and
    (setq uPnt(getpoint "\nSelect point at line or curve -> "))
    (setq sSet(ssget uPnt '((0 . "*LINE,ARC,ELLIPSE,CIRCLE,RAY,XLINE")
               (-4 . "<NOT")(0 . "MLINE")(-4 . "NOT>"))))
    (setq sCurve(vlax-ename->vla-object(ssname sSet 0)))
    (setq Dr(vlax-curve-getFirstDeriv sCurve
      (vlax-curve-getParamAtPoint sCurve uPnt)))
     ); end and
    (progn
      (if(=(cadr dr) 0.0)
    (setq Ang1 0.0)
    (setq Ang1(- pi(atan(/(car dr)(cadr dr)))))
    ); end if
      (setq Ang2(- Ang1(/ pi 2))
        pt1 (polar uPnt Ang1 1.0)
        pt2 (polar uPnt Ang2 1.0)
        ); end setq
      (setvar "OSMODE" 0)
      (command "_.ucs" "_3" uPnt pt1 pt2)
      (setvar "ORTHOMODE" 1)
      (princ "\nSpecify length: ")
      (command "_.line" (trans uPnt 0 1) pause "")
      (command "_.ucs" "_p")
      (command "_.ucs" "_p")
      (setvar "ORTHOMODE" oldOrt)
      ); end progn
    ); end if
  (setvar "CMDECHO" oldEcho)
  (setvar "OSMODE" oldOsm)
  (princ)
  ); end of c:per

Пока у тебя более комфортно, поскольку если перед отрисовкой линии перпендикуляра можно включить привязки Intrsection и Apparent Intersection (чего пока нет) доводить перпендикуляр до пересечения с нужным контуром.
Однако мой код имеет большие возможности для развития потому что позволяет выбирать что отрисовывать перпендикуляр или касательную. А если отрисовть 2 перпендикулярные х-линии, сделать их под цвет экрана или подсветить как направляющие, включить вышеуказанные привязки, то получится очень и очень прикольно. Только учитывая все проверки потребуется намного больше кода.

Маленькое замечание. Если в моих программах заменить привязку "_per" на "_tan", то будет строиться касательная, но только к окружности или дуге.

> kpblc
Да я тут и не претендую на абсолютно готовый вариант. К тому же я не очень-то приветствую сверхуниверсальные программы с множеством проверок на "вшивость"...:) С другой стороны, мне бы и в голову не пришло что-либо отрисовывать на блокированном слое.

Вполне может иметь место ситуация, когда необходимо построить перпендикуляр/касательную от конкретного объекта из точки пересечения нескольких объектов. Ни один из приведенных примеров не даёт такой возможности, а хотелось бы...
С уважением.

Направление понятно, но код, похоже, не рабочий...

Прошу прощения, запускл как (test), а не как (C:test) - тормоз конечно...
А вообще - оригинальная штука, с Вашего позволения применю способ выбора кое-где в своих програмках. Но я имел ввиду не это: допустим необходимо выполнить построение НЕПОСРЕДСТВЕННО  ИЗ  ТОЧКИ  ПЕРЕСЕЧЕНИЯ примитивов, т.е. ткнули в пересечение, а в наборе оказалось несколько объектов и тут как бы и вопрос: "От какого именно?", ну и т.д.

;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
(defun c:perpen ( /
         cmd_key
         Obj_per
         Obj_per_VLAX
         TestColorObj_per
         test_point
         OldColor
         Angl
         orthomode_key
         point
         Derivate
         snap_key
         Param
           )
  (STORE)
  (command "_.UNDO" "_be")
  (setq OLDERROR *ERROR*)
  (setq *ERROR* *MY_ERROR*)
  (vlr-remove-all)
  (setq cmd_key (getvar 'CMDECHO))
  (setvar "CMDECHO" 0)
  (while (= Obj_per nil)
  (terpri)
  (setq Obj_per (entsel "Выделите линию для восстановления перпендикуляра:"))
  )
  (terpri)
  (if (/= Obj_per nil)
    (progn
      (setq Obj_per (car Obj_per))
      (setq Obj_per_VLAX (vlax-ename->vla-object Obj_per))
      (setq TestColorObj_per (vlax-property-available-p Obj_per_VLAX "Color" T))
      (if (= TestColorObj_per T)
    (progn
      (setq OldColor (vlax-get-property Obj_per_VLAX 'Color))
      (if (/= OldColor 1)
        (vlax-put Obj_per_VLAX "Color" 1)
        (vlax-put Obj_per_VLAX "Color" 5)
      )
    )
      )
      (while (= test_point nil)
    (terpri)
    (setq point (getpoint "Укажите точку на линии для восстановления перпендикуляра:"))
    (if (=  (ssget "_C" point point) nil)
      (setq test_point nil)
      (setq test_point (ssmemb Obj_per (ssget "_C" point point)))
    )
      )
      (if (/= test_point nil)
    (progn
      (setq point (vlax-curve-getclosestpointto Obj_per (trans point 1 0)))
      (setq Param (vlax-curve-getParamAtPoint Obj_per point))
      (if (not Param)
        (progn
          (if(equal point(vlax-curve-getStartPoint Obj_per)0.1)(setq Param(vlax-curve-getStartParam Obj_per)))
          (if(equal point(vlax-curve-getEndPoint Obj_per)0.1)(setq Param(vlax-curve-getEndParam Obj_per)))
        )
      )
      (setq Derivate (vlax-curve-getfirstderiv Obj_per Param))
      (setq Angl (- (atof (angtos (angle '(0 0 0) Derivate) 0 4)) 90))
      (setq point (polar '(0 0 0) (angtof (rtos (- (atof (angtos (angle '(0 0 0) (trans point 0 1)) 0 4)) Angl) 2 5)) (distance '(0 0 0) (trans point 0 1))))
      (command "_ucs" "_z" Angl)
      (setq orthomode_key (getvar 'ORTHOMODE))
      (setvar "ORTHOMODE" 1)
      (setq snap_key (getvar 'OSMODE))
      (setvar "OSMODE" 0)
      (command "_line" point pause "")
      (vlax-put Obj_per_VLAX "Color" OldColor)
      (setvar "ORTHOMODE" orthomode_key)
      (setvar "OSMODE" snap_key)
      (command "_ucs" "_p")
    )
      )
    )
  )
  (setvar "CMDECHO" cmd_key)
  (command "_.UNDO" "_e")
  (setq *ERROR* OLDERROR)
  (princ)
)
;<<<<<<<<>>>>>>>>>><<<<<<<<<<<<<>>>>>>>>>>>>>>><<<<<<<<<<<<<<<>>>>>>>>>>>>><<<<<<<<<<>>>>><><><><><><><><><><
писалось очень давно - но строит по моему к чему угодно, кроме блоков ест-но, из указанной точки

Был небольшой "косячок", если функция отменялась ESC сразу после запкска. Исправил:

(defun c:per(/ oldEcho oldOsm uPnt sSet oldOrt
        sCurve Dr Ang1 Ang2 pt1 pt2 *error*
         actDoc actLay actSp oldSt xl1 xl2)
  (vl-load-com)
  (defun *error* (msg)
    (setvar "ORTHOMODE" oldOrt)
    (command "_.ucs" "_p")
    (command "_.ucs" "_p")
    (setvar "CMDECHO" oldEcho)
    (setvar "OSMODE" oldOsm)
    (if(and xl1 xl2)
      (progn
      (vla-put-Lock actLay :vlax-false)
      (vla-delete xl1)(vla-delete xl2)
      (vla-put-Lock actLay oldSt)
      ); end progn
      ); end if
    (vla-EndUndoMark actDoc)
    (princ)
    ); end of *error*
  (setq oldEcho(getvar "CMDECHO")
        oldOsm(getvar "OSMODE")
        oldOrt(getvar "ORTHOMODE")
   ); end setq
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 819)
  (command "_.ucs" "_w")
  (setq actDoc(vla-get-ActiveDocument
            (vlax-get-acad-object))
    actLay(vla-get-ActiveLayer actDoc)
    oldSt(vla-get-Lock actLay)
    ); end setq
(vla-StartUndoMark actDoc)
  (if
    (and
    (setq uPnt(getpoint "\nSelect point at line or curve -> "))
    (setq sSet(ssget uPnt '((0 . "*LINE,ARC,ELLIPSE,CIRCLE,RAY,XLINE")
               (-4 . "<NOT")(0 . "MLINE")(-4 . "NOT>"))))
    (setq sCurve(vlax-ename->vla-object(ssname sSet 0)))
    (setq Dr(vlax-curve-getFirstDeriv sCurve
      (vlax-curve-getParamAtPoint sCurve uPnt)))
     ); end and
    (progn
      (if(=(cadr dr) 0.0)
    (setq Ang1 0.0)
    (setq Ang1(- pi(atan(/(car dr)(cadr dr)))))
    ); end if
      (setq Ang2(- Ang1(/ pi 2))
        pt1 (polar uPnt Ang1 1.0)
        pt2 (polar uPnt Ang2 1.0)
        ); end setq
      (if(= 1(vla-get-ActiveSpace actDoc))
    (setq actSp(vla-get-ModelSpace actDoc))
    (setq actSp(vla-get-PaperSpace actDoc))
    ); end if
      (vla-put-Lock actLay :vlax-false)
      (setq xl1(vla-AddXline actSp
         (vlax-3D-point uPnt)
         (vlax-3D-point pt1))
        xl2(vla-AddXline actSp
         (vlax-3D-point uPnt)
         (vlax-3D-point pt2))
        ); end setq
      (vla-put-color xl1 130)
      (vla-put-color xl2 51)
      (vla-Highlight xl1 :vlax-true)
      (vla-Highlight xl2 :vlax-true)
      (command "_.ucs" "_3" uPnt pt1 pt2)
      (setvar "ORTHOMODE" 1)
      (princ "\nSpecify length: ")
      (setvar "OSMODE" 2080)
      (command "_.line" (trans uPnt 0 1) pause "")
      (vla-delete xl1)(vla-delete xl2)
      (vla-put-Lock actLay oldSt)
      (command "_.ucs" "_p")
      (command "_.ucs" "_p")
      (setvar "ORTHOMODE" oldOrt)
      ); end progn
    ); end if
  (setvar "CMDECHO" oldEcho)
  (setvar "OSMODE" oldOsm)
  (vla-EndUndoMark actDoc)
  (princ)
  ); end of c:per

> Антимозг
http://dwg.ru/forum/viewtopic.php?t=11445

> guest
Вот эту > {Smirnoff} (2005-12-17 12:54:58) тоже запускал под 2006 RUS с установленной пользовательской ПСК. Все работает. Я бы только добавил установку UCSFOLLOW - в 0.