Отмерить по линии расстояние и поставить точку (Страница 3 из 4)

;; written by Fatty T.O.H. () 2004 * all rights removed 

;; edited 6/5/10
;; edited 6/10/11
;; edited 6/11/11
;; edited 6/10/12

;; Пикеты

;;load ActiveX library
(vl-load-com)

;;local defuns


;;//
(defun start (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getstartpoint curve
    )
  )
)
    )
  )
  )
;;//
(defun end (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getendpoint curve
    )
  )
)
    )
  )
  )
;;//
(defun pointoncurve (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  pt
    )
  )
)
    )
  )
;;//
(defun paramatpoint (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getparamatpoint curve
  pt
    )
  )
)
    )
  )
;;//
(defun distatpt (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatpoint curve
    (vlax-curve-getclosestpointto curve pt)
    )
  )
                )
    )
  )
;;//
(defun pointatdist (curve dist)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getpointatdist curve dist)
    )
  )
)
    )
  )
;;//
(defun curvelength (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatparam curve
  (- (vlax-curve-getendparam curve)
     (vlax-curve-getstartparam curve)
    )
  )
  )
)
    )
  )
;;//
(defun distatparam (curve param)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatparam curve
  param
  )
  )
                )
    )
  )
;;//
(defun statlabel  (num step div)
  ;; num - integer, zero based
  ;; step - double or integer, must be non zero
  
  (strcat
    (itoa (fix (/ num div)))
    "+"
    (if (zerop (rem num div))
      "00"
      (rtos (* (rem num div) step) 2 0))

    )
  )



;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
  
     (setq param (paramatpoint curve pt)
           ang ((lambda (deriv)
           (if (zerop (cadr deriv))
             (/ pi 2)
             (atan (apply '/ deriv))
           )
         )
          (cdr (reverse
             (vlax-curve-getfirstderiv curve param)
               )
          )
        )
)
  ang
  )

;;---------------------- main program -----------------------------;;

(defun c:DPK (/ *error* acsp adoc block cnt div en ent label
           lastp lay leng lnum mul num pt rot sign start step txh txt)
  
  (defun *error* (msg)
         
     (vla-endundomark
       (vla-get-activedocument (vlax-get-acad-object))
       )
    (cond ((not msg))
      ((vl-position
         msg
         '("Function cancelled" "quit / exit abort" "console break")
       )
      )
      ((princ (strcat "\nDist2P Command Error: " msg)))
    )
    (if    clay
      (setvar "celayer" clay)
    )
    (if    dimz
      (setvar "dimzin" dimz)
    )
  
    (princ)
  )
  
  (setvar "dimzin" 2)
  (setq lay (getvar "clayer"))
  (setvar "clayer" "0")
  
  (setq adoc    (vla-get-activedocument (vlax-get-acad-object))
       acsp    (vla-get-block (vla-get-activelayout adoc))
     )
  

 (while    (not
      (and
        (or
          (initget 6)
          (setq step (getreal "\nВведите шаг <25>: "))
          (if (not step)
        (setq step 25.)))
        (zerop (rem 100 step))))
   (alert (strcat "\nОстаток от деления 100 на шаг / " (rtos step 2 2) " не равен нулю,
          \nВведен некорректный шаг"))
   )
   (initget  "Yes No ")
   (setq ans (getkword "\nВставить префикс? (Y/N) <Y>:"))
   (setq pref  (if (not ans )(lisped   "ПК") ""))
   (setq txh (cond
          ((getdist (strcat "\nВведите высоту текста  [ Enter для подтверждения ]: <" (rtos  (getvar "dimtxt") 2 1) ">: ")))
          (txh)
          ))
(if

  (setq
    ent    (entsel
      "\nУказать кривую ближе к её началу >>"
      )
    )

   (progn
     

     (setq en    (car ent)
       pt    (pointoncurve en (cadr ent))
       leng    (distatparam en (vlax-curve-getendparam en))
       )

     (setq num (fix (/ leng step))
       )

     (setq div (fix (/ 100. step)
            )
       )

     (setq mul (- leng
          (* (setq lnum (fix (/ leng (* step div)))) (* step div))))

     (if (not (zerop mul))
       (setq lastp T)
       (setq lastp nil)
       )

     (if (> (- (paramatpoint en pt)
           (paramatpoint en (vlax-curve-getstartpoint en))
           )
        (- (paramatpoint en (vlax-curve-getendpoint en))
           (paramatpoint en pt)
           )
        )
       (progn
     (setq start leng
           sign  -1
           )
     )
       (progn

     (setq start (distatparam en (vlax-curve-getstartparam en))
           sign  1
           )
     )
       )


     (vla-startundomark
       (vla-get-activedocument (vlax-get-acad-object))
       )
     (setq cnt 0)
     (repeat (1+ num)
       (setq pt     (pointatdist en start)
         rot (gettangent en pt)
         )
       (setq txt (vla-addtext  acsp (strcat pref (statlabel cnt step div)) (vlax-3d-point pt) txh))
       (vla-put-rotation txt (+ rot(/ pi 2)))

       (setq cnt   (1+ cnt)
         start (+ start (* sign step))
         )
       )


     (if lastp
       (progn

     (if (= sign -1)
       (progn
         (setq pt  (vlax-curve-getstartpoint en)
           rot (gettangent en pt)
           )
         )
       (progn
         (setq pt  (vlax-curve-getendpoint en)
           rot (gettangent en pt)
           )
         )
       )


     (setq label (strcat (itoa lnum) "+" (rtos mul 2 2))
           )
           (setq txt (vla-addtext  acsp  (strcat pref label) (vlax-3d-point pt) txh))
       (vla-put-rotation txt (+ rot(/ pi 2)))

     )
       )

     )
   (princ "\nНичего не выбрано")
   )
  (*error* nil)
  (princ)
)
(prompt "\n   ---   Команда на выполнение \"DPK\" или \"dpk\"  ---") 
(prin1) 
(or (vl-load-com) 
(princ) 
    )