LISP ARTBD - bonuscad

(vl-load-com)

(defun c:ARTDB ( / js n AcDoc Space ename obj pr nb typ_obj oldim oldlay a_base a_dir

 pt_start pt_end pt_cen rad alpha pt_vtx dist_start dist_end seg_len seg_bulge)

  (defun grdraw-id_arc ( / oldcolor)

    (setq oldcolor (getvar "CECOLOR"))

    (setvar "CECOLOR" "3")

    (command "_.line" "_none" (trans pt_start 0 1) "_none" (trans pt_vtx 0 1) "")

    (command "_.line" "_none" (trans pt_vtx 0 1) "_none" (trans pt_end 0 1) "")

    (setvar "CECOLOR" "5")

    (command "_.line" "_none" (trans pt_start 0 1) "_none" (trans pt_cen 0 1) "")

    (command "_.line" "_none" (trans pt_cen 0 1) "_none" (trans pt_end 0 1) "")

    (setvar "CECOLOR" "2")

    (command "_.line" "_none" (trans (polar pt_cen (angle pt_cen pt_vtx) (abs rad)) 0 1) "_none" (trans pt_vtx 0 1) "")

    (setvar "CECOLOR" oldcolor)

  )

  (defun add_mt_arc ( / ins_txt h_t)

    (initget 9)

    (setq ins_txt (getpoint (trans pt_cen 0 1) "\nPoint d'insertion des informations de l'arc?: "))

    (initget 6)

    (setq h_t (getdist ins_txt (strcat "\nTaille du texte <" (rtos (getvar "textsize")) ">: ")))

    (if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t))

    (vla-addMtext Space

      (vlax-3d-point (trans ins_txt 1 0))

      0.0

      (strcat

        "{\\fArial Narrow|b0|i0|c0|p34;"

        "A = " (angtos (- pi (* 2 alpha)) (getvar "LUNITS") 4)

        "\\PR = " (rtos rad 2 3)

        "\\PT = " (rtos (distance pt_start pt_vtx) 2 3)

        "\\PD = " (rtos seg_len 2 3)

        "\\PB = " (rtos (- (distance pt_cen pt_vtx) (abs rad)) 2 3)

        "}"

      )

    )

    (entmod

      (append

      (vl-remove-if

        (function

          (lambda (x)

            (or (member (car x) '(90 63 421 45))

              (< 419 (car x) 440)

            )

          )

        )

        (entget (entlast))

      )

      (list

        '(90 . 1)

        '(63 . 41)

        '(421 . 16770196)

        '(45 . 1.5)

      )

      )

    )

    (entupd (entlast))

  )

  (princ "\nSélectionner des Arcs/PolyArcs .")

  (setq

    js

    (ssget

      '((-4 . "")

        (-4 . "AND>")

        (0 . "LWPOLYLINE,ARC")

        (-4 . "OR>"))

    )

    n -1

  )

  (cond

    (js

      (setq

        AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))

        Space

          (if (= 1 (getvar "CVPORT"))

            (vla-get-PaperSpace AcDoc)

            (vla-get-ModelSpace AcDoc)

          )

        nb 0

      )

      (cond

        ((null (tblsearch "LAYER" "Info ARTDB des Arcs"))

          (vlax-put (vla-add (vla-get-layers AcDoc) "Info ARTDB des Arcs") 'Color "5")

        )

      )

      (setq

        oldim (getvar "dimzin")

        oldlay (getvar "clayer")

        a_base (getvar "ANGBASE")

        a_dir (getvar "ANGDIR")

      )

      (setvar "dimzin" 0) (setvar "clayer" "Info ARTDB des Arcs")

      (setvar "ANGBASE" 0) (setvar "ANGDIR" 0)

      (repeat (sslength js)

        (setq

          ename (ssname js (setq n (1+ n)))

          obj (vlax-ename->vla-object ename)

          pr -1

          nb 0

        )

        (setq typ_obj (vla-get-ObjectName obj))

        (if (eq typ_obj "AcDbArc")

          (progn

            (setq

              pt_start (vlax-get obj 'StartPoint)

              pt_end (vlax-get obj 'EndPoint)

              pt_cen (vlax-get obj 'Center)

              rad (vlax-get obj 'Radius)

              alpha (* (vlax-get obj 'TotalAngle) 0.5)

              seg_len (vlax-get obj 'ArcLength)

              pt_vtx (polar pt_cen (+ (vlax-get obj 'StartAngle) alpha) (+ rad (* rad (1- (/ 1 (cos alpha))))))

              nb (1+ nb)

            )

            (grdraw-id_arc)

            (add_mt_arc)

          )

          (repeat (fix (vlax-curve-getEndParam obj))

            (setq

              dist_start (vlax-curve-GetDistAtParam obj (setq pr (1+ pr)))

              dist_end (vlax-curve-GetDistAtParam obj (1+ pr))

              pt_start   (vlax-curve-GetPointAtParam obj pr)

              pt_end (vlax-curve-GetPointAtParam obj (1+ pr))

              seg_len (- dist_end dist_start)

              seg_bulge (vla-GetBulge obj pr)

            )

            (if (not (zerop seg_bulge))

              (progn

                (setq

                  rad (/ seg_len (* 4.0 (atan seg_bulge)))

                  alpha (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge))))

                  pt_cen (polar pt_start alpha rad)

                  pt_vtx (polar pt_start (- alpha (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))

                  alpha (if (< (* 2.0 (atan seg_bulge)) 0) (- pi (* 2.0 (atan seg_bulge))) (* 2.0 (atan seg_bulge)))

                  nb (1+ nb)

                )

                (grdraw-id_arc)

                (add_mt_arc)

              )

            )

          )

        )

      )

      (setvar "dimzin" oldim) (setvar "clayer" oldlay)

      (setvar "ANGBASE" a_base) (setvar "ANGDIR" a_dir)

    )

  )

  (prin1)

)

 </or")>