[编程交流] 将块放置在u线的起点

;draw chainages
;by Dave Corrall   12-Nov-2001
;degrees>radians
(defun dtr (a)
 (* pi (/ a 180.0))
 )
;radians>degrees
(defun rtd (a)
 (* 180.0(/ a pi))
 )
(defun intro ()
 (setq dialog-state 999)
 (setq dialog_pos (list -1 -1))
 (setq dcl_id (load_dialog "intro.dcl"))
 (princ "\nDialog Box:")
 (while (< 2 dialog-state)
   (new_dialog "intro" dcl_id "" dialog_pos)
   (set_tile "lname" "Chainages on Polyline")
   (setq x (dimx_tile "DC")
  y (dimy_tile "DC"))
   (fill_image 0 0 x y -15)
   (start_image "DC")
   (slide_image 0 0 x y "dc_logo")
   (end_image)
   (action_tile "accept" "(done_dialog 1)")
   (action_tile "cancel" "(quit_routine)")
   (action_tile "about" "(setq userclick1 t)(open_about)")
   (setq dialog-state (start_dialog))
   (if (= dialog-state 1)
     (princ)
;      (princ "\nDialog Box: ")
     )
   )
 (unload_dialog dcl_id)
;  (princ "\nDialog Box: ")
)
; tell about routine
(defun open_about ()
;  (done_dialog)
 (startapp "notepad.exe" "chains.txt")
;  (setq userclick1 nil)
 )
(defun quit_routine ()
 (setq qr "Q")
 )
(defun chainage ()
 (setq oreq(getvar"attreq")odia(getvar"attdia"))
 (setq oldlayer(getvar "clayer"))
 (setvar "attreq" 1)
 (setvar "attdia" 0)
 (setvar "osmode" 1024)
 (command "ucs" "")
 (setq r 0.0)
 (setq seg 0.0)
 (if (= (tblsearch "LAYER" "CCC_LAYOUT_Chainages") nil)
     (command "layer" "m" "CCC_LAYOUT_Chainages" "c" "7" "" "")
     (command "layer" "s" "CCC_LAYOUT_Chainages" "")
   )
 (setq step(getreal "\nSet interval to display Chainage text: ")
svprefix "Ch"
svsuffix "m"
scale "1"
svval 0)
 (setq nam (car (entsel "\nSelect Polyline: ")))
(command "_change" nam ""  "p" "Layer" "CCC_LAYOUT_Chainages" "color" "Bylayer" "")
 (setq ent (entget nam))
(command "_.insert" "Chainage_Tick" nil)
(command "measure" nam "b" "Chainage_Tick" "y" "10" "")
 (if (not (equal (cdr (assoc 0 ent)) "LWPOLYLINE"))
     (prompt "\nEntity not a polyline...")
     (progn
(setq nv (cdr(assoc 90 ent)))
(setq ent1 (member(assoc 10 ent)ent))
  (setq ent2(cdr ent1))
  (setq ent2(member(assoc 10 ent2)ent2))
(while (/= ent2 nil)
  (if (/= ent2 nil)
                  (progn
;  IF THE VERTEX PRECEDES A STRAIGHT LINE
                     (if (equal (cdr (assoc 42 ent1)) 0.0)
                     (progn
                        (setq v1(cdr(assoc 10 ent1))
                       v2(cdr(assoc 10 ent2))
                       a(angle v1 v2)
                       d(distance v1 v2)
                       p1(polar v1 a (- step r))
                       d1(distance p1 v2)
                       )
                (if(< seg 1)
                  (progn
                (setq value(strcat svprefix (rtos svval 2 0) svsuffix ))
                (command "-insert" "Chainage_Text" v1 scale scale (rtd a) value)
                )
                  )
                (if(<(+ d r) step)
                  (progn
                    (setq r (+ d r))
                    )
                  (progn
                    (setq num(1+(fix(/ d1 step))))
                    (setq cnt 0)
                    (repeat num
                      (progn
                        (setq pt(polar p1 a (* cnt step)))
                        (setq svval(+ svval step)
                              value(strcat svprefix (rtos svval 2 0) svsuffix ))
                        (command "-insert" "Chainage_Text" pt scale scale (rtd a) value)
                        (setq cnt (1+ cnt))
                        )
                      )
                    (setq r(rem d1 step))
                    )
                  )
; set new values for variables                        
                (setq ent1 ent2)
                (setq ent2(cdr ent2))
                (setq ent2(member(assoc 10 ent2)ent2))
                (setq seg(1+ seg))
                );end progn for straight section
;if the vertex preceds an arc
                (progn
                  (setq v1(cdr(assoc 10 ent1))
                        v2(cdr(assoc 10 ent2))
                        bulge(cdr(assoc 42 ent1))
                        )
                  (setq a(angle v1 v2)
                        d(distance v1 v2)
                        radi(abs(/ d(* 2.0(sin(*(atan bulge) 2)))))
                        )
                  (setq hfd(/ d 2.0)
                        thet(atan(/(sqrt(-(* radi radi)(* hfd hfd)))hfd))
                        )
                  (if (< (abs bulge) 1)         ; if > 180 deg
                               (if (< bulge 0)             ; if clockwise
                                 (setq dtoc (- a thet))
                                 (setq dtoc (+ a thet))
                               )
                              (if (< bulge 0)
                                (setq dtoc (+ a thet))
                                (setq dtoc (- a thet))
                              )
                         )
                            (setq p1 v1)
                            (setq p2 v2)
                            (setq pc (polar p1 dtoc radi))
                            (setq beg (angle pc p1))
                            (setq end (angle pc p2))
; CALCULATE LENGTH OF ARC
                            (setq swept (abs (- beg end) ))
                            (setq len (abs (* (- beg end) radi)))
                            (if (and (< (abs bulge) 1) (> swept pi ))
                                (setq len (- (* 2 pi radi) len))
                            )
                         (if (< (+ len r) step)
                         (progn
                             (setq r (+ len r))
                         )
                         (progn
                            (if (and (> (abs bulge) 1) (< swept pi ))
                                (setq len (- (* 2 pi radi) len))
                            )
                            (setq beta (- step r))
                            (setq len1 (- len beta))
                            (if (> bulge 0)
                                (setq beg (+ beg (/ beta radi) ) )
                                (setq beg (- beg (/ beta radi) ) )
                            )
                            (setq num (1+ (fix (/ len1 step))))
                            (setq astep (/ step radi ))
                            (setq cnt 0)
                            (repeat num
                              (progn
                                 (if (> bulge 0)
                                    (setq ai (+ beg (* cnt astep))
                                   ab(+ ai (dtr 90)))
                                    (setq ai (- beg (* cnt astep))
                                   ab(- ai (dtr 90)))
                                 )
                                 (setq pt (polar pc ai radi))
                        (setq svval(+ svval step)
                              value(strcat svprefix (rtos svval 2 0) svsuffix ))                                 
                        (command "-insert" "Chainage_Text" pt scale scale (rtd ab) value)
                        (setq cnt (1+ cnt))
                         )
                       )
                    (setq r(rem len1 step))
                    (if(equal r 0.0)(setq r step))
                    )
                    )
; set new values for variables                        
                (setq ent1 ent2)
                (setq ent2(cdr ent2))
                (setq ent2(member(assoc 10 ent2)ent2))
                );end progn for arc section                          
                );end if check straight or arc
             );end progn
    );end if /= ent2 nil
  );end while /= ent2 nil
)
   )
 ;reset variables
 (setvar "attreq" oreq)
 (setvar "attdia" odia)
 (command "layer" "s" oldlayer "")
 (command "ucs" "p")
 )
