(defun c:ufc00003 ( / eps epe ss1 nn1 ente1 enls1 pk1 pk2
                      ss2 nn2 pdi pp1 pp2 nc ente enls fin
                      fg1 fg2 fg3 xx yy ll1 ll2 ) 
;複数線分トリム＆延長
;最初に選択された線分及びトリム側指定にて次以降に選択された線分をトリム及び延長する
  (setq eps 0.001)
  (setq epe 0.0000001)
  (prompt "\nそろえるための基準になる線分を選択（１線分）：")
  (setq ss1 (ssget '((0 . "LINE")) )) ;線分を選択
  (setq nn1 0)
  (if (/= ss1 nil)
    (progn
      (setq nn1 (sslength ss1))
      (setq ente1 (ssname ss1 0))
      (setq enls1 (entget ente1)) 
      (setq pk1 (cdr (assoc 10 enls1)))
      (setq pk2 (cdr (assoc 11 enls1)))
    )
  )
  (if (/= nn1 1)
    (prompt "\n最初の選択はひとつの線分を選択して下さい。")
    (progn
      (prompt "\nそろえたい線分を選択（複数線分可）：")
      (setq ss2 (ssget '((0 . "LINE")) )) ;線分を選択
      (setq nn2 0)
      (if (/= ss2 nil)
        (setq nn2 (sslength ss2))
      )
      (setq pdi (getpoint "\nトリムする側を指示:"))
      (if (/= pdi nil)
        (progn
          (setq pp1 (list 0.0 0.0 0.0))
          (setq pp2 (list 0.0 0.0 0.0))
          (command "pan" "none" pp1 "none" pp2 ) 'undo１回分戻るためのダミーコマンド
          (setq nc 0)
          (repeat nn2
            (setq ente (ssname ss2 nc))
            (setq nc (+ nc 1))
            (if (and (/= ente nil) (/= ente ente1))
              (progn
                (setq enls (entget ente))
                (if (/= enls nil)
                  (progn
                    (setq pp1 (cdr (assoc 10 enls)))
                    (setq pp2 (cdr (assoc 11 enls)))
                    (setq fin (ufb00004 pk1 pk2 pp1 pp2 eps epe))
                    (if (= fin nil)
                      (prompt "\n交点が見つかりません。")
                      (progn
                        (setq fg1 (ufb00009 pk1 pk2 pdi eps epe))
                        (if (or (= fg1 0) (= fg1 nil))
                          (prompt "\nトリムする側が決定できません。")
                          (progn
                            (setq fg2 (ufb00009 pk1 pk2 pp1 eps epe))
                            (setq fg3 (ufb00009 pk1 pk2 pp2 eps epe))
                            (if (and (/= fg2 nil) (/= fg3 nil))
                              (progn
                                (cond
                                  ((and (= fg1 fg2) (= fg1 fg3))
                                    (entdel ente)
                                  )
                                  ((and (= fg1 fg2) (/= fg1 fg3))
                                    (if (= fg3 0)
                                      (entdel ente)
                                      (progn
                                        (setq enls
                                          (subst (cons 10 fin)
                                            (assoc 10 enls)
                                            enls
                                          )
                                        )
                                        (entmod enls)
                                      )
                                    )
                                  )
                                  ((and (/= fg1 fg2) (= fg1 fg3))
                                    (if (= fg2 0)
                                      (entdel ente)
                                      (progn
                                        (setq enls
                                          (subst (cons 11 fin)
                                            (assoc 11 enls)
                                            enls
                                          )
                                        )
                                        (entmod enls)
                                      )
                                    )
                                  )
                                  ((and (/= fg1 fg2) (/= fg1 fg3))
                                    (setq xx (- (car  pp1) (car  fin)))
                                    (setq yy (- (cadr pp1) (cadr fin)))
                                    (setq ll1 (sqrt (+ (* xx xx) (* yy yy))))
                                    (setq xx (- (car  pp2) (car  fin)))
                                    (setq yy (- (cadr pp2) (cadr fin)))
                                    (setq ll2 (sqrt (+ (* xx xx) (* yy yy))))
                                    (if (< ll1 ll2)
                                      (progn
                                        (setq enls
                                          (subst (cons 10 fin)
                                            (assoc 10 enls)
                                            enls
                                          )
                                        )
                                        (entmod enls)
                                      )
                                      (progn
                                        (setq enls
                                          (subst (cons 11 fin)
                                            (assoc 11 enls)
                                            enls
                                          )
                                        )
                                        (entmod enls)
                                      )
                                    )
                                  )
                                )
                              )
                            )
                          )
                        )
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
  (princ)
)
(defun ufb00001 ( u_p1  ;線分の始点
                  u_p2  ;線分の終点
                  u_eps ;許容誤差
                / vv    ;単位ベクトル（２次元）　Ｚ成分は０．０
                        ; nil:単位ベクトルが算出できないとき
                        ;     始点と終点が同一点（Ｚ＝０平面）
                  xx yy ll vx vy zv )
;単位ベクトルを求める（２次元）
  (setq vv nil)
  (setq xx (- (car  u_p2) (car  u_p1)))
  (setq yy (- (cadr u_p2) (cadr u_p1)))
  (setq ll (sqrt (+ (* xx xx) (* yy yy))))
  (if (> ll u_eps)
    (progn
      (setq vx (/ (- (car  u_p2) (car  u_p1)) ll))
      (setq vy (/ (- (cadr u_p2) (cadr u_p1)) ll))
      (setq vz 0.0)
      (setq vv (list vx vy vz))
    )
  )
  vv
)
(defun ufb00003 ( u_p1  ;線分の始点
                  u_p2  ;線分の終点
                  u_eps ;許容誤差
                / abc   ;直線の方程式　(car abc)*x+(cadr abc)*y=c
                        ; nil:方程式が求まらない
                        ;     始点と終点が同一点
                  xx yy ll aa bb cc )
;直線の方程式を求める
  (setq abc nil)
  (setq xx (- (car  u_p2) (car  u_p1)))
  (setq yy (- (cadr u_p2) (cadr u_p1)))
  (setq ll (sqrt (+ (* xx xx) (* yy yy))))
  (if (> ll u_eps)
    (progn
      (setq aa (/ (- (cadr u_p1) (cadr u_p2)) ll))
      (setq bb (/ (- (car  u_p2) (car  u_p1)) ll))
      (setq cc (/ (- (* (- (car  u_p2) (car  u_p1)) (cadr u_p1))
                     (* (- (cadr u_p2) (cadr u_p1)) (car  u_p1))) ll))
      (setq abc (list aa bb cc))
    )
  ) 
  abc
)
(defun ufb00004 ( u_p1  ;線分１の始点
                  u_p2  ;線分１の終点
                  u_p3  ;線分２の始点
                  u_p4  ;線分２の終点
                  u_eps ;許容誤差
                  u_epe ;許容誤差（規格化用）
                / pc    ;交点
                        ; nil:交点が求まらない
                        ;     始点と終点が同一点
                  abc1 abc2 a1 b1 c1 a2 b2 dd c2 xc yc )
;無限線分と無限線分の交点を求める
  (setq pc nil)
  (setq abc1 (ufb00003 u_p1 u_p2 u_eps))
  (setq abc2 (ufb00003 u_p3 u_p4 u_eps))
  (if (and (/= abc1 nil) (/= abc2 nil))
    (progn
      (setq a1 (car   abc1))
      (setq b1 (cadr  abc1))
      (setq c1 (caddr abc1))
      (setq a2 (car   abc2))
      (setq b2 (cadr  abc2))
      (setq c2 (caddr abc2))
      (setq dd (- (* a1 b2) (* b1 a2)))
      (if (> (abs dd) u_epe)
        (progn
          (setq xc (/ (- (* b2 c1) (* b1 c2)) dd))
          (setq yc (/ (- (* a1 c2) (* a2 c1)) dd))
          (setq pc (list xc yc 0.0))
        )
      )
    )
  ) 
  pc
)
(defun ufb00009 ( u_p1  ;線分の始点
                  u_p2  ;線分の終点
                  u_pc  ;左右どちらにあるか判定する点
                  u_eps ;許容誤差
                  u_epe ;許容誤差（規格化用）
                / fout  ;0:延長を含める線分上、1:右側、2:左側
                        ; nil:判定ができない
                  vv ww vx vy wx wy ss )
;指定点が線分の左右どちらにあるか判定する
  (setq fout nil)
  (setq vv (ufb00001 u_p1 u_p2 u_eps))
  (setq ww (ufb00001 u_p1 u_pc u_eps))
  (if (and (/= vv nil) (/= ww nil))
    (progn
      (setq vx (car  vv))
      (setq vy (cadr vv))
      (setq wx (car  ww))
      (setq wy (cadr ww))
      (setq ss (- (* vx wy) (* vy wx)))
      (setq fout 1)
      (if (> ss 0.0)
        (setq fout 2)
      )
      (if (< (abs ss) u_epe)
        (setq fout 0)
      )
    )
  ) 
  fout
)