[编程交流] 选择线条，然后进行合成

(defun c:tt( / )
        (defun tan ( x )
                (if (not (equal 0.0 (cos x) 1e-8))
                        (/ (sin x) (cos x))
                )
        )
        (defun Get-bulge-by3p ( pt1 pt2 pt3 )
                ((lambda ( a ) (/ (sin a) (cos a))) (/ (+ (- pi (angle pt2 pt1)) (angle pt2 pt3)) 2))
        )
        (defun Add-polyarc-by3p ( pt1 pt2 pt3 / ocs )
                (entmakex (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")'(090 . 2) '(070 . 0) (cons 010 pt1) (cons 042 (Get-bulge-by3p pt1 pt2 pt3))(cons 010 pt3)))
        )
        (defun LWVertices ( e )
                (if (setq e (member (assoc 10 e) e))
                        (cons
                                (list
                                        (assoc 10 e);vertex
                                        (assoc 42 e);bulge
                                )
                                (LWVertices (cdr e))
                        )
                )
        )
        ;-----------------Main Start----------------------
        (setq LinesTOJoin NIL)
        (while(and
                        (setq sel (entsel "\nSelect object at section to be use:"))
                        (setq ent (car sel));Select object
                        (setq bpt (cadr sel));Select point(Select sections that want to keep)
                        (setq pt1 (getpoint "Pick 1st break point:"))
                        (setq pt2 (getpoint "Pick 2nd break point:"))
                        (setq bpt (vlax-curve-getclosestpointto ent bpt))
                )
                (setq enx (vl-remove-if '(lambda ( x ) (member (car x) '(-1 5 6 8 39 48 62 102 330 370)))(entget ent));dxf
                        pt1 (vlax-curve-getclosestpointto ent pt1);break start point to curve
                        pt2 (vlax-curve-getclosestpointto ent pt2);break end point to curve
                        pa1 (vlax-curve-getparamatpoint ent pt1)
                        pa2 (vlax-curve-getparamatpoint ent pt2)
                        pab (vlax-curve-getparamatpoint ent bpt)
                )
                (if (< pa2 pa1) (mapcar 'set '(pt1 pt2 pa1 pa2) (list pt2 pt1 pa2 pa1)))
                (setq typ (cdr (assoc 0 enx)))
                (cond
                        ((= "ARC" typ)
                                (setq LinesTOJoin (cons (Add-polyarc-by3p pt1 bpt pt2)LinesTOJoin))
                        )
                        ((= "CIRCLE" typ)
                                (setq LinesTOJoin (cons (Add-polyarc-by3p  pt1 bpt pt2)LinesTOJoin))
                        )
                        ((= "LINE" typ)
                                (setq LinesTOJoin (cons (entmakex (list '(0 . "LINE") (cons 10 pt1) (cons 10 pt2)))LinesTOJoin))
                        )
                        ((= "LWPOLYLINE" typ)
                                (setq vtx (LWVertices enx))
                                (repeat (fix pa1) (setq vtx (cdr vtx)));delete the head
                                (if (not(equal pa1 (fix pa1) 1e-8))
                                        (setq bul (atan (cdr (assoc 42 (car vtx)))))
                                )
                                ;(princ "need help..............")
                        )
                )
        )
        (princ)
)

(defun c:tt( / )
        (vl-load-com)
        (defun tan ( x )
                (if (not (equal 0.0 (cos x) 1e-8))
                        (/ (sin x) (cos x))
                )
        )
        (defun Get-bulge-by3p ( pt1 pt2 pt3 )
                ((lambda ( a ) (/ (sin a) (cos a))) (/ (+ (- pi (angle pt2 pt1)) (angle pt2 pt3)) 2))
        )
        (defun LWVertices ( e )
                (if (setq e (member (assoc 10 e) e))
                        (cons
                                (list
                                        (assoc 10 e);vertex
                                        (assoc 42 e);bulge
                                )
                                (LWVertices (cdr e))
                        )
                )
        )
        ;-----------------Main Start----------------------
        (if(not(tblsearch "layer" "GuideLine"))
                (entmake(list(cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord")(cons 2 "GuideLine") (cons 62 8) (cons 70 0) (cons 6 "Continuous")))
        )
        (setq LinesTOJoin nil BVertices nil)
        (while(and
                        (setq sel (entsel "\nSelect object at section to be use:"))
                        (setq ent (car sel));Select object
                        (setq bpt (cadr sel));Select point(Select sections that want to keep)
                        (setq pt1 (getpoint "Pick 1st break point:"))
                        (setq pt2 (getpoint "Pick 2nd break point:"))
                        (setq bpt (vlax-curve-getclosestpointto ent bpt))
                )
                (setq enx (vl-remove-if '(lambda ( x ) (member (car x) '(-1 5 6 8 39 48 62 102 330 370)))(entget ent));dxf
                        pt1 (vlax-curve-getclosestpointto ent pt1);break start point to curve
                        pt2 (vlax-curve-getclosestpointto ent pt2);break end point to curve
                        pa1 (vlax-curve-getparamatpoint ent pt1)
                        pa2 (vlax-curve-getparamatpoint ent pt2)
                        pab (vlax-curve-getparamatpoint ent bpt)
                )
                (if (< pa2 pa1) (mapcar 'set '(pt1 pt2 pa1 pa2) (list pt2 pt1 pa2 pa1)))
                (setq typ (cdr (assoc 0 enx)))
                (cond
                        ((= "ARC" typ)
                                (setq tement(entmakex (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 "GuideLine")
                                        '(090 . 2) '(070 . 0) (cons 010 pt1) (cons 042 (Get-bulge-by3p pt1 bpt pt2))(cons 010 pt2))))
                                setq BVertices 
                        )
                        ((= "CIRCLE" typ)
                                (setq tement(entmakex (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 "GuideLine")
                                        '(090 . 2) '(070 . 0) (cons 010 pt1) (cons 042 (Get-bulge-by3p pt1 bpt pt2))(cons 010 pt2))))
                        )
                        ((= "LINE" typ)
                                (setq tement (entmakex (list '(000 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")(cons 8 "GuideLine")
                                        '(090 . 2) '(070 . 0) (cons 010 pt1)(cons 010 pt2))))
                        )
                        ((= "LWPOLYLINE" typ)
                                (setq vtx (LWVertices enx))
                                (setq vl1 nil);the head
                                (setq vl2 nil);the tail
                                (repeat (fix pa1)
                                        (setq vl1 (cons (car vtx) vl1)
                                                vtx (cdr vtx)
                                        )
                                )
                                (if (not (equal pa1 (fix pa1) 1e-8))
                                        (setq vx1 (car vtx)
                                                bul (atan (cdr (assoc 42 vx1)))
                                                vl1 (vl-list*
                                                                (list (cons 10 pt1) '(42 . 0.0))
                                                                (list (assoc 10 vx1) (cons  42 (tan (* (- pa1 (fix pa1)) bul))))
                                                                vl1
                                                        )
                                                vtx (cons
                                                                (list (cons  10 pt1) (cons  42 (tan (* (- (min pa2 (1+ (fix pa1))) pa1) bul))))
                                                                (cdr vtx)
                                                        )
                                        )
                                )
                                (setq vl1 (cons (car vtx) vl1))
                                (setq vtx (reverse vtx))
                                (repeat (+ (length vtx) (fix pa1) (- (fix pa2)) -1)
                                        (setq vl2 (cons (car vtx) vl2)
                                                vtx (cdr vtx)
                                        )
                                )
                                (if (not (equal pa2 (fix pa2) 1e-8))
                                        (setq vx1 (car vtx)
                                                bul (atan (cdr (assoc 42 vx1)))
                                                vl2 (cons
                                                                (list(cons  10 pt2) (cons  42 (tan (* (/ (- (1+ (fix pa2)) pa2) (if (< (fix pa2) pa1) (- pa2 pa1) 1.0)) bul))))
                                                                vl2
                                                        )
                                                vtx (vl-list*
                                                        (list (cons 10 pt2) '(42 . 0.0))
                                                        (list (assoc 10 vx1) (cons  42 (tan (* (if (< (fix pa2) pa1) 1.0 (- pa2 (fix pa2))) bul))))
                                                        (cdr vtx)
                                                )
                                        )
                                        (setq vl2 (cons (car vtx) vl2))
                                )
                                (if (<= pa1 pab pa2)
                                        (setq vtx(reverse vtx))
                                        (if (vlax-curve-isclosed ent)
                                                (setq vtx(append vl2 (reverse vl1)))
                                                (setq vtx(reverse vtx))
                                        )
                                )
                                (setq tement(entmakex (append
                                                                        (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")(cons 8 "GuideLine")(cons 90 (length vtx)))
                                                                        (apply 'append vtx)
                                                                )
                                                )
                                        )
                        )
                )
                (vla-put-color (vlax-ename->vla-object tement) 1)
                (vla-highlight (vlax-ename->vla-object tement) :VLAX-TRUE)
                (setq LinesTOJoin (cons tement LinesTOJoin))
        )
        (if (> (length LinesTOJoin) 0)
                (progn
                        (setq ss(ssadd))
                        (foreach n LinesTOJoin
                                (setq ss(ssadd n ss))
                        )
                        (COMMAND "PEDIT" "M" SS "" "J" "J" "E" "0.1" "")
                )
        )
        (princ)
)