[编程交流] 沿柱脚对齐块

;;;WIZMAN 01DEC08
(vl-load-com)
(defun c:balign        (/ bal_blk bal_blk_ent bal_dist bal_ent bal_ent_sp bal_tot_dist)
   (if
(and
    (not
        (while
            (not
                (and
                    (or
                        (setq
                            bal_ent (entsel "\n>>>...Pick Polyline, Line or Spline...<<<")
                        ) ;_ end_setq
                        (princ "\n>>>...Missed, Try again...<<<")
                    ) ;_ end_or
                    (if        bal_ent
                        (or
                            (member (cdr (assoc 0 (entget (car bal_ent))))
                                    '("LWPOLYLINE" "SPLINE" "LINE")
                            ) ;_ end_member
                            (not
                                (princ "\n>>>...Object is not a Line, Polyline, Spline...<<<"
                                ) ;_ end_princ
                            ) ;_ end_not
                        ) ;_ end_or
                    ) ;_ end_if
                ) ;_ end_and
            ) ;_ end_not
        ) ;_ end_while
    ) ;_ end_not
    (not
        (while
            (not
                (and
                    (or
                        (setq bal_blk_ent (entsel "\n>>>...Pick Block...<<<"))
                        (princ "\n>>>...Missed, Try again...<<<")
                    ) ;_ end_or
                    (if        bal_blk_ent
                        (or
                            (member (cdr (assoc 0 (entget (car bal_blk_ent))))
                                    '("INSERT")
                            ) ;_ end_member
                            (not
                                (princ "\n>>>...Object is not a Block...<<<"
                                ) ;_ end_princ
                            ) ;_ end_not
                        ) ;_ end_or
                    ) ;_ end_if
                ) ;_ end_and
            ) ;_ end_not
        ) ;_ end_while
    ) ;_ end_not
    (setq bal_blk (cdr (assoc 2 (entget (car bal_blk_ent)))))
) ;_ end_and
   (progn
       (setq bal_ent_sp (vlax-curve-getstartpoint (car bal_ent)))
       (setq bal_tot_dist '(+))
       (while (setq bal_dist (getreal "\n>>>...Enter Distance...>>>: "))
           (if (<= (eval (setq bal_tot_dist (append bal_tot_dist (list bal_dist))))
                   (vlax-curve-getdistatparam
                       (car bal_ent)
                       (vlax-curve-getendparam (car bal_ent))
                   ) ;_ end_vlax-curve-getdistatparam
               ) ;_ end_<=
               (entmake
                   (list (cons 0 "INSERT")
                         (cons 2 bal_blk)
                         (cons 10
                               (vlax-curve-getpointatdist
                                   (car bal_ent)
                                   (eval bal_tot_dist)
                               ) ;_ end_vlax-curve-getpointatdist
                         ) ;_ end_cons
                         (cons 41 1)
                         (cons 42 1)
                         (cons 43 1)
                         (cons 50
                               (angle '(0 0)
                                      (vlax-curve-getFirstDeriv
                                          (car bal_ent)
                                          (vlax-curve-getParamAtPoint
                                              (car bal_ent)
                                              (vlax-curve-getpointatdist
                                                  (car bal_ent)
                                                  (eval bal_tot_dist)
                                              ) ;_ end_vlax-curve-getpointatdist
                                          ) ;_ end_vlax-curve-getParamAtPoint
                                      ) ;_ end_vlax-curve-getFirstDeriv
                               ) ;_ end_angle
                         ) ;_ end_cons
                   ) ;_ end_list
               ) ;_ end_entmake
               (progn (princ "\n>>>...Distance exceeds Length of Polyline...<<<\n") (exit))
           ) ;_ end_if
       ) ;_ end_while
   ) ;_ end_progn
   ) ;_ end_if
   (princ)
) ;_ end_defun
(prompt "\n>>>...Balign.lsp is now loaded, Type 'Balign' to run command...<<<")
(princ)