[编程交流] 在中间距离画线

(defun c:test ( / activedocument ename1 ename2 iacadapplication modelspace mp1 mp2 object1 object2)
(setq IAcadApplication (vlax-get-acad-object)
      ActiveDocument (vla-get-ActiveDocument IAcadApplication)
      ModelSpace (vla-get-ModelSpace ActiveDocument)
      EName1 (car (entsel "\nSelect the first line: "))
      EName2 (car (entsel "\nSelect the Second line: "))
      object1 (vlax-ename->vla-object EName1)
      object2 (vlax-ename->vla-object EName2)
      mp  (lambda (p1 p2) (mapcar (function(lambda(a b)(/(+ a b 0.0) 2.0))) p1 p2))
      mp1 (mp (vlax-get object1 'StartPoint) (vlax-get object1 'EndPoint))
      mp2 (mp (vlax-get object2 'StartPoint) (vlax-get object2 'EndPoint))
)
(vla-AddLine ModelSpace (vlax-3d-point mp1) (vlax-3d-point mp2))
(princ)
)

(defun C:MLL (/             *error*           acsp          adoc         dlt1        dlt2   ep1
      ep2    flag   int1   int2          ip        line1         line2        nxp    ocirc
      p1     p2            rad           sp1          sp2         ss        tmp    x
      xline1
     )
 (if (< (atoi (substr (getvar "acadver") 1 2)) 15)
   (progn
     (alert
"Programm wiil be works in\n
AutoCAD 2000 and higher versions"
     )
     (exit)
     (princ)
   )
 )
 (or (vl-load-com))
;=====================================;
 (defun *error* (msg)
   (princ msg)
   (vla-endundomark
     (vla-get-activedocument
(vlax-get-acad-object)
     )
   )
   (princ)
 )
 (defun midpoint (p1 p2)
   (mapcar (function (lambda (a b)
                (* (+ a b) 0.5)
              )
    )
    p1
    p2
   )
 )
;=====================================;
 (defun group-by-num (lst num / ls ret)
   (if        (= (rem (length lst) num) 0)
     (progn
(setq ls nil)
(repeat        (/ (length lst) num)
  (repeat num
    (setq ls
              (cons (car lst) ls)
          lst (cdr lst)
    )
  )
  (setq        ret (append ret (list (reverse ls)))
        ls  nil
  )
)
     )
   )
   ret
 )
;=====================================;
 (or adoc
     (setq adoc (vla-get-activedocument
           (vlax-get-acad-object)
         )
     )
 )
 (or acsp
     (setq acsp (if (= (getvar "CVPORT") 1)
           (vla-get-paperspace
             adoc
           )
           (vla-get-modelspace
             adoc
           )
         )
     )
 )
 (vla-endundomark
   adoc
 )
 (vla-startundomark
   adoc
 )
 (setq ss (ssget (list (cons 0 "LINE"))))
 (if (/= (sslength ss) 2)
   (progn
     (alert "Must be selected 2 lines only")
     (exit)
     (princ)
   )
 )
 (setq        line1 (vlax-ename->vla-object (ssname ss 0))
line2 (vlax-ename->vla-object (ssname ss 1))
sp1   (vlax-get line1 'StartPoint)
ep1   (vlax-get line1 'EndPoint)
sp2   (vlax-get line2 'StartPoint)
ep2   (vlax-get line2 'EndPoint)
dlt1  (vlax-get line1 'Angle)
dlt2  (vlax-get line2 'Angle)
 )
 (if (or (equal dlt1 dlt2 1e-08)
  (equal dlt1 (+ pi dlt2) 1e-08)
     )        ;parallel lines
   (setq flag t)
   (setq flag nil)
 )
 (if flag
   (progn
     (if
(< (distance sp1 sp2) (distance sp1 ep2))
 (progn
   (setq p1 (midpoint sp1 sp2)
         p2 (midpoint ep1 ep2)
   )
 )
 (progn
   (setq p1 (midpoint sp1 ep2)
         p2 (midpoint ep1 sp2)
   )
 )
     )
     (setq xline1 (vlax-invoke acsp 'AddXline p1 p2))
   )
   (progn
     (setq tmp (vlax-invoke line1 'Intersectwith line2 acextendboth))
     (setq rad        (distance tmp
                  (setq        p1
                         (car (vl-sort
                                (list sp1 sp2 ep1 ep2)
                                (function (lambda (a b)
                                            (< (distance tmp a) (distance tmp b))
                                          )
                                )
                              )
                         )
                  )
        )
     )
     (if (vl-some (function (lambda (a)
                       (equal tmp a 1e-08)
                     )
           )
           (list sp1 sp2 ep1 ep2)
  )
(setq rad 0.001)
     )
     (setq ocirc (vlax-invoke acsp 'AddCircle tmp rad))
     (setq int1 (group-by-num
           (vlax-invoke ocirc 'Intersectwith line1 acextendnone)
           3
         )
    int2 (group-by-num
           (vlax-invoke ocirc 'Intersectwith line2 acextendnone)
           3
         )
     )
     (setq
nxp (vl-remove-if (function not)(vl-sort (append int1 int2)
             (function (lambda (a b)
                         (< (distance sp1 a) (distance sp1 b))
                       )
             )
    )
      )
)
     (if (= (length nxp) 1)
(progn
  (if int1
    (setq ip (polar tmp (angle tmp (vlax-get line2 'StartPoint))
                  (distance tmp int1)))
  (setq ip (polar tmp (angle tmp (vlax-get line1 'StartPoint))
                  (distance tmp int2)))
    )
  (setq p2 (midpoint (car nxp) ip))
  )
     (setq p2 (midpoint (car nxp) (cadr nxp)))
)
     (setq xline1 (vlax-invoke acsp 'AddXline tmp p2))
   )
 )
 (mapcar (function (lambda (x)
              (vl-catch-all-apply
                (function (lambda ()
                            (progn
                              (vla-delete ocirc)
                              (vlax-release-object x)
                            )
                          )
                )
              )
            )
  )
  (list line1 line2 ocirc xline1)
 )
 (*error* nil)
 (princ)
)

Sub BisectorLine()
Dim entTemp As AcadEntity
Dim entLine1 As AcadLine
Dim entLine2 As AcadLine
Dim entCircle As AcadCircle
Dim entBisector As AcadXline
Dim varTempPoint As Variant
Dim varTempPoint2 As Variant
Dim arrDblPT(2) As Double
  ThisDrawing.Utility.GetEntity entTemp, varTempPoint, "Select first line: "
  If Not entTemp.ObjectName = "AcDbLine" Then Exit Sub
  Set entLine1 = entTemp.Copy
  ThisDrawing.Utility.GetEntity entTemp, varTempPoint, "Select second line: "
  If Not entTemp.ObjectName = "AcDbLine" Then Exit Sub
  Set entLine2 = entTemp.Copy
  varTempPoint = entLine1.IntersectWith(entLine2, acExtendBoth)
  entLine1.StartPoint = varTempPoint
  entLine2.StartPoint = varTempPoint
  Set entCircle = ThisDrawing.ModelSpace.AddCircle(varTempPoint, 1) 'this demo for limited scale modelspace only
  varTempPoint = entCircle.IntersectWith(entLine1, acExtendNone)
  varTempPoint2 = entCircle.IntersectWith(entLine2, acExtendNone)
  arrDblPT(0) = (varTempPoint(0) + varTempPoint2(0)) / 2
  arrDblPT(1) = (varTempPoint(1) + varTempPoint2(1)) / 2
  arrDblPT(2) = 0 'this demo for WCS only
  Set entBisector = ThisDrawing.ModelSpace.AddXline(entCircle.Center, arrDblPT)
  entLine1.Delete
  entLine2.Delete
  entCircle.Delete
  Set entLine1 = Nothing
  Set entLine2 = Nothing
  Set entCircle = Nothing
  Set entBisector = Nothing
End Sub