(defun thanku()
 (setq dialog-state 999)
 (setq dialog_pos (list -1 -1))
 (setq dcl_id (load_dialog "thanks.dcl"))
 (while (< 2 dialog-state)
   (new_dialog "thanks" dcl_id "" dialog_pos)
   (set_tile "lname" "Chainage Routine")
   (setq x (dimx_tile "DC")
  y (dimy_tile "DC"))
   (fill_image 0 0 x y -15)
   (start_image "DC")
   (slide_image 10 10 x y "dc_logo")
   (end_image)
   (setq dialog-state (start_dialog))
   (if (= dialog-state 1)
     (princ)
     )
   )
 (unload_dialog dcl_id)
 (princ)
 )
;command routine
(defun c:chains ()
 (intro)
 (if(= qr "Q")
   (progn
     (setq qr nil)
     (thanku)
     )
   (progn
     (chainage)
     (thanku)
     )
   )
 )
;PI's on pipelines no radiused bends
(defun c:bends ()
 (if (= (tblsearch "LAYER" "Bend_numbers") nil)
     (command "layer" "m" "Bend_numbers" "c" "1" "" "")
     (command "layer" "s" "Bend_numbers" "")
   )
 (setq bend 1.0)
 (setq nam (car (entsel "\nSelect Polyline: ")))
 (setq ent (entget nam))
 (if (not (equal (cdr (assoc 0 ent)) "LWPOLYLINE"))
     (prompt "\nEntity not a polyline...")
     (progn
(setq nv (cdr(assoc 90 ent)))
(setq ent1 (member(assoc 10 ent)ent))
  (setq ent2(cdr ent1))
  (setq ent2(member(assoc 10 ent2)ent2))
(while (/= ent2 nil)
                   (setq v1(cdr(assoc 10 ent1))
                  v2(cdr(assoc 10 ent2))
                  a(angle v1 v2)
                  )
            (command "text" "c" (polar v1 (+ (dtr 90) a) (* scale 1.25)) (* scale 3.5) (rtd a) (rtos bend 2 0))
  (setq bend(1+ bend))
  (setq ent1 ent2)
  (setq ent2(cdr ent2))
  (setq ent2(member(assoc 10 ent2)ent2))
  )
)
   )
 )