0 Members and 1 Guest are viewing this topic.
Quote from: alanjt on May 28, 2010, 11:33:13 AMQuote from: ronjonp on May 28, 2010, 11:14:05 AMWell I think Hugo has a nice selection to choose from now I hope I didn't step on your toes, Ron. I was just joining in on the fun.Not at all ... I actually enjoy seeing how other people solve problems
Quote from: ronjonp on May 28, 2010, 11:14:05 AMWell I think Hugo has a nice selection to choose from now I hope I didn't step on your toes, Ron. I was just joining in on the fun.
Well I think Hugo has a nice selection to choose from now
(defun c:PTL (/ ent dist pt dxf) ;; Alan J. Thompson, 05.28.10 (while (and (setq ent (car (entsel "\nSelect curve: "))) (eq "LINE" (cdr (assoc 0 (entget ent)))) (setq dist (cond ((getdist "\nSpecify distance <None>: ")) (0.) ) ) ) (while (setq pt (getpoint "\nSpecify point for line: ")) (setq pt (trans pt 1 0)) ((lambda (pol) ((lambda (ang) (if (and (> ang (* pi 0.5)) (< ang (* pi 1.5))) (setq dxf '(10 11)) (setq dxf '(11 10)) ) ) (angle pol pt) ) (entmake (list '(0 . "LINE") (cons (cadr dxf) pol) (cons (car dxf) (cond ((zerop dist) pt) ((polar pol (angle pol pt) dist)) ) ) ) ) ((lambda (lst / lst) (if (< (apply (function distance) lst) (distance pol (car (setq lst (vl-sort lst (function (lambda (a b) (> (distance a pol) (distance b pol)))) ) ) ) ) ) (entmod (mapcar (function (lambda (x) (if (equal (cdr x) (cadr lst)) (cons (car x) pol) x ) ) ) (entget ent) ) ) ) ) (list (vlax-curve-getEndPoint ent) (vlax-curve-getStartPoint ent)) ) ) (vlax-curve-getClosestPointTo ent pt T) ) ) ) (princ))
;;; Draw perpendicular line;;; Alan J. Thompson, 10.15.09;;; Edited by GSLS(SS) 2011-03-08(defun c:Lper (/ foo ss-errexit #Ent #Read pt p0 ang ent blk?) (defun foo (/ is_go lst mid mod) (setq pt (osnap (cadr #read) "_end,_mid,_cen,_nod,_int,_tan,_per,_nea" ) ) (if pt (progn (setq is_go T lst '("_end" "_mid" "_cen" "_nod" "_int" "_tan" "_per" "_nea") ) (while (and is_go lst) (setq mid (car lst) lst (cdr lst) ) (if (equal pt (osnap (cadr #read) mid)) (setq mod mid is_go nil ) ) ) (if mod (osMark (list pt mod (cadr #read))) ) ) ) (or pt (setq pt (cadr #Read))) (setq pt (trans pt 1 0)) (setq p0 (vlax-curve-getclosestpointto #Ent pt T)) ) ;_Add osmark ;;line-ang ;;by Lee Mac (defun line-ang (p0 ang / ent #read) (setq ent (entget (entmakex (list (cons 0 "LINE") (cons 10 p0) (cons 11 p0))) ) ) (while (= 5 (car (setq #Read (grread T 13 0)))) (entupd (cdr (assoc -1 (entmod (list (assoc -1 ent) (cons 11 (trans (polar p0 ang ((if (minusp ((lambda (n) (- (caddr (trans (cadr #read) 1 n)) (caddr (trans p0 1 n)) ) ) (polar '(0. 0. 0.) ang 1.) ) ) - + ) (distance p0 (cadr #read)) ) ) 1 0 ) ) ) ) ) ) ) ) ) (defun ss-errexit (msg) (command) (command) (if (or (= msg "Function cancelled") (= msg "quit / exit abort") ) (princ msg) (princ (strcat "\n错误: " msg)) ) (if blk? (entdel #ent) ) (clos) ) (svos) (setq #Ent (ss-Nentsel "\n选择曲线: ")) ;_support block (setq blk? (last #Ent) #Ent (car #Ent) ) (if (and #ent (vl-position (cdr (assoc 0 (entget #Ent))) '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE" "SPLINE") ) ) (while (and (/= 25 (car (setq #Read (grread T 1 1)))) (/= (car #Read) 11) (/= (car #Read) 2) ) (princ "\r选择点: ") (redraw) (if (vl-consp (cadr #Read)) (foo) ) (if p0 (grdraw p0 (trans pt 1 0) 1 ) ;_ grdraw ) ;_ if (if (and (eq 3 (car #Read)) (foo)) (if (not (equal pt p0 1e-6)) (entmake (list '(0 . "LINE") (cons 10 p0 ) (cons 11 pt) ) ;_ list ) ;_ entmake (progn ;_ the part writen by Lee Mac (setq ang (+ (xyp-get-AngleAtPoint #Ent p0) _pi2)) (line-ang p0 ang) ) ) ) ;_ if ) ;_ while ) ;_ if (redraw) (clos) (princ)) ;_ defun;;;save old sysvar(defun svos () (setq #system# '("OSMODE" "ORTHOMODE" "CLAYER" "CECOLOR" "PLINEWID" "CELTYPE" "CMDECHO" "ELEVATION" "PICKSTYLE" ) #vlale# (mapcar 'getvar #system#) gsls_olderr *error* *error* ss-errexit ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)) ));;;---------------------------------------------------------------------;;;;;;call old sysvar(defun clos () (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)) ) (MapCar 'setvar #system# #vlale#) (setq *error* gsls_olderr));;; Nentsel;;; function : to nentsel a entity In situ;;; arg : string to princ in command-line;;; return : a list ( ename point is-of-block? );;; Note : if the ename is of a block , the routine copy a similar entity , so you must entdel it later ;;; by GSLS(SS);;;(defun ss-Nentsel (msg / en en1 pt mat ins mat ent) (setq en (Nentsel msg)) (if (= (length en) 4) (progn (setq en1 (car en) pt (cadr en) mat (caddr en) ins (last mat) mat (reverse (cdr (reverse mat))) mat ((append (mapcar '(lambda (x y) (append x (list y)) ) mat ins ) '((0. 0. 0. 1.)) ) ) ) (setq ent (entget en1 '("*"))) (setq ent (vl-remove (assoc -1 ent) ent)) (setq en1 (entmakex ent)) ;_make a new similar entity !!! (if en1 (progn (setq obj (vlax-ename->vla-object en1)) (vla-TransformBy obj (vlax-tmatrix mat)) (setq en1 (vlax-vla-object->ename obj)) ) ) (list en1 pt T) ) (append en (list nil)) ));;;by xyp1964(defun xyp-get-AngleAtPoint (ename point / oname p1 v1 pt-ang) (setq oname (vlax-ename->vla-object ename)) (setq v1 (vlax-curve-getfirstderiv oname (vlax-curve-getparamatpoint oname point) ) p1 (mapcar '+ point v1) pt-ang (angle point p1) ) (vlax-release-object oname) pt-ang);;;osmark by Evgeniy(defun osMark (o / s drft osGrv) (setq s (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) o (cons (trans (car o) 1 3) (cdr o)) ) (setq osGrv (osmode-grvecs-lst (vla-get-AutoSnapMarkerColor (setq drft (vla-get-drafting (vla-get-preferences (vlax-get-acad-object) ) ) ) ) (vla-get-AutoSnapMarkerSize drft) ) ) (grvecs (cdr (assoc (cadr o) osGrv)) (list (list s 0. 0. (caar o)) (list 0. s 0. (cadar o)) (list 0. 0. s (caddar o)) (list 0. 0. 0. 1.) ) ))