[编程交流] 拾取切点时出现问题

 
(defun c:column ()
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 35)
(setq oldcmddia (getvar "cmddia"))
(setvar "cmddia" 0)
(princ "n\ Draws circular column using 3 reference points")
;draw initial 3 circles using user input
(initget 1)(setq orig1pt (getpoint "\n Select origin of measurement..."))
(setq circ1rad (getreal "\n Input distance from disto..."))
(command "circle" orig1pt circ1rad ) 
(initget 1)(setq orig2pt (getpoint "\n Select origin of measurement..."))
(setq circ2rad (getreal "\n Input distance from disto..."))
(command "circle" orig2pt circ2rad ) 
(initget 1)(setq orig3pt (getpoint "\n Select origin of measurement..."))
(setq circ3rad (getreal "\n Input distance from disto..."))
(command "circle" orig3pt circ3rad )
;draw column with 3 tangent points
(setvar "osmode" 256)
(initget 1)(setq col1pt1 (getpoint "\n Select tangent on first circle nearest where column will be placed..."))
(setvar "osmode" 256)
(initget 1)(setq col1pt2 (getpoint "\n Select tangent on second circle nearest where column will be placed..."))
(setvar "osmode" 256)
(initget 1)(setq col1pt3 (getpoint "\n Select tangent on third circle nearest where column will be placed..."))
(command "circle" "3p" col1pt1 col1pt2 col1pt3 )
(setvar "osmode" oldosmode )
(setvar "cmdecho" oldcmdecho )
(setvar "cmddia" oldcmddia)
(princ)
)

;;  CAB Version 1.0  The Sledge Hammer Approach
;; Perhaps someone with a math background can apply the Math solution
;;  http://demonstrations.wolfram.com/CirclesOfApollonius/
;;  http://www.geometryexpressions.com/downloads/Circles.pdf  example 86
(defun c:GetColumn (/ p1 p2 p3 r1 r2 r3 c1 c2 c3 rbase rinc fuzz
                   cpt pts_c1_c2 pts_c2_c3 pts_c1_c3)
 (vl-load-com)
 (defun MakeCircle (cpt rad lay)
   (entmakex
     (list (cons 0 "CIRCLE")
           (cons 6 "BYLAYER")
           (cons 8 "0")
           (cons 10 cpt)
           (cons 39 0.0)
           (cons 40 rad)     ; radius
           (cons 62 256)
           (cons 210 (list 0.0 0.0 1.0))
     )
   )
 )
 ;;  return 2 points in a list
 (defun getinters (obj1 obj2)
   (setq iplist (vl-catch-all-apply
                  'vlax-safearray->list
                  (list (vlax-variant-value
                          (vla-intersectwith obj1 obj2 acextendnone)
                        )
                  )
                )
   )
   (if (vl-catch-all-error-p iplist) ;  error if no intersection
     nil
     (list (list (car iplist)(cadr iplist))(list (cadddr iplist)(nth 4 iplist)))
   )
 )
 (if (or p1 ; debug
     (and (setq p1 (getpoint "\nPick First circle center point."))
          (setq r1 (getdist "\nEnter distance to column.") rx1 r1)
          (setq p2 (getpoint "\nPick Second circle center point."))
          (setq r2 (getdist "\nEnter distance to column.") rx2 r2)
          (setq p3 (getpoint "\nPick Third circle center point."))
          (setq r3 (getdist "\nEnter distance to column.") rx3 r3)
 )
     )
   (progn
     (setq r1 rx1 r2 rx2 r3 rx3) ; debug
     (setq rbase r1
           rinc  0.01 ; step size
           fuzz  0.01)
     (setq c1 (vlax-ename->vla-object (MakeCircle p1 r1 "0")))
     (setq c2 (vlax-ename->vla-object (MakeCircle p2 r2 "0")))
     (setq c3 (vlax-ename->vla-object (MakeCircle p3 r3 "0")))
     (while
       (progn
       (vla-put-radius c1 (setq r1 (+ r1 rinc)))
       (vla-put-radius c2 (setq r2 (+ r2 rinc)))
       (vla-put-radius c3 (setq r3 (+ r3 rinc)))
      (cond
         ((null (setq pts_c1_c2 (getinters c1 c2)))
          (prompt "\nC1 & C2 do not intersect.")
         )
         ((null (setq pts_c2_c3 (getinters c2 c3)))
          (prompt "\nC2 & C3 do not intersect.")
         )
         ((null (setq pts_c1_c3 (getinters c1 c3)))
          (prompt "\nC1 & C3 do not intersect.")
         )
         ;;  if 3 of the 6 points are the same the center has been found
         ;;  check the first 2 point pair against the remaining two pair
         ((vl-some '(lambda(x)  ; 5.77522
                      (and
                            (or (equal x (car pts_c2_c3) fuzz)
                                (equal x (cadr pts_c2_c3) fuzz))
                            (or (equal x (car pts_c1_c3) fuzz)
                                (equal x (cadr pts_c1_c3) fuzz))))
                   pts_c1_c2)
          (MakeCircle (car pts_c1_c2) (- r1 rbase) "0")
          nil ; exit loop
         )
         (t t)
       )
       )
     )
   )
 )
 (princ)
)

;;; AUTHOR
;;; Copyright© 2009 Ron Perez (ronperez (AT) gmail dot com)
;;; 
(defun c:tancir    (/ c1 c2 c3 cen circle d1 d2 d3 fuzz p rad ss)
 (vl-load-com)
 (princ "\nSelect 3 circles...")
 (if (and (setq ss (ssget '((0 . "CIRCLE"))))
      (setq c1 (ssname ss 0))
      (setq c2 (ssname ss 1))
      (setq c3 (ssname ss 2))
      (setq fuzz 0.01)
     )
   (while (and (setq p (grread 5)) (= (car p) 5) (setq cen (trans (cadr p) 1 0)))
     (redraw)
     (grdraw cen (setq d1 (vlax-curve-getclosestpointto c1 cen)) 1)
     (grdraw cen (setq d2 (vlax-curve-getclosestpointto c2 cen)) 2)
     (grdraw cen (setq d3 (vlax-curve-getclosestpointto c3 cen)) 3)
     (setq rad (/ (apply '+ (list (distance cen d1) (distance cen d2) (distance cen d3))) 3.))
     (if circle
   (entdel circle)
     )
     (setq circle (entmakex (list '(0 . "CIRCLE")
                  '(6 . "BYLAYER")
                  '(8 . "0")
                  (cons 10 cen)
                  '(39 . 0.0)
                  (cons 40 rad) ; radius
                  '(62 . 256)
                  (cons 210 (list 0.0 0.0 1.0))
                )
          )
     )
     (if (and (equal rad (distance cen d1) fuzz)
          (equal rad (distance cen d2) fuzz)
          (equal rad (distance cen d3) fuzz)
     )
   (progn (grdraw cen (vlax-curve-getclosestpointto c1 cen) 5)
          (grdraw cen (vlax-curve-getclosestpointto c2 cen) 5)
          (grdraw cen (vlax-curve-getclosestpointto c3 cen) 5)
   )
     )
     (princ)
   )
 )
)

3）
 
 
[code];DAIC.LSP  Program to delete entities generated by AIC
;          on the AIC layer.
; 7-31-09  Working version by CALCAD
(defun c:daic (/ vcset n ssln vc_en)
(setq vcset (ssget "X" '((8 . "AIC")))) ; select all entities on AIC layer
(if (/= vcset nil)
 (progn
   (setq n 0)
   (setq ssln 0)
   (setq ssln (sslength vcset))
   (repeat ssln
     (setq vc_en (ssname vcset n))
     (entdel vc_en)
     (setq n (+ n 1))
   )
 )
)
(setq vcset nil)
(princ)
)

5