(defun line<45 (/ GR LST PT)
; Drawing of a line under a corner of 45 degrees
; by ElpanovEvgeniy
; (2005-03-22 10:43:02)
;(line<45)
(setq lst (entget
(entmakex
(list
'(0 . "LINE")
(cons 8 (getvar "CLAYER"))
(cons 10 (setq pt (getpoint "\n Specify the first point ")))
(cons 11 pt)
) ;_ list
) ;_ entmakex
) ;_ entget
) ;_ setq
(princ "\n Specify the second point ")
(while (and (setq gr (grread 5)) (= (car gr) 5))
(entmod (subst
(cons 11 (polar pt (/ pi 4) (distance pt (cadr gr))))
(assoc 11 lst)
lst
) ;_ subst
) ;_ entmod
(entupd (cdr (assoc -1 lst)))
) ;_ while
) ;_ defun
(defun arc-radius (/ GR LST PT)
; Change of radius of an arc
; by ElpanovEvgeniy
; (2005-03-22 11:21:30)
;(arc-radius)
(setq lst (entget
(car (entsel "\n Select an arc "))
) ;_ entget
pt (cdr (assoc 10 lst))
) ;_ setq
(princ "\n Select new radius ")
(while (and (setq gr (grread 5)) (= (car gr) 5))
(entmod (subst
(cons 40 (distance pt (cadr gr)))
(assoc 40 lst)
lst
) ;_ subst
) ;_ entmod
(entupd (cdr (assoc -1 lst)))
) ;_ while
) ;_ defun
(defun VECTORS (/ PT PTLIST)
; Sequential choice of points
; by ElpanovEvgeniy
; (2005-10-19 17:59:01)
; (VECTORS)
(setq PTLIST (list
(setq PT (getpoint "\n Specify the first point "))
) ;_ list
) ;_ setq
(princ "\n Specify the following point ")
(princ)
(while
(setq PT
(progn (while
(and (setq PT (grread 5))
(= (car PT) 5)
) ;_ and
(redraw)
(mapcar
(function
(lambda (x1 x2)
(grdraw x1 x2 6 5)
) ;_ lambda
) ;_ function
(cons (cadr PT) PTLIST)
PTLIST
) ;_ mapcar
) ;_ while
(if (listp (cadr PT))
(cadr PT)
) ;_ if
) ;_ progn
) ;_ setq
(setq PTLIST (cons PT PTLIST))
) ;_ while
) ;_ defun
(defun lst-ent-wp (/ PT PTLIST SS)
; Clone Select CP
; by ElpanovEvgeniy
; (2006-05-11 11:05:52)
; (lst-ent-wp)
(setq
PTLIST (list (setq PT (getpoint "\n Specify the first point ")))
) ;_ setq
(princ "\n Specify the following point ")
(princ)
(while
(setq
PT (progn
(while
(and
(setq PT (grread 5))
(= (car PT) 5)
) ;_ and
(redraw)
(mapcar
(function
(lambda (x1 x2)
(grdraw x1 x2 6 5)
) ;_ lambda
) ;_ function
(cons (cadr PT) PTLIST)
(append PTLIST (cdr PT))
) ;_ mapcar
) ;_ while
(if (listp (cadr PT))
(cadr PT)
) ;_ if
) ;_ progn
) ;_ setq
(setq PTLIST (cons PT PTLIST))
) ;_ while
(redraw)
(vla-ZoomExtents (vlax-get-acad-object))
(if (setq ss (ssget "CP" PTLIST))
(vl-remove-if
(function listp)
(mapcar (function cadr) (ssnamex ss))
) ;_ vl-remove-if
) ;_ if
) ;_ defun
(defun c:test (/ A LST P P1 S X Y)
; Example of usage of various matrixes in LISP
; by ElpanovEvgeniy
; (2006-10-01)
; (c:test)
(setq lst '((0. 0.) (0. 1.) (1. 1.) (1. 0.))
p1 (trans (setq p (getpoint "\n Get base point")) 1 3)
x (car p1)
y (cadr p1)
) ;_ setq
(while (= (car (setq p (grread nil 5))) 5)
(setq p (trans (cadr p) 1 3)
p (list (- (car p) x) (- (cadr p) y))
a 0. ;(angle p1 p)
s (/ (getvar "viewsize") 10.)
) ;_ setq
(if (> (abs (car p)) (abs (cadr p)))
(setq p (list
(if (minusp (car p))
-1.
1.
) ;_ if
(if (zerop (car p))
0.
(/ (cadr p) (abs (car p)))
) ;_ if
) ;_ list
) ;_ setq
(setq p (list
(if (zerop (cadr p))
0.
(/ (car p) (abs (cadr p)))
) ;_ if
(if (minusp (cadr p))
-1.
1.
) ;_ if
) ;_ list
) ;_ setq
) ;_ if
(redraw)
(grvecs
(apply
(function append)
(cons (list 3 '(0 0) p)
(mapcar
(function
(lambda (l)
(apply
(function append)
(mapcar
(function
(lambda (x x1) (list 1 x x1))
) ;_ function
l
(cons (last l) l)
) ;_ mapcar
) ;_ apply
) ;_ lambda
) ;_ function
(mapcar
(function
(lambda (n)
(setq
n (list
(+ (* (car n) (car p)) (* (cadr n) (cadr p)))
(+ (* (car n) (cadr p)) (* (cadr n) (- (car p))))
) ;_ list
) ;_ setq
(mapcar (function (lambda (x1) (mapcar (function +) x1 n))) lst)
) ;_ lambda
) ;_ function
'((-2 -2)(-1 -2)(0 -2)(1 -2)(2 -2)
(-2 -1)(-1 -1)(0 -1)(1 -1)(2 -1)
(-2 0)(-1 0)(0 0)(1 0)(2 0)
(-2 1)(-1 1)(0 1)(1 1)(2 1)
(-2 2)(-1 2)(0 2)(1 2)(2 2)
)
) ;_ mapcar
) ;_ mapcar
) ;_ cons
) ;_ apply
(list
(list (* (cos a) s) (* (- (sin a)) s) 0. (- (+ x x) (* x (cos a)) (* y (- (sin a)))))
(list (* (sin a) s) (* (cos a) s) 0. (- (+ y y) (* x (sin a)) (* y (cos a))))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
) ;_ while
(redraw)
) ;_ defun
(defun C:LW_pt (/ ENT I LST LW PAR PT)
; Addition of a point in a polyline
; by ElpanovEvgeniy
; (2005-11-09 15:05:39)
; (C:LW_pt)
(setq pt (getpoint " \n Specify a new point polylines. "))
(if (and pt (setq lw (ssget pt '((0 . "LWPOLYLINE")))) (setq lw (ssname lw 0)))
(progn
(setq par (vlax-curve-getParamAtPoint lw (vlax-curve-getClosestPointTo lw pt))
ent (entget lw)
ent (subst (cons 90 (1+ (cdr (assoc 90 ent)))) (assoc 90 ent) ent)
i 0
lst nil
) ;_ setq
(while (or (/= (caar ent) 41)
(if (< i (fix par))
(setq i (1+ i))
) ;_ if
) ;_ or
(setq lst (cons (car ent) lst)
ent (cdr ent)
) ;_ setq
) ;_ while
(setq lst (cons (cons 41
(+ (cdr (assoc 40 lst))
(* (- (cdr (assoc 41 ent)) (cdr (assoc 40 lst))) (- par (fix par)))
) ;_ +
) ;_ cons
lst
) ;_ cons
lst (cons (cons 42
(/ (sin (setq i
(- (angle (vlax-curve-getPointAtParam lw (fix par)) pt)
(angle
(vlax-curve-getPointAtParam lw (fix par))
(vlax-curve-getPointAtParam lw (+ (fix par) (/ (- par (fix par)) 2.)))
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
lst (cons (assoc 41 ent)
(cons (cons 40 (cdr (assoc 41 lst))) (cons (list 10 (car pt) (cadr pt)) lst))
) ;_ cons
lst (cons
(cons
42
(/
(sin (setq
i (- (angle pt (vlax-curve-getPointAtParam lw (1+ (fix par))))
(angle
pt
(vlax-curve-getPointAtParam lw (+ par (/ (- (1+ (fix par)) par) 2.)))
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
) ;_ setq
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(entmod (append (reverse lst) (cddr ent)))
(entupd lw)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
) ;_ progn
(princ " \n Specified point does not lay on a polyline. ")
) ;_ if
(princ)
) ;_ defun
(defun c:lw_pt_1 (/ ent i gr lst lw par pt)
; Addition of a point in a lwpolyline, line, arc, circle
; by ElpanovEvgeniy
; (2005-11-10 12:48:04)
; (c:lw_pt_1)
(princ " \n Specify a new point polylines. ")
(while (and (setq gr (grread 5)) (= (car gr) 5))
(if lw
(redraw lw 4)
) ;_ if
(if (and (setq pt (osnap (cadr gr) "_nea,_end"))
(setq lw (ssget pt '((0 . "LWPOLYLINE,LINE,ARC,CIRCLE"))))
(setq lw (ssname lw 0))
(setq ent (entget lw))
) ;_ and
(redraw lw 3)
) ;_ if
) ;_ while
(cond
((= (cdr (assoc 0 ent)) "LWPOLYLINE")
(setq par (vlax-curve-getparamatpoint
lw
(vlax-curve-getclosestpointto
lw
pt
) ;_ vlax-curve-getclosestpointto
) ;_ vlax-curve-getparamatpoint
ent (subst (cons 90 (1+ (cdr (assoc 90 ent))))
(assoc 90
ent
) ;_ assoc
ent
) ;_ subst
i 0
lst nil
) ;_ setq
(if (/= par (fix par))
(progn (while (or (/= (caar ent) 41)
(if (< i (fix par))
(setq i (1+ i))
) ;_ if
) ;_ or
(setq lst (cons (car ent) lst)
ent (cdr ent)
) ;_ setq
) ;_ while
(setq lst (cons
(cons
41
(+ (cdr (assoc 40 lst))
(* (- (cdr (assoc 41 ent)) (cdr (assoc 40 lst)))
(-
par
(fix par)
) ;_ -
) ;_ *
) ;_ +
) ;_ cons
lst
) ;_ cons
lst (cons
(cons
42
(/
(sin
(setq i (-
(angle
(vlax-curve-getpointatparam
lw
(fix par)
) ;_ vlax-curve-getpointatparam
pt
) ;_ angle
(angle (vlax-curve-getpointatparam lw (fix par))
(vlax-curve-getpointatparam
lw
(+ (fix par)
(/ (-
par
(fix par)
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
lst (cons (assoc 41 ent)
(cons (cons 40 (cdr (assoc 41 lst)))
(cons (list 10 (car pt) (cadr pt))
lst
) ;_ cons
) ;_ cons
) ;_ cons
lst (cons
(cons
42
(/
(sin
(setq
i (-
(angle pt
(vlax-curve-getpointatparam
lw
(1+ (fix par))
) ;_ vlax-curve-
) ;_ angle
(angle pt
(vlax-curve-getpointatparam
lw
(+ par
(/ (-
(1+ (fix par))
par
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
lst
) ;_ cons
) ;_ setq
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmod (append (reverse lst) (cddr ent)))
(entupd lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
) ;_ progn
) ;_ if
(vl-cmdf
"_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
((= (cdr (assoc 0 ent)) "LINE")
(setq lst '((0 . "LWPOLYLINE")))
(foreach x '(100 67 410 8 62 6 370)
(if (assoc x ent)
(setq lst (cons (assoc x ent) lst))
) ;_ if
) ;_ foreach
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmakex
(append (reverse lst)
(list '(100 . "AcDbPolyline")
'(90 . 3)
'(70 . 0)
(cons 38 (cadddr (assoc 10 ent)))
(assoc 10 ent)
'(40 . 0)
'(41 . 0)
'(42 . 0)
(cons 10 (list (car pt) (cadr pt)))
'(40 . 0)
'(41 . 0)
'(42 . 0)
(cons 10
(list (cadr (assoc 11 ent))
(caddr (assoc 11
ent
) ;_ assoc
) ;_ caddr
) ;_ list
) ;_ cons
'(40 . 0)
'(41 . 0)
'(42 . 0)
(assoc 210 ent)
) ;_ list
) ;_ append
) ;_ entmakex
(entdel lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(vl-cmdf "_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
((= (cdr (assoc 0 ent)) "ARC")
(setq lst '((0 . "LWPOLYLINE"))
par (vlax-curve-getparamatpoint
lw
(vlax-curve-getclosestpointto
lw
pt
) ;_ vlax-curve-
) ;_ vlax-curve-getparamatpoint
) ;_ setq
(foreach x '(100 67 410 8 62 6 370)
(if (assoc x
ent
) ;_ assoc
(setq lst (cons (assoc x ent) lst))
) ;_ if
) ;_ foreach
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmakex
(append
(reverse lst)
(list
'(100 . "AcDbPolyline")
'(90 . 3)
'(70 . 0)
(cons 38 (cadddr (assoc 10 ent)))
(cons
10
(reverse
(cdr
(reverse
(polar
(cdr
(assoc 10 ent)
) ;_ cdr
(cdr (assoc 50 ent))
(cdr (assoc 40 ent))
) ;_ polar
) ;_ reverse
) ;_ cdr
) ;_ reverse
) ;_ cons
'(40 . 0)
'(41 . 0)
(cons
42
(/
(sin
(setq i (-
(angle
(vlax-curve-getstartpoint lw)
pt
) ;_ angle
(angle
(vlax-curve-getstartpoint lw)
(vlax-curve-getpointatparam
lw
(+ (vlax-curve-getstartparam lw)
(/
(- par
(vlax-curve-getstartparam
lw
) ;_ vlax-curve-
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
(cons 10 (list (car pt) (cadr pt)))
'(40 . 0)
'(41 . 0)
(cons 42
(/ (sin
(setq i (-
(angle pt (vlax-curve-getendpoint lw))
(angle pt
(vlax-curve-getpointatparam
lw
(+ par
(/ (-
(vlax-curve-getendparam lw)
par
) ;_ -
2.
) ;_ /
) ;_ +
) ;_ vlax-curve-getpointatparam
) ;_ angle
) ;_ -
) ;_ setq
) ;_ sin
(cos i)
) ;_ /
) ;_ cons
(cons
10
(reverse
(cdr
(reverse
(polar
(cdr
(assoc
10
ent
) ;_ assoc
) ;_ cdr
(cdr (assoc 51 ent))
(cdr (assoc 40 ent))
) ;_ polar
) ;_ reverse
) ;_ cdr
) ;_ reverse
) ;_ cons
'(40 . 0)
'(41 . 0)
'(42 . 0)
(assoc 210 ent)
) ;_ list
) ;_ append
) ;_ entmakex
(entdel lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(vl-cmdf "_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
((= (cdr (assoc 0 ent)) "CIRCLE")
(setq lst '((0 . "LWPOLYLINE")))
(foreach x '(100 67 410 8 62 6 370)
(if (assoc x ent)
(setq lst (cons (assoc x ent) lst))
) ;_ if
) ;_ foreach
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(entmakex
(append (reverse lst)
(list '(100 . "AcDbPolyline")
'(90 . 2)
'(70 . 1)
(cons 38 (cadddr (assoc 10 ent)))
(cons 10 (list (car pt) (cadr pt)))
'(40 . 0)
'(41 . 0)
(cons 42 (/ (sin (/ pi 4.)) (cos (/ pi 4.))))
(cons 10
(reverse
(cdr (reverse (polar (cdr (assoc 10 ent))
(angle
pt
(cdr (assoc 10 ent))
) ;_ angle
(cdr (assoc 40 ent))
) ;_ polar
) ;_ reverse
) ;_ cdr
) ;_ reverse
) ;_ cons
'(40 . 0)
'(41 . 0)
'(42 . 1.)
(assoc 210 ent)
) ;_ list
) ;_ append
) ;_ entmakex
(entdel lw)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(vl-cmdf "_.stretch"
"_C"
pt
pt
""
pt
(getpoint pt " Specify a new point: ")
) ;_ vl-cmdf
)
(t (princ " \n Specified point does not lay on a polyline or line, arc, circle... "))
) ;_ cond
(princ)
) ;_ defun
(defun rc (/ p1 p2 p3 p4 a g om)
(setq om (getvar "OSMODE"))(setvar "OSMODE" 0)
(setq p1 (getpoint "\nSelect objects to stretch by (rotated) crossing..."))
(princ "\nOther corner...")
(while (not a)
(setq g (grread T) p3 (cadr g))
(cond ((= (car g) 3) ; PICK BUTTON?
(setq a T)
(redraw)
)
((= (car g) 5) ; POSITIE?
(setq p2 (list (car p1)(cadr p3)))
(setq p4 (list (car p3)(cadr p1)))
(redraw)(grvecs (list -256 p1 p2 p2 p3 p3 p4 p4 p1))
)
)
)
(setvar "OSMODE" om)
(ssget "CP" (list p1 p2 p3 p4))
)
I never understood why the box of a crossing or window doesn't follow the angle of the UCS.....
I never understood why the box of a crossing or window doesn't follow the angle of the UCS.
You can see now how complex it could get if you tried to capture pixels in any direction but 'square' to the screen.
A work around could be to grab the rectangle and the model/scene and transform it to be square, do the selection thing and invert it back but there may be some subtle inaccuracies with doing this not to mention a performance hit.
Do you mean GRREAD or GRDRAW? :D
K4KUBE.TXT
==========
Freeware Version 1.01 of K4KUBE
Copyright (C) 2002, K4 CAD Solutions
WELCOME TO K4KUBE
===============================================================================
K4KUBE is a free RUBIK'S CUBE game for AutoCAD (R12, R13, R14, 2000, 2002).
K4KUBE comes as a zipped file (A_RUBIX.ZIP) which unzips into two files:
K4KUBE.TXT - This File.
K4KUBE.LSP - An AutoLISP program to play
R U B I K ' S C U B E.
INSTALLING K4KUBE
===============================================================================
1) Create a new directory with the path C:\K4KUBE (or any other name).
2) Unzip A_RUBIX.ZIP which expands into the two files listed above.
RUNNING K4KUBE
===============================================================================
Using the AutoCAD Menus, select 'Tools', then 'Load Application...', then
select K4KUBE.LSP from the folder which you installed into. Click on
'Load' then verify that it loaded successfully.
OR, at the AutoCAD command prompt type:
(load "c:/k4kube/k4kube") [Note: use forward slashes].
If you have installed K4KUBE into a different directory or folder than
the one above, eg. C:\Program Files\K4kube then type:
(load "c:/program files/k4kube/k4kube")
OR, for easier loading copy the file K4KUBE.LSP somewhere into the AutoCAD
support path and then type:
(load "k4kube")
Alternatively, the AutoLISP File K4KUBE.LSP may be loaded by double clicking
on it via Windows Explorer.
Once loaded, the command K4KUBE runs automatically.
Click on Large Arrows to turn the cube.
Click on Small Arrows to turn a layer.
Click on buttons to: MIX (10 random twists)
SORT (resets cube)
QUIT (quits K4KUBE, remembers last permutation)
The command K4KUBE be run at any time from the Command Bar.
NOTE: If running in IntelliCAD type:
(setq k4icad 1)
at the command prompt.
OR,
Create a new file called 'K4KUBE-P.LSP' containing:
(setq k4icad 1)
(load "c:/k4kube/k4kube") ;;modify to your installation path
Finally, to run K4KUBE type:
(load "c:/k4kube/k4kube-p")
ABOUT K4 CAD SOLUTIONS
===============================================================================
K4 CAD Solutions develops bespoke software for AutoCAD (and Windows) to meet
very specific user-requirements that are often not fully addressed by 'off
the shelf packages'. Examples of the types of projects undertaken include:
Parametric Commands : Commands to automate the drawing of complicated
designs simply by specifying dimensions of the
features within the design. Use of dialogue boxes
enables fast and accurate data entry.
Manufacturers Databases : Suites of commands that interactively display then
insert your company's manufactured products into
drawings - for use in-house or for distribution to
engineers, architects and specifiers.
CNC Code Generators : Commands to draw machined parts and automatically
generate CNC code to your exact specifications.
G CODE turning and milling projects undertaken.
For more information regarding the services on offer or to discuss your
specific requirements in detail email K4 CAD Solutions at:
admin@k4cadsolutions.co.uk
or visit the web site: http://www.k4cadsolutions.co.uk
Fixed price quotes offered for well defined and specified projects.
K4 CAD Solutions is based in Yorkshire, United Kingdom.
WARRANTY STATEMENT
===============================================================================
Author is not responsible for any damages whatsoever, including loss of
information, interruption of business, personal injury and/or any damage or
consequential damage without limitation, incurred before, during or after the
use of this product. Author's entire liability, without exception, is limited to
the customers' reimbursement of the purchase price (if applicable) of the
software (maximum being the suggested retail price) in exchange for the
return of the product, all copies, registration papers and manuals, and all
materials that constitute a transfer of ownership from the customer back to
Author.
LICENSE
===============================================================================
Each registered copy of this software may be used in only one single
location by one user. Use of the software means that you have loaded the
program and run it or have installed the program onto a computer. If you
install the software onto a multi-user platform or network, each and every
individual user of the software must be registered separately.
You may make one copy of the registered software for backup purposes,
providing you only have one copy installed on one computer being used by
one person. If any person other than yourself uses software registered in
your name, regardless of whether it is at the same time or different times,
then this agreement is being violated!
The sale of and or distribution of registered copies of this software are
strictly forbidden. It is a violation of this agreement to loan, rent,
lease, borrow, or transfer the use of registered copies of this software
product.
AutoCAD is a registered trademark of Autodesk Inc.
Windows is a registered tradmark of Microsoft Corporation
===============================================================================
Copyright (C) K4 CAD Solutions, April 2002
===============================================================================
...
Are you really sure about all this, or is it a lot of guesswork?
...
For autocad to use irregular selection with a polyline say, it would almost have to be only in 2d to keep the math simple and it would not need to use the selection buffer of the grfx, if it can do it with a 3d model (items that don't cross the polyline in the same plane) it would have to be doing its own projections to the polyline plane and then the clipping. Basically though the selction buffer is the most efficient way to collect selected entities IMO as this is what it is used and optimised for.
... I don't notice any performance difference between the two, but I'm guessing I might with a much bigger drawing or with slower hardware.
In either case, the objects appear to be projected in into the plane of the current view to determine what gets selected.
(defun c:ew(/ NewEL el1 DeltaEl)
(setq CurrElev (getvar "ELEVATION")
newDir (dkb_readMouse)
)
(if (minusp newDir) (setq NewEl -2) (setq NewEl 2))
(setvar "ELEVATION" (+ CurrElev NewEL))
); end function ew
(defun dkb_readMouse()
(setq firstY nil)
(while (= (setq grCode (car (setq grData (grread T 7 0)))) 5)
(setq grReturn (cadr grData))
(if (= grCode 5)
(progn
(if (not firstY)
(setq firstY (cadr grReturn)
currDelta 0
)
(setq currDelta (- (cadr grReturn) firstY))
)
);progn then
);if
);end while
)
(defun c:eew()
(dkb_mouseelev)
)
(defun dkb_MouseElev()
(setq firstY nil
TotalY (getvar "VIEWSIZE")
NumSteps 50
YStep (fix (/ TotalY NumSteps))
DeltaElPerStep 0.05
CurrEL (getvar "ELEVATION")
)
(while (= (setq grCode (car (setq grData (grread T 7 0)))) 5)
(setq grReturn (cadr grData))
(if (= grCode 5)
(progn
(if (not firstY)
(setq firstY (cadr grReturn)
currDelta 0
)
(setvar "ELEVATION"
(+ CurrEl
(* DeltaElPerStep
(fix (/(setq currDelta (- (cadr grReturn) firstY)) YStep))
)
)
);setvar and end else
); end inner if
);progn then
);if
);end while
)
(defun c:et()
(setq Ent1Name (car (entsel "\nPick Text to Edit "))
Ent1List (entget Ent1Name)
Ent1Elev (atof (cdr (assoc 1 Ent1List)))
OldMode (getvar "MODEMACRO")
OldElev (getvar "ELEVATION")
);setq
(setvar "MODEMACRO" (rtos Ent1Elev 2 2 ))
(setq firstY nil
TotalY (getvar "VIEWSIZE")
NumSteps 50
YStep (max (fix (/ TotalY NumSteps)) 1)
DeltaElPerStep 0.05
CurrEL (atof (getvar "MODEMACRO"))
)
(while (= (setq grCode (car (setq grData (grread T 7 0)))) 5)
(setq grReturn (cadr grData))
(if (= grCode 5)
(progn
(if (not firstY)
(setq firstY (cadr grReturn)
currDelta 0
)
(setvar "MODEMACRO"
(rtos (+ CurrEl
(* DeltaElPerStep
(fix (/(setq currDelta (- (cadr grReturn) firstY)) YStep))
)
) 2 2 )
);setvar and end else
); end inner if
);progn then
);if
);end while
(setq newEl (atof (getvar "MODEMACRO"))
newElStr (rtos newEl 2 2)
newEntList (subst (cons 1 newElStr) (assoc 1 ent1List) ent1List)
)
(setvar "ELEVATION" oldElev)
(setvar "MODEMACRO" oldMode)
(entmod newEntList)
(prin1)
);defun et
(defun menu-pop500 (d / lst p s)
; Choice function of OSNAP through the shortcut menu.
; Only, as an example.
; Is checked up in AutoCad 2004-2007 (En)
; by ElpanovEvgeniy
; (2006-10-11)
; (menu-pop500 (grread t 5))
(setq
lst (reverse
(menu-index
((lambda (x) (list (1- (vla-get-count x)) x))
(vla-item
(vla-get-menus
(vla-item
(vla-get-menugroups
(vlax-get-acad-object)
) ;_ vla-get-MenuGroups
"ACAD"
) ;_ vla-item
) ;_ vla-get-Menus
"&Object Snap Cursor Menu"
;|
" *Object Snap Cursor Menu "
For localization into other languages, it is possible to use function bu kpblc
(cond
((vl-string-search "419" (setq p(vlax-product-key)))
;; The Russian version
"&Контекстное меню привязки")
((vl-string-search "409" p)
;; The English version
"&Object Snap Cursor Menu"
))
|;
) ;_ vla-item
)
) ;_ menu-index
) ;_ reverse
) ;_ setq
(while (and
(listp d)
(or (= (car d) 5)
(= (car d) 11)
(= (car d) 12)
(= (car d) 25) ; For old version AutoCad
) ;_ or
) ;_ and
(cond
((= (car d) 25) (menucmd "POP500=*")) ; For old version AutoCad
((equal d '(11 0)) (menucmd "POP500=*"))
((= (car d) 11) (setq s (nth (- (cadr d) 500) lst)))
) ;_ cond
(if s
(setq d s)
(setq d (grread t 5))
) ;_ if
) ;_ while
(substr s 1 4)
) ;_ defun
(defun menu-index (l)
; Creation of the list of choices of choice of OSNAP
; Is checked up in AutoCad 2004-2007 (En)
; by ElpanovEvgeniy
; (2006-10-11)
;|
(menu-index
((lambda (x) (list (1-(vla-get-count x)) x))
(vla-item
(vla-get-menus
(vla-item
(vla-get-menugroups
(vlax-get-acad-object)
) ;_ vla-get-MenuGroups
"ACAD"
) ;_ vla-item
) ;_ vla-get-Menus
"&Object Snap Cursor Menu"
) ;_ vla-item
)
) ;_ menu-index
|;
(if (not (minusp (car l)))
(cond
((= (vla-get-type (vla-item (cadr l) (car l))) 0)
(cons
(vla-get-macro (vla-item (cadr l) (car l)))
(menu-index (cons (1- (car l)) (cdr l)))
) ;_ cons
)
((= (vla-get-type (vla-item (cadr l) (car l))) 1)
(menu-index (cons (1- (car l)) (cdr l)))
)
((= (vla-get-type (vla-item (cadr l) (car l))) 2)
(append
(menu-index
((lambda (x) (list (1- (vla-get-count x)) x))
(vla-get-submenu (vla-item (cadr l) (car l)))
) ;_ menu-index
) ;_ menu-index
(menu-index (cons (1- (car l)) (cdr l)))
) ;_ append
)
) ;_ cond
) ;_ if
) ;_ defun
(defun get_osmode nil
; Function create list osmode macro
; for result (getvar "OSMODE")
; by Evgeniy Elpanov
; (get_osmode)
(mapcar
(function cdr)
(vl-remove-if
(function
(lambda (x)
(zerop (logand (getvar "OSMODE") (car x)))
) ;_ lambda
) ;_ function
'((1 . "_end")
(2 . "_mid")
(4 . "_cen")
(8 . "_nod")
(16 . "_qua")
(32 . "_int")
(64 . "_ins")
(128 . "_per")
(256 . "_tan")
(512 . "_nea")
;(1024 . "_qui") ; Is not realized
(2048 . "_app")
;(4096 . "_ext") ; Is not realized
;(8192 . "_par") ; Is not realized
)
) ;_ substr
) ;_ mapcar
) ;_ defun
(defun osmode-grvecs-lst (/ -ASS ASS COL)
; Function create list
; for drawing icons osmode with the function grvecs
; by Evgeniy Elpanov
; (osmode-grvecs-lst)
(setq
col (atoi (getenv "AutoSnapColor"))
ass (atof (getenv "AutoSnapSize"))
-ass (- ass)
) ;_ setq
(list
(list
"tracking"
col
(list (* -ass 0.2) 0.)
(list (* ass 0.2) 0.)
col
(list 0. (* -ass 0.2))
(list 0. (* ass 0.2))
) ;_ list
(list
"_end"
col
(list -ass -ass)
(list -ass ass)
col
(list (1- -ass) (1- -ass))
(list (1- -ass) (1+ ass))
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list ass ass)
(list ass -ass)
col
(list (1+ ass) (1+ ass))
(list (1+ ass) (1- -ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
(list
"_mid"
col
(list -ass -ass)
(list 0. ass)
col
(list (1- -ass) (1- -ass))
(list 0. (1+ ass))
col
(list 0. ass)
(list ass -ass)
col
(list 0. (1+ ass))
(list (1+ ass) (1- -ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
(list
"_cen"
7
(list (* -ass 0.2) 0.)
(list (* ass 0.2) 0.)
7
(list 0. (* -ass 0.2))
(list 0. (* ass 0.2))
col
(list -ass 0.)
(list (* -ass 0.86) (* ass 0.5))
col
(list (* -ass 0.86) (* ass 0.5))
(list (* -ass 0.5) (* ass 0.86))
col
(list (* -ass 0.5) (* ass 0.86))
(list 0. ass)
col
(list 0. ass)
(list (* ass 0.5) (* ass 0.86))
col
(list (* ass 0.5) (* ass 0.86))
(list (* ass 0.86) (* ass 0.5))
col
(list (* ass 0.86) (* ass 0.5))
(list ass 0.)
col
(list ass 0.)
(list (* ass 0.86) (* -ass 0.5))
col
(list (* ass 0.86) (* -ass 0.5))
(list (* ass 0.5) (* -ass 0.86))
col
(list (* ass 0.5) (* -ass 0.86))
(list 0. -ass)
col
(list 0. -ass)
(list (* -ass 0.5) (* -ass 0.86))
col
(list (* -ass 0.5) (* -ass 0.86))
(list (* -ass 0.86) (* -ass 0.5))
col
(list (* -ass 0.86) (* -ass 0.5))
(list -ass 0.)
) ;_ list
(list
"_nod"
col
(list -ass -ass)
(list ass ass)
col
(list -ass ass)
(list ass -ass)
col
(list -ass 0.)
(list (* -ass 0.86) (* ass 0.5))
col
(list (* -ass 0.86) (* ass 0.5))
(list (* -ass 0.5) (* ass 0.86))
col
(list (* -ass 0.5) (* ass 0.86))
(list 0. ass)
col
(list 0. ass)
(list (* ass 0.5) (* ass 0.86))
col
(list (* ass 0.5) (* ass 0.86))
(list (* ass 0.86) (* ass 0.5))
col
(list (* ass 0.86) (* ass 0.5))
(list ass 0.)
col
(list ass 0.)
(list (* ass 0.86) (* -ass 0.5))
col
(list (* ass 0.86) (* -ass 0.5))
(list (* ass 0.5) (* -ass 0.86))
col
(list (* ass 0.5) (* -ass 0.86))
(list 0. -ass)
col
(list 0. -ass)
(list (* -ass 0.5) (* -ass 0.86))
col
(list (* -ass 0.5) (* -ass 0.86))
(list (* -ass 0.86) (* -ass 0.5))
col
(list (* -ass 0.86) (* -ass 0.5))
(list -ass 0.)
) ;_ list
(list
"_qua"
col
(list 0. -ass)
(list -ass 0.)
col
(list 0. (1- -ass))
(list (1- -ass) 0.)
col
(list -ass 0.)
(list 0. ass)
col
(list (1- -ass) 0.)
(list 0. (1+ ass))
col
(list 0. ass)
(list ass 0.)
col
(list 0. (1+ ass))
(list (1+ ass) 0.)
col
(list ass 0.)
(list 0. -ass)
col
(list (1+ ass) 0.)
(list 0. (1- -ass))
) ;_ list
(list
"_int"
col
(list -ass -ass)
(list ass ass)
col
(list -ass (1+ -ass))
(list ass (1+ ass))
col
(list (1+ -ass) -ass)
(list (1+ ass) ass)
col
(list -ass ass)
(list ass -ass)
col
(list -ass (1+ ass))
(list ass (1+ -ass))
col
(list (1+ -ass) ass)
(list (1+ ass) -ass)
) ;_ list
(list
"_ins"
col
(list (* -ass 0.1) (* -ass 0.1))
(list -ass (* -ass 0.1))
col
(list -ass (* -ass 0.1))
(list -ass ass)
col
(list -ass ass)
(list (* ass 0.1) ass)
col
(list (* ass 0.1) ass)
(list (* ass 0.1) (* ass 0.1))
col
(list (* ass 0.1) (* ass 0.1))
(list ass (* ass 0.1))
col
(list ass (* ass 0.1))
(list ass -ass)
col
(list ass -ass)
(list (* -ass 0.1) -ass)
col
(list (* -ass 0.1) -ass)
(list (* -ass 0.1) (* -ass 0.1))
col
(list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
(list (1- -ass) (1- (* -ass 0.1)))
col
(list (1- -ass) (1- (* -ass 0.1)))
(list (1- -ass) (1+ ass))
col
(list (1- -ass) (1+ ass))
(list (1+ (* ass 0.1)) (1+ ass))
col
(list (1+ (* ass 0.1)) (1+ ass))
(list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
col
(list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
(list (1+ ass) (1+ (* ass 0.1)))
col
(list (1+ ass) (1+ (* ass 0.1)))
(list (1+ ass) (1- -ass))
col
(list (1+ ass) (1- -ass))
(list (1- (* -ass 0.1)) (1- -ass))
col
(list (1- (* -ass 0.1)) (1- -ass))
(list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
) ;_ list
(list
"_tan"
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list -ass 0.)
(list (* -ass 0.86) (* ass 0.5))
col
(list (* -ass 0.86) (* ass 0.5))
(list (* -ass 0.5) (* ass 0.86))
col
(list (* -ass 0.5) (* ass 0.86))
(list 0. ass)
col
(list 0. ass)
(list (* ass 0.5) (* ass 0.86))
col
(list (* ass 0.5) (* ass 0.86))
(list (* ass 0.86) (* ass 0.5))
col
(list (* ass 0.86) (* ass 0.5))
(list ass 0.)
col
(list ass 0.)
(list (* ass 0.86) (* -ass 0.5))
col
(list (* ass 0.86) (* -ass 0.5))
(list (* ass 0.5) (* -ass 0.86))
col
(list (* ass 0.5) (* -ass 0.86))
(list 0. -ass)
col
(list 0. -ass)
(list (* -ass 0.5) (* -ass 0.86))
col
(list (* -ass 0.5) (* -ass 0.86))
(list (* -ass 0.86) (* -ass 0.5))
col
(list (* -ass 0.86) (* -ass 0.5))
(list -ass 0.)
) ;_ list
(list
"_per"
col
(list -ass -ass)
(list -ass ass)
col
(list (1- -ass) (1- -ass))
(list (1- -ass) (1+ ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
col
(list -ass 0.)
(list 0. 0.)
col
(list -ass -1.)
(list 0. -1.)
col
(list 0. 0.)
(list 0. -ass)
col
(list -1. 0.)
(list -1. -ass)
) ;_ list
(list
"_nea"
col
(list -ass -ass)
(list ass ass)
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list -ass ass)
(list ass -ass)
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
(list
"_app"
col
(list -ass -ass)
(list ass ass)
col
(list ass -ass)
(list -ass ass)
col
(list -ass -ass)
(list -ass ass)
col
(list (1- -ass) (1- -ass))
(list (1- -ass) (1+ ass))
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list ass ass)
(list ass -ass)
col
(list (1+ ass) (1+ ass))
(list (1+ ass) (1- -ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
;; Is not realized
;; (list
;; "_par"
;; col
;; (list (* -ass 0.8) -ass)
;; (list ass (* ass 0.8))
;; col
;; (list -ass (* -ass 0.8))
;; (list (* ass 0.8) ass)
;; )
) ;_ list
) ;_ defun
(defun c:test (/ GR O OSM-LST OSMODE S TP)
; Example drawing icons osmode with
; Return point, for osmode
; by Evgeniy Elpanov
; (c:test)
(setq osm-lst (osmode-grvecs-lst)
osmode (get_osmode)
) ;_ setq
(while (or (= (car (setq gr (grread nil 5 0))) 5)
(= (car gr) 11)
(= (car gr) 25) ; For old version AutoCad
) ;_ or
(if (or (= (car gr) 11)
(= (car gr) 25)
) ;_ or
(setq osmode (list (menu-pop500 gr)))
(progn
(if (setq
o (vl-remove-if
(function null)
(mapcar
(function
(lambda (x / o)
(if (setq o (osnap (cadr gr) x))
(list (distance (cadr gr) o) o x (cadr gr))
) ;_ if
) ;_ lambda
) ;_ function
osmode
) ;_ mapcar
) ;_ vl-remove-if
) ;_ setq
(setq
o (cdar
(vl-sort
o
(function
(lambda (a b)
(< (car a) (car b))
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ cdar
) ;_ setq
) ;_ if
(setq s (/ (getvar "viewsize") (cadr (getvar "SCREENSIZE"))))
(cond
((not o))
((WCMATCH (cadr o) "_end,_mid,_cen,_nod,_int,_ins")
(setq tp (car o))
(setvar "lastpoint" tp)
(setq o (cons (trans (car o) 1 3) (cdr o)))
(redraw)
(grvecs
(cdr (assoc "tracking" osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
(grvecs
(cdr (assoc (cadr o) osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
)
((WCMATCH (cadr o) "_nea,_qua,_app")
(setq o (cons (trans (car o) 1 3) (cdr o)))
(redraw)
(grvecs
(cdr (assoc (cadr o) osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
)
((and tp (not (equal tp (car o) 1e-8)))
(redraw)
(grdraw (car o) tp 7 1)
(setq o (cons (trans (car o) 1 3) (cdr o)))
(grvecs
(cdr (assoc (cadr o) osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
)
) ;_ cond
(if tp
(grvecs
(cdr (assoc "tracking" osm-lst))
(list (list s 0. 0. (car (trans tp 1 3)))
(list 0. s 0. (cadr (trans tp 1 3)))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
) ;_ if
) ;_ progn
) ;_ if
) ;_ while
(redraw)
(if o
(osnap (caddr o) (cadr o))
(cadr gr)
) ;_ if
) ;_ defunTesting further I did get an error when selecting NONE in the Right Click menu.
Also would be nice if the F3 key toggled osmode On / Off.
I like it. :-)
Testing further I did get an error when selecting NONE in the Right Click menu.
Also would be nice if the F3 key toggled osmode On / Off.
I like it. :-)
(defun menu-pop500 (d / lst s)
; Choice function of OSNAP through the shortcut menu.
; Only, as an example.
; Is checked up in AutoCad 2004-2007 (En)
; by ElpanovEvgeniy
; (2006-10-11)
; (menu-pop500 (grread t 5))
(setq
lst (reverse
(menu-index
((lambda (x) (list (1- (vla-get-count x)) x))
(vla-item
(vla-get-menus
(vla-item
(vla-get-menugroups
(vlax-get-acad-object)
) ;_ vla-get-MenuGroups
"ACAD"
) ;_ vla-item
) ;_ vla-get-Menus
"&Object Snap Cursor Menu"
) ;_ vla-item
)
) ;_ menu-index
) ;_ reverse
) ;_ setq
(while (and
(listp d)
(or (= (car d) 5)
(= (car d) 11)
(= (car d) 12)
(= (car d) 25) ; For old version AutoCad
) ;_ or
) ;_ and
(cond
((= (car d) 25) (menucmd "POP500=*")) ; For old version AutoCad
((equal d '(11 0)) (menucmd "POP500=*"))
((= (car d) 11) (setq s (nth (- (cadr d) 500) lst)))
) ;_ cond
(if s
(setq d s)
(setq d (grread t 5))
) ;_ if
) ;_ while
(substr s 1 4)
) ;_ defun
(defun menu-index (l)
; Creation of the list of choices of choice of OSNAP
; Is checked up in AutoCad 2004-2007 (En)
; by ElpanovEvgeniy
; (2006-10-11)
;|
(menu-index
((lambda (x) (list (1-(vla-get-count x)) x))
(vla-item
(vla-get-menus
(vla-item
(vla-get-menugroups
(vlax-get-acad-object)
) ;_ vla-get-MenuGroups
"ACAD"
) ;_ vla-item
) ;_ vla-get-Menus
"&Object Snap Cursor Menu"
) ;_ vla-item
)
) ;_ menu-index
|;
(if (not (minusp (car l)))
(cond
((= (vla-get-type (vla-item (cadr l) (car l))) 0)
(cons
(vla-get-macro (vla-item (cadr l) (car l)))
(menu-index (cons (1- (car l)) (cdr l)))
) ;_ cons
)
((= (vla-get-type (vla-item (cadr l) (car l))) 1)
(menu-index (cons (1- (car l)) (cdr l)))
)
((= (vla-get-type (vla-item (cadr l) (car l))) 2)
(append
(menu-index
((lambda (x) (list (1- (vla-get-count x)) x))
(vla-get-submenu (vla-item (cadr l) (car l)))
) ;_ menu-index
) ;_ menu-index
(menu-index (cons (1- (car l)) (cdr l)))
) ;_ append
)
) ;_ cond
) ;_ if
) ;_ defun
(defun get_osmode nil
; Function create list osmode macro
; for result (getvar "OSMODE")
; by Evgeniy Elpanov
; (get_osmode)
(mapcar
(function cdr)
(vl-remove-if
(function
(lambda (x)
(zerop (logand (getvar "OSMODE") (car x)))
) ;_ lambda
) ;_ function
(append
(if (< 0 (setq cur_mode (getvar "osmode")) 16384)
'((1 . "_end")
(2 . "_mid")
(4 . "_cen")
(8 . "_nod")
(16 . "_qua")
(32 . "_int")
;(4096 . "_ext") ; Is not realized
)
) ;_ if
(if (not (zerop (logand (getvar "autosnap") 16)))
'((64 . "_ins")
(128 . "_per")
(256 . "_tan")
(512 . "_nea")
;(1024 . "_qui") ; Is not realized
(2048 . "_app")
;(8192 . "_par") ; Is not realized
)
) ;_ if
) ;_ append
) ;_ substr
) ;_ mapcar
) ;_ defun
(defun osmode-grvecs-lst (/ -ASS ASS COL)
; Function create list
; for drawing icons osmode with the function grvecs
; by Evgeniy Elpanov
; (osmode-grvecs-lst)
(setq
col (atoi (getenv "AutoSnapColor"))
ass (atof (getenv "AutoSnapSize"))
-ass (- ass)
) ;_ setq
(list
(list
"tracking"
col
(list (* -ass 0.2) 0.)
(list (* ass 0.2) 0.)
col
(list 0. (* -ass 0.2))
(list 0. (* ass 0.2))
) ;_ list
(list
"_end"
col
(list -ass -ass)
(list -ass ass)
col
(list (1- -ass) (1- -ass))
(list (1- -ass) (1+ ass))
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list ass ass)
(list ass -ass)
col
(list (1+ ass) (1+ ass))
(list (1+ ass) (1- -ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
(list
"_mid"
col
(list -ass -ass)
(list 0. ass)
col
(list (1- -ass) (1- -ass))
(list 0. (1+ ass))
col
(list 0. ass)
(list ass -ass)
col
(list 0. (1+ ass))
(list (1+ ass) (1- -ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
(list
"_cen"
7
(list (* -ass 0.2) 0.)
(list (* ass 0.2) 0.)
7
(list 0. (* -ass 0.2))
(list 0. (* ass 0.2))
col
(list -ass 0.)
(list (* -ass 0.86) (* ass 0.5))
col
(list (* -ass 0.86) (* ass 0.5))
(list (* -ass 0.5) (* ass 0.86))
col
(list (* -ass 0.5) (* ass 0.86))
(list 0. ass)
col
(list 0. ass)
(list (* ass 0.5) (* ass 0.86))
col
(list (* ass 0.5) (* ass 0.86))
(list (* ass 0.86) (* ass 0.5))
col
(list (* ass 0.86) (* ass 0.5))
(list ass 0.)
col
(list ass 0.)
(list (* ass 0.86) (* -ass 0.5))
col
(list (* ass 0.86) (* -ass 0.5))
(list (* ass 0.5) (* -ass 0.86))
col
(list (* ass 0.5) (* -ass 0.86))
(list 0. -ass)
col
(list 0. -ass)
(list (* -ass 0.5) (* -ass 0.86))
col
(list (* -ass 0.5) (* -ass 0.86))
(list (* -ass 0.86) (* -ass 0.5))
col
(list (* -ass 0.86) (* -ass 0.5))
(list -ass 0.)
) ;_ list
(list
"_nod"
col
(list -ass -ass)
(list ass ass)
col
(list -ass ass)
(list ass -ass)
col
(list -ass 0.)
(list (* -ass 0.86) (* ass 0.5))
col
(list (* -ass 0.86) (* ass 0.5))
(list (* -ass 0.5) (* ass 0.86))
col
(list (* -ass 0.5) (* ass 0.86))
(list 0. ass)
col
(list 0. ass)
(list (* ass 0.5) (* ass 0.86))
col
(list (* ass 0.5) (* ass 0.86))
(list (* ass 0.86) (* ass 0.5))
col
(list (* ass 0.86) (* ass 0.5))
(list ass 0.)
col
(list ass 0.)
(list (* ass 0.86) (* -ass 0.5))
col
(list (* ass 0.86) (* -ass 0.5))
(list (* ass 0.5) (* -ass 0.86))
col
(list (* ass 0.5) (* -ass 0.86))
(list 0. -ass)
col
(list 0. -ass)
(list (* -ass 0.5) (* -ass 0.86))
col
(list (* -ass 0.5) (* -ass 0.86))
(list (* -ass 0.86) (* -ass 0.5))
col
(list (* -ass 0.86) (* -ass 0.5))
(list -ass 0.)
) ;_ list
(list
"_qua"
col
(list 0. -ass)
(list -ass 0.)
col
(list 0. (1- -ass))
(list (1- -ass) 0.)
col
(list -ass 0.)
(list 0. ass)
col
(list (1- -ass) 0.)
(list 0. (1+ ass))
col
(list 0. ass)
(list ass 0.)
col
(list 0. (1+ ass))
(list (1+ ass) 0.)
col
(list ass 0.)
(list 0. -ass)
col
(list (1+ ass) 0.)
(list 0. (1- -ass))
) ;_ list
(list
"_int"
col
(list -ass -ass)
(list ass ass)
col
(list -ass (1+ -ass))
(list ass (1+ ass))
col
(list (1+ -ass) -ass)
(list (1+ ass) ass)
col
(list -ass ass)
(list ass -ass)
col
(list -ass (1+ ass))
(list ass (1+ -ass))
col
(list (1+ -ass) ass)
(list (1+ ass) -ass)
) ;_ list
(list
"_ins"
col
(list (* -ass 0.1) (* -ass 0.1))
(list -ass (* -ass 0.1))
col
(list -ass (* -ass 0.1))
(list -ass ass)
col
(list -ass ass)
(list (* ass 0.1) ass)
col
(list (* ass 0.1) ass)
(list (* ass 0.1) (* ass 0.1))
col
(list (* ass 0.1) (* ass 0.1))
(list ass (* ass 0.1))
col
(list ass (* ass 0.1))
(list ass -ass)
col
(list ass -ass)
(list (* -ass 0.1) -ass)
col
(list (* -ass 0.1) -ass)
(list (* -ass 0.1) (* -ass 0.1))
col
(list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
(list (1- -ass) (1- (* -ass 0.1)))
col
(list (1- -ass) (1- (* -ass 0.1)))
(list (1- -ass) (1+ ass))
col
(list (1- -ass) (1+ ass))
(list (1+ (* ass 0.1)) (1+ ass))
col
(list (1+ (* ass 0.1)) (1+ ass))
(list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
col
(list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
(list (1+ ass) (1+ (* ass 0.1)))
col
(list (1+ ass) (1+ (* ass 0.1)))
(list (1+ ass) (1- -ass))
col
(list (1+ ass) (1- -ass))
(list (1- (* -ass 0.1)) (1- -ass))
col
(list (1- (* -ass 0.1)) (1- -ass))
(list (1- (* -ass 0.1)) (1- (* -ass 0.1)))
) ;_ list
(list
"_tan"
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list -ass 0.)
(list (* -ass 0.86) (* ass 0.5))
col
(list (* -ass 0.86) (* ass 0.5))
(list (* -ass 0.5) (* ass 0.86))
col
(list (* -ass 0.5) (* ass 0.86))
(list 0. ass)
col
(list 0. ass)
(list (* ass 0.5) (* ass 0.86))
col
(list (* ass 0.5) (* ass 0.86))
(list (* ass 0.86) (* ass 0.5))
col
(list (* ass 0.86) (* ass 0.5))
(list ass 0.)
col
(list ass 0.)
(list (* ass 0.86) (* -ass 0.5))
col
(list (* ass 0.86) (* -ass 0.5))
(list (* ass 0.5) (* -ass 0.86))
col
(list (* ass 0.5) (* -ass 0.86))
(list 0. -ass)
col
(list 0. -ass)
(list (* -ass 0.5) (* -ass 0.86))
col
(list (* -ass 0.5) (* -ass 0.86))
(list (* -ass 0.86) (* -ass 0.5))
col
(list (* -ass 0.86) (* -ass 0.5))
(list -ass 0.)
) ;_ list
(list
"_per"
col
(list -ass -ass)
(list -ass ass)
col
(list (1- -ass) (1- -ass))
(list (1- -ass) (1+ ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
col
(list -ass 0.)
(list 0. 0.)
col
(list -ass -1.)
(list 0. -1.)
col
(list 0. 0.)
(list 0. -ass)
col
(list -1. 0.)
(list -1. -ass)
) ;_ list
(list
"_nea"
col
(list -ass -ass)
(list ass ass)
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list -ass ass)
(list ass -ass)
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
(list
"_app"
col
(list -ass -ass)
(list ass ass)
col
(list ass -ass)
(list -ass ass)
col
(list -ass -ass)
(list -ass ass)
col
(list (1- -ass) (1- -ass))
(list (1- -ass) (1+ ass))
col
(list -ass ass)
(list ass ass)
col
(list (1- -ass) (1+ ass))
(list (1+ ass) (1+ ass))
col
(list ass ass)
(list ass -ass)
col
(list (1+ ass) (1+ ass))
(list (1+ ass) (1- -ass))
col
(list ass -ass)
(list -ass -ass)
col
(list (1+ ass) (1- -ass))
(list (1- -ass) (1- -ass))
) ;_ list
;; Is not realized
;; (list
;; "_par"
;; col
;; (list (* -ass 0.8) -ass)
;; (list ass (* ass 0.8))
;; col
;; (list -ass (* -ass 0.8))
;; (list (* ass 0.8) ass)
;; )
) ;_ list
) ;_ defun
(defun c:test (/ GR O OSM-LST OSMODE S TP)
; Example drawing icons osmode with
; Return point, for osmode
; by Evgeniy Elpanov
; (c:test)
(setq osm-lst (osmode-grvecs-lst)
osmode (get_osmode))
(while (or (= (car (setq gr (grread nil 5 0))) 5)
(= (car gr) 11)
(= (car gr) 25) ; For old version AutoCad
)
(if (or (= (car gr) 11)
(= (car gr) 25)
) ;_ or
(setq osmode(list(menu-pop500 gr)))
(progn
(if (setq
o (vl-remove-if
(function null)
(mapcar
(function
(lambda (x / o)
(if (setq o (osnap (cadr gr) x))
(list (distance (cadr gr) o) o x (cadr gr))
) ;_ if
) ;_ lambda
) ;_ function
osmode
) ;_ mapcar
) ;_ vl-remove-if
) ;_ setq
(setq
o (cdar
(vl-sort
o
(function
(lambda (a b)
(< (car a) (car b))
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ cdar
) ;_ setq
) ;_ if
(setq s (/ (getvar "viewsize") (cadr (getvar "SCREENSIZE"))))
(cond
((not o))
((= (cadr o) "_non")(setq tp(redraw)))
((WCMATCH (cadr o) "_end,_mid,_cen,_nod,_int,_ins")
(setq tp (car o))
(setvar "lastpoint" tp)
(setq o (cons (trans (car o) 1 3) (cdr o)))
(redraw)
(grvecs
(cdr (assoc "tracking" osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
(grvecs
(cdr (assoc (cadr o) osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
)
((WCMATCH (cadr o) "_nea,_qua,_app")
(setq o (cons (trans (car o) 1 3) (cdr o)))
(redraw)
(grvecs
(cdr (assoc (cadr o) osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
)
((and tp (not (equal tp (car o) 1e-8)))
(redraw)
(grdraw (car o) tp 7 1)
(setq o (cons (trans (car o) 1 3) (cdr o)))
(grvecs
(cdr (assoc (cadr o) osm-lst))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
)
) ;_ cond
(if tp
(grvecs
(cdr (assoc "tracking" osm-lst))
(list (list s 0. 0. (car (trans tp 1 3)))
(list 0. s 0. (cadr (trans tp 1 3)))
(list 0. 0. s 0.)
'(0. 0. 0. 1.)
) ;_ list
) ;_ grvecs
) ;_ if
) ;_ progn
) ;_ if
) ;_ while
(redraw)
(if o
(osnap (caddr o) (cadr o))
(cadr gr)
) ;_ if
) ;_ defun
(if (vl-catch-all-error-p
(setq me (VL-CATCH-ALL-APPLY
(function vla-item)
(list (setq m (vla-get-menus
(vla-item
(vla-get-menugroups
(vlax-get-acad-object)
) ;_ vla-get-MenuGroups
"ACAD"
) ;_ vla-item
) ;_ vla-get-menus
) ;_ setq
"new_menu_snap"
) ;_ list
) ;_ VL-CATCH-ALL-APPLY
) ;_ setq
) ;_ vl-catch-all-error-p
(setq me (vla-add m "new_menu_snap"))
) ;_ if
(foreach x '((0 "Endpoint" "_end")
(1 "Midpoint" "_mid")
(2 "Intersection" "_int")
(3 "Apparent Intersection" "_app")
(5 "Center" "_cen")
(6 "Quadrant" "_qua")
(7 "Tangent" "_tan")
(9 "PERpendicular" "_per")
(10 "Node" "_nod")
(11 "Insertion" "_ins")
(12 "Nearest" "_nea")
(13 "None" "_non")
)
(vla-AddMenuItem me (car x) (cadr x) (caddr x))
) ;_ foreach
(foreach x '(4 8)
(vla-AddSeparator me x)
) ;_ foreach
(menucmd "p0=+ACAD.new_menu_snap")
(menucmd "p0=*");; get entsel, ss or text
;; CAB 07/30/2006
;; return text or ss
(defun c:test (/ p1 ent ents result)
;; first get entsel, point or text
(while
(if (progn
(prompt "\nSelect objects or enter Layer: ")
(setq p1 (getkeyboard '(0 13) 0 "alpha" nil))
)
(cond
((= (type p1) "TEXT")
nil ; exit
)
((listp p1) ; point
(if (setq ent (nentselp p1))
(setq ents (list (car ent)))
)
nil
)
) ; cond
)
) ; while
(while
(cond
((null p1) nil) ; exit if nothing
((= (type p1) "TEXT")
(setq result p1)
nil ; we are done
)
((listp p1) ; point, so ssget
(prompt "\nSelect objects or enter Layer: ")
(setq p2 (getkeyboard '(0 13) 0 "alpha" p1))
nil
)
) ; cond
) ; while
result
)
;;; FUNCTION
;;; Get keyboard input and return the keys as a string
;;;
;;; ARGUMENTS
;;; ExitList is the list of ascii codes that will cause an exit
;;; #chars number of characters allowed, 0= no limit
;;; $type String type "real" "integer" "alpha"
;;; winPt Window Point - Display a window
;;;
;;; USAGE
;;;
;;;
;;; PLATFORMS
;;; 2000+
;;;
;;; AUTHOR
;;; Charles Alan Butler
;;; ab2draft@TampaBay.rr.com
;;;
;;; VERSION 1.0 Mar 07, 2005
(defun GetKeyboard (ExitList #chars $type winpt / buffer whitespace input space pointok)
;; ExitList is the list of ascii codes that will cause an exit, 0 = point
;; #chars number of characters allowed, 0= no limit
;; $type String type real -real integer -integer alpha
;; -real = allow minus sign
;; Rectangel Get - Stig
;; Honers the right to left solid line & left to right dashed line
;; used in the normal selection method.
(defun getrect (pt / col method pi270 pi90 pt1 track)
(setq pi270 (* 1.5 pi) pi90 (* 0.5 pi))
(while (= 5 (car (setq track (grread T 5 1))))
(redraw)
(setq pt1 (cadr track))
(cond ((>= pi270 (angle pt pt1) pi90)(setq col -256 method "_C"))
((setq col 256 method "_W")))
(grvecs (list col pt (list (car pt) (cadr pt1))
col (list (car pt) (cadr pt1)) pt1
col pt1 (list (car pt1)(cadr pt))
col (list (car pt1)(cadr pt)) pt))
)
(redraw)
;; return point AND selection method
(cond (pt1 (list pt1 method)))
)
(setq space " "
whitespace (strcat "\r" (repeat 80 (setq space (strcat " " space))) "\r" )
)
(if (or (null ExitList) (not (listp ExitList)))
(setq exitList (list 13))
)
(and (vl-position 0 exitlist)
(setq pointok t)
)
(if (or (null #chars) (< #chars 0))
(setq #chars 0) ; unlimited
)
(if (or (null $type)
(not (member (setq $type (strcase $type))
'("REAL" "INTEGER" "ALPHA" "ASCII")
)
)
)
(setq $type "ALPHA")
)
(setq buffer (if (eq $type "ASCII") (list) "" ) )
(while
(progn
(if (eq $type "ASCII")
(princ buffer)
(princ (strcat " " buffer whitespace));(strcat action " " buffer whitespace))
)
(if (or
(if (and pointok WinPt)
(setq input (list 3 (getrect WinPt)))
(and (= (car (setq input (grread 11 2))) 2) ; keyboard entry
(< 31 (setq input (cadr input)) 255) ; a key was pressed
)
)
(and (listp input)
(= (car input) 3) ; point picked
pointok)
)
(cond
((not (print input)) ; print code number to command line
()
)
((member input ExitLst)
(setq buffer (cons buffer input))
nil ; exit loop
)
((and (listp input)
(equal 3 (car input))) ; point picked
(setq buffer nil
input (cadr input))
nil ; exit loop
)
((equal 13 input) ; always exit on ENTER key
(setq buffer (cons buffer input))
nil ; exit loop
)
((equal bspace input) ; BS backspace <--<<
(or (and (eq $type "ASCII")
(> (length buffer) 0)
(setq buffer (reverse (cdr (reverse buffer))))
)
(and (/= buffer "")
(setq buffer (substr buffer 1 (- (strlen buffer) 1)))
)
(setq action nil) ; exit
)
) ; end BackSpace
((and (wcmatch $type "*REAL")
(member input '(45 46 48 49 50 51 52 53 54 55 56 57))
)
(if (= input 45)
(if (and (= $type "-REAL") (= buffer ""))
(setq buffer "-")
)
(setq buffer (strcat buffer (chr input)))
)
(if (and (> #chars 0)
(= #chars (strlen buffer))
)
(setq input nil) ; exit
)
) ;end REAL
((and (wcmatch $type "*INTEGER")
(member input '(45 48 49 50 51 52 53 54 55 56 57))
)
(if (= input 45)
(if (and (= $type "-INTEGER") (= buffer ""))
(setq buffer "-")
)
(setq buffer (strcat buffer (chr input)))
)
(if (and (> #chars 0)
(= #chars (strlen buffer))
)
(setq input nil) ; exit
)
) ; end INTEGET
((and (eq $type "ALPHA") (< 31 input 126))
(setq buffer (strcat buffer (chr input)))
) ; end ALPHA
((eq $type "ASCII")
(if buffer
(setq buffer (cons buffer input))
(setq buffer (list input))
)
(if (and (> #chars 0)
(= #chars (length buffer))
)
(setq input nil) ; exit
)
) ; end ASCII
) ; end cond stmt
t ; stay in loop
) ; endif
) ; progn
) ; end while
;; return value ( string [exit key]) or [exit key]
(if buffer
(cons buffer input)
input
)
)
;*****************************************************************************
; INSPECTOR - Command to Inspect Objects by Moving the Crosshairs Over Them. *
; ========= *
; Didge, 2006. *
;*****************************************************************************
(defun C:INSPECTOR (/ INPUT INPUT_COORD ENTITY_FOUND ENTITY_NAME ENTITY_LIST ENTITY_TYPE ENTITY_LAYER)
(prompt "\nMove Crosshairs To Inspect Objects.")
(while (and (setq INPUT (grread T)) (= (car INPUT) 5))
(setq INPUT_COORD (cadr INPUT))
(setq ENTITY_FOUND (ssget INPUT_COORD))
(if ENTITY_FOUND
(progn
(setq ENTITY_LIST (entget (ssname ENTITY_FOUND 0)))
(setq ENTITY_TYPE (cdr (assoc 0 ENTITY_LIST)))
(setq ENTITY_LAYER (cdr (assoc 8 ENTITY_LIST)))
(prompt (strcat "\rObject: " ENTITY_TYPE " Layer: " ENTITY_LAYER " "))
)
)
)
(princ)
)
Here's a simple use of GRREAD, this code will display an entity's Type & Layer on the command line as the crosshairs are moved across the screen. Changing the "assoc" code however will allow just about any property to be displayed.
Ironically, this routine was originally called INSPECT, but having just typed that at the command line I've just noticed an existing acad command by the same name that does exactly the same thing (albeit better) as this one. Thats my new piece of knowledge gathered for today :-)
I did have a small maze type game that utilised this same function, the user had to navigate around a maze using the mouse against the clock without crashing into the walls and certain objects etc.
I've renamed the variables to something a little more informative.Code: [Select];*****************************************************************************
; INSPECTOR - Command to Inspect Objects by Moving the Crosshairs Over Them. *
; ========= *
; Didge, 2006. *
;*****************************************************************************
(defun C:INSPECTOR (/ INPUT INPUT_COORD ENTITY_FOUND ENTITY_NAME ENTITY_LIST ENTITY_TYPE ENTITY_LAYER)
(prompt "\nMove Crosshairs To Inspect Objects.")
(while (and (setq INPUT (grread T)) (= (car INPUT) 5))
(setq INPUT_COORD (cadr INPUT))
(setq ENTITY_FOUND (ssget INPUT_COORD))
(if ENTITY_FOUND
(progn
(setq ENTITY_LIST (entget (ssname ENTITY_FOUND 0)))
(setq ENTITY_TYPE (cdr (assoc 0 ENTITY_LIST)))
(setq ENTITY_LAYER (cdr (assoc 8 ENTITY_LIST)))
(prompt (strcat "\rObject: " ENTITY_TYPE " Layer: " ENTITY_LAYER " "))
)
)
)
(princ)
)
(defun c:perp (/ ent dep deriv ang loop per gr pe str)
(vl-load-com)
(if (and
(setq ent (car (entsel)))
(setq dep (trans (getpoint "\nStart point of the perpendicular line:") 1 0))
(not (vl-catch-all-error-p
(setq deriv (vl-catch-all-apply
'vlax-curve-getFirstDeriv
(list ent
(vlax-curve-getParamAtPoint ent dep)
)
)
)
)
)
)
(progn
(entmake (list '(0 . "LINE")
(cons 10 dep)
(cons 11 dep)
)
)
(setq per (entlast)
ang (angle '(0 0 0) deriv)
loop T
)
(princ "\nSpecify line length: ")
(while (and (setq gr (grread T 12 0)) (/= (car gr) 3) loop)
(cond
((= (car gr) 5)
(setq
pe (polar
dep
(if (minusp (sin (- (angle dep (cadr gr)) ang)))
(- ang (/ pi 2))
(+ ang (/ pi 2))
)
(distance dep (cadr gr))
)
)
(entmod
(subst (cons 11 (trans pe 1 0))
(assoc 11 (entget per))
(entget per)
)
)
(grtext -1 (rtos (distance dep (cadr gr))))
)
((member (cadr gr) '(13 32))
(if (and str (numberp (read str)))
(progn
(entmod
(subst
(cons
11
(trans (polar dep (angle dep pe) (distof str)) 1 0)
)
(assoc 11 (entget per))
(entget per)
)
)
(setq loop nil)
)
(progn
(princ
"\nNeeds a valid number or a screen pointing.
\nSpecify line length: "
)
(setq str "")
)
)
)
(T
(if (= (cadr gr) 8)
(or
(and str
(/= str "")
(setq str (substr str 1 (1- (strlen str))))
(princ (chr 8))
(princ (chr 32))
)
(setq str nil)
)
(or
(and str (setq str (strcat str (chr (cadr gr)))))
(setq str (chr (cadr gr)))
)
)
(and str (princ (chr (cadr gr))))
)
)
)
)
)
(princ)
)
(defun tsterr (s)
(if (= s "Function cancelled")
(princ "\n*Cancelled*")
(princ s)
)
(mapcar '(lambda (x) (if (numberp x) (princ) (vlax-release-object x))) ty)
(setq *error* oe)
(princ)
)
(defun okd_k (a / okd_lm)
(mapcar
'(lambda (x)
(cond ((= x 3) (setq okd_lm (append okd_lm (list 94 67))))
((= x 16) (setq okd_lm (append okd_lm (list 94 80))))
((= x 10) (setq okd_lm (append okd_lm (list 59))))
(T (setq okd_lm (append okd_lm (list x))))
)
)
a)
(vl-list->string okd_lm)
)
(defun lod_m (a / loc_ac loc_cn loc_lb loc_lg loc_lm loc_lp loc_mb loc_mg loc_nm loc_tt)
(setq loc_mg (vla-get-menugroups a)
loc_mb (vla-get-menubar a)
loc_cn 0
)
(vlax-for it loc_mg
(setq loc_lm (cons (vla-get-menus it) loc_lm)
loc_nm (cons (vla-get-menufilename it) loc_nm)
loc_tt (cons (abs (1- (vla-get-type it))) loc_tt))
)
(mapcar
'(lambda (x)
(vlax-for it x
(if (= :vlax-true (vla-get-onmenubar it))
(setq loc_lg (cons (vla-get-name it) loc_lg)
loc_lp (append (list (vl-position x loc_lm)) loc_lp))
)
)
)
loc_lm
)
(vlax-for it loc_mb
(setq loc_lb (cons (cons loc_cn (vla-get-name it)) loc_lb)
loc_cn (1+ loc_cn))
)
(vlax-release-object loc_mb)
(gc)
(setq loc_nm (reverse loc_nm) loc_tt (reverse loc_tt))
(vlax-map-collection loc_mg 'vla-unload)
(mapcar '(lambda (x y) (vla-load loc_mg x y)) loc_nm loc_tt)
(vlax-release-object loc_mg)
(gc)
(setq loc_mg (vla-get-menugroups a)
loc_mb (vla-get-menubar a))
(vlax-for it loc_mg (setq loc_lm (cons (vla-get-menus it) loc_lm)))
(mapcar
'(lambda (x / mx pm)
(setq pm (vla-item (setq mx (nth (nth (vl-position (cdr x) loc_lg) loc_lp) loc_lm)) (cdr x)))
(if (= :vlax-false (vla-get-onmenubar pm))
(vla-insertmenuinmenubar mx (cdr x) (car x))
)
)
loc_lb)
(list loc_mb loc_mg)
)
(defun prn_a (a b / nm pp pr ps)
(setq pr (vla-get-parent a)
nm (vla-get-name pr)
)
(if (= nm "")
(progn
(setq ps (vla-get-parent (vla-get-parent pr)))
(if (= :vlax-true (vla-get-shortcutmenu ps))
(setq pp
(strcat "SHORTCUT MENU:"
"\n->NAME:\t"
(vla-get-namenomnemonic ps)
"\n[-------]"
)
)
(setq pp
(strcat "POP MENU ON BAR:"
"\n->NAME:\t"
(vla-get-namenomnemonic ps)
"\n[-------]"
)
)
)
(setq pp
(strcat pp
"\nSUBMENU:"
"\n->NAME:\t"
(vl-list->string
(vl-remove 38
(vl-string->list
(vla-get-caption
(vla-get-parent pr)
)
)
)
)
"\n[-------]\nPOP MENU ITEM:\nGRREAD Nº:\t"
(itoa b)
"\n->CAPTION:\t"
(vl-list->string
(vl-remove 38
(vl-string->list
(vla-get-caption a)
)
)
)
"\n->HELPSTRING:\t"
(vla-get-helpstring a)
"\n->MACRO:\t"
(okd_k (vl-string->list (vla-get-macro a)))
"\n->TAGSTRING:\t"
(vla-get-tagstring a)
)
)
)
(progn
(if (= :vlax-true (vla-get-shortcutmenu pr))
(setq pp
(strcat "SHORTCUT MENU:"
"\n->NAME:\t"
(vla-get-namenomnemonic pr)
"\n[-------]"
)
)
(setq pp
(strcat "POP MENU ON BAR:"
"\n->NAME:\t"
(vla-get-namenomnemonic pr)
"\n[-------]"
)
)
)
(setq pp
(strcat pp
"\nPOP MENU ITEM:\nGRREAD Nº:\t"
(itoa b)
"\n->CAPTION:\t"
(vl-list->string
(vl-remove 38
(vl-string->list
(vla-get-caption a)
)
)
)
"\n->HELPSTRING:\t"
(vla-get-helpstring a)
"\n->MACRO:\t"
(okd_k (vl-string->list (vla-get-macro a)))
"\n->TAGSTRING:\t"
(vla-get-tagstring a)
)
)
)
)
(alert pp)
)
(defun prn_b (a b / nm pp pr)
(setq pr (vla-get-parent a)
nm (vla-get-name pr)
pp (strcat "TOOL BAR:"
"\n->NAM:\t"
nm
"\n[-------]"
"\nTOOL BAR ITEM:\nGRREAD Nº:\t"
(itoa b)
"\n->NAME:\t\t"
(vla-get-name a)
"\n->HELPSTRING:\t"
(vla-get-helpstring a)
"\n->MACRO:\t"
(okd_k (vl-string->list (vla-get-macro a)))
"\n->TAGSTRING:\t"
(vla-get-tagstring a)
)
)
(alert pp)
)
(defun fna_j (a / ax cn ll)
(setq ax (vlax-invoke-method a 'getelementsbytagname "ImageMenu"))
(if (zerop (vlax-get-property ax 'length))
(vlax-get-property ax 'item 0)
(progn
(setq cn 0)
(while (> (vlax-get-property ax 'length) cn)
(setq ll (append ll (list (vlax-get-property ax 'item cn))) cn (1+ cn))
)
ll
)
)
)
(defun fnb_j (a / ax)
(setq ax (vlax-get-property (vlax-invoke-method a 'getelementsbytagname "Alias") 'item 0))
(if (null ax)
(setq lb (append lb (list a)))
(setq la (append la (list a)))
)
)
(defun fnc_j (a / ax cn ln lo oa)
(if (= :vlax-true (vlax-invoke-method a 'haschildnodes))
(progn
(setq cn 0
ax (vlax-get-property a 'childnodes)
ln (vlax-get-property ax 'length))
(while (> ln cn)
(setq oa (vlax-get-property ax 'item cn) cn (1+ cn))
(if (= (vlax-get-property oa 'nodename) "ImageMenuItem")
(setq lo (append lo (list oa)))
)
)
)
)
lo
)
(defun get_j (a / dc la lb lc)
(vl-load-com)
(vlax-invoke-method
(setq dc (vlax-create-object "MSXML.DOMDocument"))
'load
a
)
(mapcar 'fnb_j (fna_j dc))
(setq lc (mapcar 'length (mapcar 'fnc_j la)))
(mapcar 'vlax-release-object la)
(mapcar 'vlax-release-object lb)
(vlax-release-object dc)
(gc)
lc
)
(defun get_aa (a / cn ct it lx ty)
(setq ct (vla-get-count a) cn 0)
(repeat ct
(setq it (vlax-invoke-method a 'item cn)
ty (vla-get-type it)
cn (1+ cn))
(if (zerop ty)
(setq lx (append lx (list it)))
(if (= ty 2)
(setq lx (append lx (get_aa (vla-get-submenu it))))
)
)
)
(vl-remove-if
(function
(lambda (x)
(or (= (vla-get-macro x) "")
(wcmatch (vla-get-macro x) "*quit*")
(wcmatch (vla-get-macro x) "*closeall*")
(wcmatch (vla-get-macro x) "*syswindows*")
)
)
)
lx)
)
(defun get_ab (a / cn ct it lx ty)
(setq ct (vla-get-count a) cn 0)
(repeat ct
(setq it (vlax-invoke-method a 'item cn)
ty (vla-get-type it)
cn (1+ cn))
(if (zerop ty)
(setq lx (append lx (list it)))
(if (= ty 2)
(setq lx (append lx (get_ab (vla-get-submenu it))))
)
)
)
(vl-remove-if
(function
(lambda (x)
(or (= (vla-get-macro x) "")
(wcmatch (vla-get-macro x) "*_closeall*")
(wcmatch (vla-get-macro x) "*syswindows*")
)
)
)
lx)
)
(defun get_b (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
ll
)
(defun get_i (a / ax fi fs li lx)
(if (findfile (setq fs (vl-string-subst ".mns" ".mnc" a)))
(progn
(setq ax 0
fi (open fs "r"))
(while (/= (read-line fi) "***IMAGE") (princ))
(while (/= (substr (setq li (read-line fi)) 1 3) "***")
(cond ((wcmatch li "`*`**")
(if (zerop ax)
(princ)
(setq lx (append lx (list ax)) ax 0))
)
((wcmatch li "*(*,*)*") (setq ax (1+ ax)))
(T (princ))
)
)
(close fi)
(setq lx (append lx (list ax)))
)
(progn
(setq fi (reverse (vl-string->list fs)))
(while (/= (car fi) 92)
(setq lx (cons (car fi) lx) fi (cdr fi))
)
(alert (strcat "Couldn't find source menu for \"" (vl-list->string lx) "\"\nSorry, I can't follow"))
(exit)
)
)
)
(defun get_s (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
(vl-remove-if '(lambda (x) (= :vlax-false (vla-get-shortcutmenu x))) ll)
)
(defun get_t (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
)
(defun get_u (a / it ll)
(vlax-for it a (setq ll (append ll (list it))))
(vl-remove-if '(lambda (x)
(or
(= :vlax-true (vla-get-shortcutmenu x))
(= :vlax-true (vla-get-onmenubar x)))
)
ll)
)
(defun rng_a (a b / ax ll lm)
(setq lm a
ll (list (list (1+ b) (+ b (car lm))))
lm (cdr lm))
(while lm
(setq ax (cadr (last ll))
ll (append ll (list (list (1+ ax) (+ (car lm) ax))))
lm (cdr lm))
)
ll
)
(defun scm_a (a b c / ax cp gt nt)
(if (member a '(1000 2000 3000))
(progn
(grread T 2)
(menucmd "P0=POP0")
(menucmd "P0=*")
)
(setq ax (if (zerop a) nil a))
)
(if ax
(progn
(setq nt
(vl-position
'T
(mapcar
'(lambda (x)
(if
(and
(>= ax (car x))
(<= ax (cadr x))
)
(numberp (setq gt (- ax (car x))))
nil)
)
b)
)
)
(if
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-get-onmenubar (list (nth nt c))))
(prn_b (nth gt (get_b (nth nt c))) a)
(prn_a
(nth gt
(if (< (atof (substr (getvar "ACADVER") 1 4)) 16.2)
(get_aa (nth nt c))
(get_ab (nth nt c))
)
)
a)
)
)
)
)
(defun tst_g (/ aa ab ac ad ae ao it lg li lp ls lt lu lx ly mb mg)
(setq mg (vla-get-menugroups (vlax-get-acad-object))
lg (reverse (vlax-for it mg (setq lg (cons it lg)))))
(mapcar '(lambda (x) (setq ls (append (get_s x) ls))) (mapcar 'vla-get-menus lg))
(if (> (length ls) 1)
(progn
(mapcar 'vlax-release-object ls)
(mapcar 'vlax-release-object lg)
(vlax-release-object mg)
(gc)
(setq ao (lod_m (vlax-get-acad-object))
mb (car ao)
mg (cadr ao)
lg nil
ls nil)
(vlax-for it mg (setq lg (append lg (list it))))
(vlax-for it mb (setq lp (append lp (list it))))
(mapcar '(lambda (x) (setq ls (append ls (get_s x)))) (mapcar 'vla-get-menus lg))
(terpri)
(terpri)
)
(progn
(setq mb (vla-get-menubar (vlax-get-acad-object)))
(vlax-for it mb (setq lp (append lp (list it))))
)
)
(if (< (atof (substr (getvar "ACADVER") 1 4)) 16.2)
(progn
(setq li (apply 'append (mapcar '(lambda (x) (get_i (vla-get-menufilename x))) lg)))
(mapcar '(lambda (x) (setq lt (append lt (get_t x)))) (mapcar 'vla-get-toolbars lg))
(mapcar '(lambda (x) (setq lu (append lu (get_u x)))) (mapcar 'vla-get-menus lg))
(setq aa (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) ls) 499)
ab (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) lp) (cadr (last aa)))
ac (rng_a li (cadr (last ab)))
ad (rng_a (mapcar (function (lambda (x) (length (get_b x)))) lt) (cadr (last ac)))
ae (rng_a (mapcar (function (lambda (x) (length (get_aa x)))) lu) (cadr (last ad)))
lx (append aa ab ac ad ae)
ly (append ls lp li lt lu)
)
)
(progn
(setq li (apply 'append (mapcar '(lambda (x) (get_j (vla-get-menufilename x))) lg)))
(mapcar '(lambda (x) (setq lt (append lt (get_t x)))) (mapcar 'vla-get-toolbars lg))
(mapcar '(lambda (x) (setq lu (append lu (get_u x)))) (mapcar 'vla-get-menus lg))
(setq aa (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) ls) 499)
ab (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) lp) (cadr (last aa)))
ac (rng_a li (cadr (last ab)))
ad (rng_a (mapcar (function (lambda (x) (length (get_b x)))) lt) (cadr (last ac)))
ae (rng_a (mapcar (function (lambda (x) (length (get_ab x)))) lu) (cadr (last ad)))
lx (append aa ab ac ad ae)
ly (append ls lp li lt lu)
)
)
)
(vlax-release-object mb)
(vlax-release-object mg)
(gc)
(list lx ly)
)
(defun C:TESTG (/ gr oe ts tx ty op sc)
(vl-load-com)
(if
(zerop (getvar "SHORTCUTMENU"))
(progn
(grread t 2)
(setq sc 12)
)
(setq sc 25)
)
(setq ts (tst_g)
tx (car ts)
ty (cadr ts)
oe *error*
*error* tsterr
)
(while (null op)
(setq gr (grread T 13))
(if (/= (car gr) 5) (setq pl (cons gr pl)))
(princ "\rCommand: Menu items evaluation: ")
(if (= (car gr) 11)
(progn
(scm_a (cadr gr) tx ty)
(princ "...Done!")
(terpri)
)
(if (or (= (car gr) sc) (and (= (car gr) 2) (= (cadr gr) 13)))
(progn
(princ "...I'm quitting")
(setq op T)
)
)
)
)
(mapcar '(lambda (x) (if (numberp x) (princ) (vlax-release-object x))) ty)
(gc)
(princ)
)
(princ "\nType TESTG to begin...")
(defun c:cam4 (/ *ERROR* STRBRK FOO1 FOO2
ANG BLG C1 CEN CEN2 CODE DATA DELTA DIS
EN GR IANG LEN LST POLY RAD RAD1 RAD2 TAN)
;; by Lee McDonnell (Lee Mac) ~ 19.12.2009
(vl-load-com)
(defun *error* (msg)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun StrBrk (str chrc / pos lst)
(while (setq pos (vl-string-position chrc str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 2))))
(reverse (cons str lst)))
(if (setq cen (getpoint "\nPick Center of First Radius: "))
(progn
(setq poly (entmakex
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 2)
(cons 70 1)
(cons 10 cen)
(cons 10 (polar cen 0 1.))))
en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse (entget poly)))))
(defun foo1 nil (setq str "")
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond ( (and (= 5 code) (listp data))
(setq rad2 (distance cen2 data) delta (- rad rad2))
(if (< (abs delta) len)
(progn
(setq tan (sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
blg2 (/ (sin (* 0.5 iAng)) (cos (* 0.5 iAng))))
(entmod
(append en
(list
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg1)
(cons 10 (polar cen (- ang iAng) rad))
(cons 10 (polar cen2 (- ang iAng) rad2))
(cons 42 blg2)
(cons 10 (polar cen2 (+ ang iAng) rad2)))))) t))
( (and (= 3 code) (listp data))
(setq rad2 (distance cen2 data) delta (- rad rad2))
(if (< (abs delta) len)
(progn
(setq tan (sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
blg2 (/ (sin (* 0.5 iAng)) (cos (* 0.5 iAng))))
(entmod
(append en
(list
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg1)
(cons 10 (polar cen (- ang iAng) rad))
(cons 10 (polar cen2 (- ang iAng) rad2))
(cons 42 blg2)
(cons 10 (polar cen2 (+ ang iAng) rad2))))) nil)))
( (= 2 code)
(cond ( (or (= data 46) (< 47 data 58))
(setq str (strcat str (princ (chr data)))))
( (and (< 0 (strlen str)) (= 8 data))
(setq str (substr str 1 (1- (strlen str))))
(princ (vl-list->string '(8 32 8))))
( (vl-position data '(32 13))
(cond ( (zerop (strlen str)) t)
( (and (setq tmp (distof str)) (not (zerop tmp)))
(setq data (polar cen2 0 tmp) rad2 (distance cen2 data)
delta (- rad rad2))
(if (< (abs delta) len)
(progn
(setq tan (sqrt (- (* len len) (* delta delta))) iAng (atan tan delta)
blg1 (/ (sin (* 0.5 (- pi iAng))) (cos (* 0.5 (- pi iAng))))
blg2 (/ (sin (* 0.5 iAng)) (cos (* 0.5 iAng))))
(entmod
(append en
(list
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg1)
(cons 10 (polar cen (- ang iAng) rad))
(cons 10 (polar cen2 (- ang iAng) rad2))
(cons 42 blg2)
(cons 10 (polar cen2 (+ ang iAng) rad2))))) nil)))
(t (setq str "")
(princ (strcat "\n** Invalid Input **" msg)))))
(t )))
(t )))))
(defun foo2 nil (setq str "")
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond ( (and (= 5 code) (listp data))
(setq dis (distance cen data) ang (angle cen data))
(if (< rad dis)
(progn
(setq tan (sqrt (- (* dis dis) (* rad rad)))
iAng (atan tan rad)
blg (/ (sin (* 0.5 (- pi iAng)))
(cos (* 0.5 (- pi iAng)))))
(entmod
(append en
(setq lst
(list
(cons 10 data)
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg)
(cons 10 (polar cen (- ang iAng) rad))))))) t))
( (and (= 3 code) (listp data))
(setq dis (distance cen data) ang (angle cen data))
(if (< rad dis)
(progn
(setq tan (sqrt (- (* dis dis) (* rad rad)))
iAng (atan tan rad)
blg (/ (sin (* 0.5 (- pi iAng)))
(cos (* 0.5 (- pi iAng)))))
(setq en
(append en
(list
(cons 10 data)
(cons 10 data)
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg)
(cons 10 (polar cen (- ang iAng) rad)))))
(setq en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 4) (assoc 90 en) en)))))
cen2 data len (distance cen cen2) ang (angle cen cen2))
(setq msg (princ "\nPick Second Radius: "))
(foo1))))
( (= 2 code)
(cond ( (or (vl-position data '(44 46)) (< 47 data 58))
(setq str (strcat str (princ (chr data)))))
( (and (< 0 (strlen str)) (= 8 data))
(setq str (substr str 1 (1- (strlen str))))
(princ (vl-list->string '(8 32 8))))
( (vl-position data '(32 13))
(cond ( (zerop (strlen str)) t)
( (apply (function and)
(setq tmp
(mapcar (function distof) (StrBrk str 44))))
(setq data tmp dis (distance cen data) ang (angle cen data))
(if (< rad dis)
(progn
(setq tan (sqrt (- (* dis dis) (* rad rad)))
iAng (atan tan rad)
blg (/ (sin (* 0.5 (- pi iAng)))
(cos (* 0.5 (- pi iAng)))))
(setq en
(append en
(list
(cons 10 data)
(cons 10 data)
(cons 10 (polar cen (+ ang iAng) rad))
(cons 42 blg)
(cons 10 (polar cen (- ang iAng) rad)))))
(setq en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 4) (assoc 90 en) en)))))
cen2 data len (distance cen cen2) ang (angle cen cen2))
(setq msg (princ "\nPick Second Radius: "))
(foo1))))
(t (setq str "")
(princ (strcat "\n** Invalid Input **" msg)))))
(t )))
(t )))))
(setq msg (princ "\nPick First Radius: ")) (setq str "")
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond ( (and (= 5 code) (listp data))
(setq data (trans data 1 0) ang (angle cen data)
dis (distance cen data))
(entmod
(append en
(setq lst
(list
(cons 10 data)
(cons 42 1.)
(cons 10 (polar data (+ ang pi) (* 2. dis)))
(cons 42 1.))))))
( (and (= 3 code) (listp data))
(setq data (trans data 1 0))
(setq en
(append en
(setq lst
(list
(cons 10 data)
(cons 42 1.)
(cons 10 (polar data (+ ang pi) (* 2. dis)))
(cons 42 1.)
(cons 10 data))))
en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 3) (assoc 90 en) en)))))
rad (distance cen data))
(princ (setq msg "\nPick Center of Second Radius: "))
(foo2))
( (= code 2)
(cond ( (or (= data 46) (< 47 data 58))
(setq str (strcat str (princ (chr data)))))
( (and (< 0 (strlen str)) (= 8 data))
(setq str (substr str 1 (1- (strlen str))))
(princ (vl-list->string '(8 32 8))))
( (vl-position data '(32 13))
(cond ( (zerop (strlen str)) t)
( (and (setq tmp (distof str))
(not (zerop tmp)))
(setq data (polar cen 0 tmp))
(setq en
(append en
(setq lst
(list
(cons 10 data)
(cons 42 1.)
(cons 10 (polar data (+ ang pi) (* 2. dis)))
(cons 42 1.)
(cons 10 data))))
en (reverse
(vl-member-if
(function
(lambda (x)
(= 39 (car x))))
(reverse
(entmod
(subst (cons 90 3) (assoc 90 en) en)))))
rad (distance cen data))
(setq msg (princ "\nPick Center of Second Radius: "))
(foo2))
(t (setq str "")
(princ (strcat "\n** Invalid Input **" msg)))))
(t )))
(t ))))))
(princ))
a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "
Regards
Kerry
a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "
Regards
Kerry
Apologies Kerry, post updated. :oops:
Hi Lee Mac
nice work! :-D
I have a suggestion: You can enter a numeric value of the radius increased!
a description of what it's 'sposed to do would be handy.
... and that first prompt confuses me "\nPick Center of First Radius: "
Regards
Kerry
Apologies Kerry, post updated. :oops:
No apologies needed :)
... just thinking of those following who may not be able to grasp intent from the code.
;;;by:lihuili 2009-12-20
;;;Dynamic drawing a line to another line perpendicular bisector
(defun Perp_bisector_line (/ ent en pt enname
p1 p2 ang ptemp1 p0 pt1
sp source ptemp ptemp1 ptemp2 ptemp3
pt1 pt2 pt3 loop
)
(setvar "cmdecho" 0)
(if (and (setq ent (car (entsel "\n select a line.")))
(= (cdr (assoc 0 (setq en (entget ent)))) "LINE")
)
(progn
(redraw ent 3)
(setq p1 (trans (cdr (assoc 10 en)) 0 1)
p2 (trans (cdr (assoc 11 en)) 0 1)
ang (angle p1 p2)
)
(setq p0 (polar p1 ang (* 0.5 (distance p1 p2)))
lineobj (vla-addLine
(vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(vlax-3d-point p0)
(vlax-3d-point p0)
)
)
(setq ptemp1 (polar p0 (+ ang (* 0.5 pi)) 10))
(prompt "\n to:")
(setq loop t
ptemp p0
pt1 p0
)
(while loop
(setq sp (grread t))
(setq source (car sp)
sp (cadr sp)
)
(cond ((= source 5)
(setq ptemp sp)
(setq ptemp2 (polar sp 0 10)
ptemp3 (polar sp (* 0.5 pi) 10)
)
(setq pt2 (inters p0 ptemp1 sp ptemp2 nil))
(setq pt3 (inters p0 ptemp1 sp ptemp3 nil))
(cond ((null pt2) (setq pt1 pt3))
((null pt3) (setq pt1 pt2))
(t
(if (< (distance sp pt2) (distance sp pt3))
(setq pt1 pt2)
(setq pt1 pt3)
)
)
)
(vla-put-EndPoint lineobj (vlax-3d-point pt1))
)
(t (setq loop nil))
)
)
(redraw ent 4)
)
(prompt "\n No select a line!")
)
(princ)
)
(defun c:test ()
(Perp_bisector_line)
)
;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
(defun c:LPer (/ #Ent #Read)
(and
(setq #Ent (car (entsel "\nSelect curve: ")))
(vl-position (cdr (assoc 0 (entget #Ent))) '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE"))
(while (not (eq 25 (car (setq #Read (grread T 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (cadr #Read))
(grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
(trans (cadr #Read) 1 0)
1
) ;_ grdraw
) ;_ if
(if (eq 3 (car #Read))
(entmake (list '(0 . "LINE")
(cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(cons 11 (trans (cadr #Read) 1 0))
) ;_ list
) ;_ entmake
) ;_ if
) ;_ while
) ;_ and
(redraw)
(princ)
) ;_ defun
Hi，alanjt:) Thanks
nice work！
Your program can add to the block processing，In other words, be able to select block.
Don't flame me too bad... I know, no code, but here is a animation of what it does....
No, the vlax-curve... functions don't work on blocks.so, we will cheat a little :)
(defun c:LPer (/ #Ent #Read *error*)
(defun *error* (msg) (and #Ent (entdel #Ent)) (princ msg))
(and
(setq #Ent (nentselp "\nSelect curve: "))
(vl-position (cdr (assoc 0 (entget (car #Ent))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
)
(setq #Read (caddr #Ent)
#Ent (entmakex (append (entget (car #Ent)) (list (cons 60 1))))
)
(or (not #Read)
(not (vla-transformby (vlax-ename->vla-object #Ent) (vlax-tmatrix #Read)))
)
(not
(while (not (eq 25 (car (setq #Read (grread T 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (cadr #Read))
(grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
(trans (cadr #Read) 1 0)
1
)
)
(if (eq 3 (car #Read))
(entmake
(list '(0 . "LINE")
(cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(cons 11 (trans (cadr #Read) 1 0))
)
)
)
)
)
(entdel #Ent)
)
(redraw)
(princ)
)
No, the vlax-curve... functions don't work on blocks.so, we will cheat a little :)Code: [Select](defun c:LPer (/ #Ent #Read *error*)
(defun *error* (msg) (and #Ent (entdel #Ent)) (princ msg))
(and
(setq #Ent (nentselp "\nSelect curve: "))
(vl-position (cdr (assoc 0 (entget (car #Ent))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
)
(setq #Read (caddr #Ent)
#Ent (entmakex (append (entget (car #Ent)) (list (cons 60 1))))
)
(or (not #Read)
(not (vla-transformby (vlax-ename->vla-object #Ent) (vlax-tmatrix #Read)))
)
(not
(while (not (eq 25 (car (setq #Read (grread T 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (cadr #Read))
(grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
(trans (cadr #Read) 1 0)
1
)
)
(if (eq 3 (car #Read))
(entmake
(list '(0 . "LINE")
(cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(cons 11 (trans (cadr #Read) 1 0))
)
)
)
)
)
(entdel #Ent)
)
(redraw)
(princ)
)
;;;GET SINGLE LETTER RESPONSE WITH OUT ENTER
;;;USEAGE (getsltr '("Y" "N"))
(defun getsltr (al / in cl)
(foreach a al
(setq cl (cons (ascii (strcase a t)) cl)
cl (cons (ascii (strcase a)) cl)))
(while (not (member in cl))
(princ "\n")
(prin1 al)
(princ ": ")
(setq in (cadr (grread))))
(strcase (chr in)))(defun c:lpers (/ *error* #ent #read clpt clr el ent lname pt x)
(defun *error* (msg) (and #ent (mapcar 'entdel #ent)) (princ msg))
(and
(setq #ent (nentselp "\nSelect curve: "))
(vl-position
(cdr (assoc 0 (setq el (entget (car #ent)))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
)
(setq clr (cdr (assoc 62 (entget (tblobjname "layer" (cdr (assoc 8 el)))))))
(setq lname (cdr (assoc 8 el)))
(setq #read (caddr #ent)
#ent (entmakex (append (entget (car #ent)) (list (cons 60 1))))
)
(or (not #read)
(not (vla-transformby (vlax-ename->vla-object #ent) (vlax-tmatrix #read)))
)
(setq #ent (list #ent))
(not
(while (not (eq 2 (car (setq #read (grread t 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (setq pt (cadr #read)))
(progn
(setq ent
(car
(mapcar
'cdr
(vl-sort
(mapcar '(lambda (x)
(cons (distance (setq pt (trans (cadr #read) 1 0))
(setq clpt (vlax-curve-getclosestpointto
x
(trans (cadr #read) 1 0)
)
)
)
x
)
)
#ent
)
(function (lambda (d1 d2) (< (car d1) (car d2))))
)
)
)
)
(grdraw (setq clpt (setq clpt (vlax-curve-getclosestpointto ent pt))) pt clr)
)
)
(if (eq 3 (car #read))
(setq
#ent (cons (entmakex
(list '(0 . "LINE") (cons 8 lname) (cons 10 clpt) (cons 11 pt))
)
#ent
)
)
)
)
)
)
(redraw)
(princ)
)
(defun c:bored (/ cir cnt gr lst n d)
(setq lst (list (getvar 'viewctr) (getvar 'viewctr)) cnt 0)
(while (eq 5 (car (setq gr (grread nil 5 1))))
(redraw)
(setq cir nil n 0 lst (append lst (list (last lst) (cadr gr))) cnt (1+ cnt))
(if (< 100 cnt) (setq lst (cddr lst)))
(repeat 50 (setq d (/ (distance (car lst) (last lst)) 4.))
(repeat 4
(setq cir (cons (polar (car lst)
(* (setq n (1+ n)) (/ (* pi 2) 50)) d) cir))
(setq d (/ d 2.))))
(grvecs (append (list (rem (/ cnt 100) 255)) lst cir)))
(princ))
(defun c:test (/ grr ent entlist inp pt1 pt2)
;;
;;
(defun MkLine (p1 p2)
(entmakex (list (cons 0 "LINE")
(cons 10 p1)
(cons 11 p2)
) ;_ list
) ;_ entmakex
) ;_ defun
;;
;;
(if
(and
(setq pt1 (getpoint "\n>>>...Pick Points...>>>: "))
(setq pt2 (getpoint pt1))
(setq ent (mkline pt1 pt2))
(setq entlist (list ent))
) ;_ and
;;
;;
(progn
(while
(progn
(setq grr (grread t 7 0)
inp (car grr)
) ;_ setq
(if (= (length entlist) 1)
(setq entlist (cons (mkline pt2 (cadr grr)) entlist))
) ;_ if
(cond
((= inp 3)
(setq entlist (cons (mkline (cadr grr) pt1) entlist))
(setq pt1 (cadr grr))
)
((or (= inp 25) (= inp 11))
nil
)
((= inp 5)
(foreach x entlist
(entmod
(subst
(cons 11 (cadr grr))
(assoc 11 (entget x))
(entget x)
) ;_ subst
) ;_ entmod
(not (redraw x 3))
) ;_ foreach
)
) ;_ cond
) ;_ progn
) ;_ while
(foreach x entlist
(redraw x 4)
) ;_ foreach
) ;_ progn
;;
;;
) ;_ if
(princ)
) ;_ defun
;;
;;
;;WIZ_24DEC09so, we will cheat a little
Just adding to Vovkas routine...this one stores the segments added and sorts to the closest one :-)Code: [Select](defun c:lpers (/ *error* #ent #read clpt clr el ent lname pt x)
(defun *error* (msg) (and #ent (mapcar 'entdel #ent)) (princ msg))
(and
(setq #ent (nentselp "\nSelect curve: "))
(vl-position
(cdr (assoc 0 (setq el (entget (car #ent)))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
)
(setq clr (cdr (assoc 62 (entget (tblobjname "layer" (cdr (assoc 8 el)))))))
(setq lname (cdr (assoc 8 el)))
(setq #read (caddr #ent)
#ent (entmakex (append (entget (car #ent)) (list (cons 60 1))))
)
(or (not #read)
(not (vla-transformby (vlax-ename->vla-object #ent) (vlax-tmatrix #read)))
)
(setq #ent (list #ent))
(not
(while (not (eq 2 (car (setq #read (grread t 15 0)))))
(princ "\rSpecify point for line: ")
(redraw)
(if (vl-consp (setq pt (cadr #read)))
(progn
(setq ent
(car
(mapcar
'cdr
(vl-sort
(mapcar '(lambda (x)
(cons (distance (setq pt (trans (cadr #read) 1 0))
(setq clpt (vlax-curve-getclosestpointto
x
(trans (cadr #read) 1 0)
)
)
)
x
)
)
#ent
)
(function (lambda (d1 d2) (< (car d1) (car d2))))
)
)
)
)
(grdraw (setq clpt (setq clpt (vlax-curve-getclosestpointto ent pt))) pt clr)
)
)
(if (eq 3 (car #read))
(setq
#ent (cons (entmakex
(list '(0 . "LINE") (cons 8 lname) (cons 10 clpt) (cons 11 pt))
)
#ent
)
)
)
)
)
)
(redraw)
(princ)
)
Just adding to Vovkas routine...this one stores the segments added and sorts to the closest one :-)Ron, stop discrediting me, 95% of the code is Alan's :)
Mine and Ron's collaborative effort to combat boredom :evil:guys, i'm having fun with it, coooool :)
:-(Just adding to Vovkas routine...this one stores the segments added and sorts to the closest one :-)Ron, stop discrediting me, 95% of the code is Alan's :)
hey don't be sad, AlanNo offense taken. :)
i didn't mean to say that you code is bad or something, i meant that i personally never use grread.
writing lisps for years i still haven't found any way i could use grread. it's because of the lack of fantasy i suppose :)
;;; Quick Text
;;; Required Subroutines: AT:Mtext AT:Getstring
;;; Alan J. Thompson, 09.23.09
(defun c:QT (/ #Point1 #Point2 #String #Text #Final)
(or QT:Default (setq QT:Default ""))
(and (setq #String (AT:Getstring "Specify text string: " QT:Default))
(not (eq #String ""))
(setq QT:Default (strcase #String))
(setq #Point1 (getpoint "\nSpecify placement point: "))
(or (setq
#Point2 (getpoint #Point1 "\nSpecify next point for angle <Zero>: ")
) ;_ setq
(setq #Point2 #Point1)
) ;_ or
(setq #Text (AT:Mtext #Point1 QT:Default 0 nil 5))
(not (vla-put-rotation #Text (angle #Point1 #Point2)))
(while (eq 5 (car (setq #Final (grread T 4 4))))
(vla-put-insertionpoint #Text (vlax-3d-point (trans (cadr #Final) 1 0)))
) ;_ while
) ;_ and
(princ)
) ;_ defun;;; Add MText to drawing
;;; #InsertionPoint - MText insertion point
;;; #String - String to place in created MText object
;;; #Width - Width of MText object (if nil, will be 0 width)
;;; #Layer - Layer to place Mtext object on (nil for current)
;;; #Justification - Justification # for Mtext object
;;; 1 or nil= TopLeft
;;; 2= TopCenter
;;; 3= TopRight
;;; 4= MiddleLeft
;;; 5= MiddleCenter
;;; 6= MiddleRight
;;; 7= BottomLeft
;;; 8= BottomCenter
;;; 9= BottomRight
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
#Space #Insertion #Object
)
(or #Width (setq #Width 0))
(or *AcadDoc*
(setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ or
(setq #Space (if (or (eq acmodelspace
(vla-get-activespace *AcadDoc*)
) ;_ eq
(eq :vlax-true (vla-get-mspace *AcadDoc*))
) ;_ or
(vla-get-modelspace *AcadDoc*)
(vla-get-paperspace *AcadDoc*)
) ;_ if
#Insertion (cond
((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
((eq (type #InsertionPoint) 'variant) #InsertionPoint)
(T nil)
) ;_ cond
) ;_ setq
;; create MText object
(setq #Object (vla-addmtext #Space #Insertion #Width #String))
;; change layer, if applicable
(and #Layer
(tblsearch "layer" #Layer)
(vla-put-layer #Object #Layer)
) ;_ and
;; change justification & match insertion point with new justification
(cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
(vla-put-attachmentpoint #Object #Justification)
(vla-move #Object
(vla-get-InsertionPoint #Object)
#Insertion
) ;_ vla-move
)
) ;_ cond
#Object
) ;_ defun
;;; Getstring Dialog Box
;;; #Title - Title of dialog box
;;; #Default - Default string within edit box
;;; Alan J. Thompson, 08.25.09
(defun AT:GetString
(#Title #Default / #FileName #FileOpen #DclID #NewString)
(setq #FileName (vl-filename-mktemp "" "" ".dcl")
#FileOpen (open #FileName "W")
) ;_ setq
(foreach x '("TempEditBox : dialog {" "key = \"Title\";"
"label = \"\";" "initial_focus = \"Edit\";" "spacer;"
": row {" ": column {" "alignment = centered;"
"fixed_width = true;" ": text {" "label = \"\";" "}" "}"
": edit_box {" "key = \"Edit\";" "allow_accept = true;"
"edit_width = 40;" "fixed_width = true;" "}" "}"
"spacer;" ": row {" "fixed_width = true;"
"alignment = centered;" ": ok_button {" "width = 11;" "}"
": cancel_button {" "width = 11;" "}" "}" "}//"
)
(write-line x #FileOpen)
) ;_ foreach
(close #FileOpen)
(setq #DclID (load_dialog #FileName))
(new_dialog "TempEditBox" #DclID)
(set_tile "Title" #Title)
(set_tile "Edit" #Default)
(action_tile
"accept"
"(setq #NewString (get_tile \"Edit\"))(done_dialog)"
) ;_ action_tile
(action_tile "cancel" "(done_dialog)")
(start_dialog)
(unload_dialog #DclID)
(vl-file-delete #FileName)
#NewString
) ;_ defun
hi！alanjtThanks :) but there are much much more qualified people here than me.
nice work！
Learn from you！
hi！alanjtThanks :) but there are much much more qualified people here than me.
nice work！
Learn from you！
hi！alanjtThanks :) but there are much much more qualified people here than me.
nice work！
Learn from you！
Very nice routine. I added this gem to my library. Thanks for sharing it.
hi！alanjtThanks :) but there are much much more qualified people here than me.
nice work！
Learn from you！
Very nice routine. I added this gem to my library. Thanks for sharing it.
;;; Magic Eraser (erase anything cursor crosses)
;;; Alan J. Thompson, 10.15.09
(defun c:EE (/ #Read #Ent)
(while (eq 5 (car (setq #Read (grread t 15 2))))
(princ "\rMove cursor over object to erase: ")
(if (setq #Ent (ssget (cadr #Read)))
(vl-catch-all-apply 'entdel (list (ssname #Ent 0)))
) ;_ if
) ;_ while
(princ)
) ;_ defun
;;; Dynamic Distance (distance displayed from picked base point)
;;; Alan J. Thompson, 11.09.09
(defun c:DyD (/ *error* #Pnt #Obj #Read #Dist)
(setq *error* (lambda (x)
(and #Obj (vl-catch-all-apply 'vla-delete (list #Obj)))
(grtext)
(redraw)
) ;_ lambda
) ;_ setq
(and (setq #Pnt (getpoint "\nSpecify base point: "))
(setq #Obj (vlax-ename->vla-object
(entmakex (list '(0 . "CIRCLE")
'(100 . "AcDbEntity")
'(100 . "AcDbCircle")
'(62 . 1)
'(6 . "Continuous")
'(40 . 1.0)
(cons 10 (trans #Pnt 1 0))
) ;_ list
) ;_ entmakex
) ;_ vlax-ename->vla-object
) ;_ setq
(while (eq 5 (car (setq #Read (grread T 15 0))))
(redraw)
(grdraw #Pnt (cadr #Read) 1 1)
(vl-catch-all-apply 'vla-put-radius (list #Obj (distance #Pnt (cadr #Read))))
(setq #Dist (strcat "Distance: " (rtos (distance #Pnt (cadr #Read)))))
(princ (strcat "\r" #Dist " "))
(grtext -1 #Dist)
) ;_ while
) ;_ and
(*error* nil)
(princ)
) ;_ defun
;;; Place current drawing's directory contents (matching *.dwg) in MText
;;; Required Subroutines: AT:MText
;;; Alan J. Thompson, 10.28.09
(defun c:Dir2Text (/ AT:NumFix #Pnt1 #List #Pos #String #Text #Read)
(defun AT:NumFix (#Num #Length / #Str)
(setq #Str (vl-princ-to-string #Num))
(while (and (<= (1+ (strlen #Str)) #Length) (< (strlen #Str) 16))
(setq #Str (strcat "0" #Str))
) ;_ while
#Str
) ;_ defun
(cond
((setq #Pnt1 (getpoint "\nSpecify first corner: "))
(setq #List (vl-sort (vl-remove-if-not
'(lambda (x) (wcmatch x "*.dwg"))
(vl-directory-files (getvar 'dwgprefix))
) ;_ vl-remove-if-not
'<
) ;_ vl-sort
#String ""
) ;_ setq
(foreach x #List
(setq #Pos (AT:NumFix (1+ (vl-position x #List)) (length #List)))
(setq #String (strcat #String #Pos " - " (vl-filename-base x) "\\P"))
) ;_ foreach
(setq #Text (AT:MText #Pnt1 #String 0 nil 1))
(while (eq 5 (car (setq #Read (grread T 15 2))))
(redraw)
(grvecs (list 7
#Pnt1
(list (car (cadr #Read)) (cadr #Pnt1))
(list (car (cadr #Read)) (cadr #Pnt1))
(cadr #Read)
(cadr #Read)
(list (car #Pnt1) (cadr (cadr #Read)))
(list (car #Pnt1) (cadr (cadr #Read)))
#Pnt1
) ;_ list
) ;_ grvecs
(vla-put-width #Text (abs (- (car #Pnt1) (car (cadr #Read)))))
) ;_ while
)
) ;_ cond
(redraw)
(princ)
) ;_ defun
(defun LM:GetString (#Default / dcTag result)
(cond ( (<= (setq dcTag (load_dialog "ACAD")) 0))
( (not (new_dialog "acad_txtedit" dcTag)))
(t
(set_tile "text_edit" #Default)
(action_tile "accept" "(setq result (get_tile \"text_edit\")) (done_dialog)")
(action_tile "cancel" "(done_dialog)")
(start_dialog)
(unload_dialog dcTag)))
result)
(lisped "edit me")
Alan, you could always cheat with your GetString :evil:Code: [Select](defun LM:GetString (#Default / dcTag result)
(cond ( (<= (setq dcTag (load_dialog "ACAD")) 0))
( (not (new_dialog "acad_txtedit" dcTag)))
(t
(set_tile "text_edit" #Default)
(action_tile "accept" "(setq result (get_tile \"text_edit\")) (done_dialog)")
(action_tile "cancel" "(done_dialog)")
(start_dialog)
(unload_dialog dcTag)))
result)
Nah, its just using whats already there :evil:Oh I know, I just meant that, if I knew enough about DCL, I would recognize what I needed.
;; Text Edit Only
;; CAB 03.06.07
(defun c:teo (/ ss txt elst newtxt dcledit)
(defun dcledit (txt / attlist NewTxt ddatt_dcl)
(and
(setq oldtxt txt
dcl (load_dialog "ACAD")
)
(new_dialog "acad_txtedit" dcl)
(set_tile "text_edit" txt)
(action_tile "text_edit" "(setq txt $value)")
(action_tile "cancel" "(setq txt oldtxt)")
(start_dialog)
(unload_dialog dcl)
)
txt
)
(while (setq ss (ssget "_+.:E:S" '((0 . "TEXT"))))
(setq elst (entget (ssname ss 0))
txt (cdr (assoc 1 elst))
)
(if (/= txt (setq NewTxt (dcledit txt)))
(entupd
(cdr (assoc -1 (entmod (subst (cons 1 NewTxt) (assoc 1 elst) elst))))
)
)
)
(princ)
)
(defun c:qe (/ i ss tx ent)
(and (setq i -1 ss (ssget "_:L" '((0 . "MTEXT,TEXT"))))
(not (numberp (setq tx (lisped "New Text"))))
(while (setq ent (ssname ss (setq i (1+ i))))
(entmod (subst (cons 1 tx) (assoc 1 (entget ent)) (entget ent)))))
(princ))
;*************************************************************************************************************************
;| VERSION HISTORY **
**
IB - VERSION 1.0 **
01/06/10 **
BY: CHRIS WADE **
**
- Insert Blocks on lines, arcs, polylines, other blocks, circles, etc. **
- Type: **
- W - Cycles from 3-5 wires **
- A - Changes to Arrowheads **
- C - Continuation Block **
- E - Use endpoint of object **
- T - Type block name. **
**
;*************************************************************************************************************************|;
; Code Adapted from VovKa's modification of Alanjt's code at http://www.theswamp.org/index.php?topic=12813.msg369625#msg369625
; Alanjt's Original code is located at: http://www.theswamp.org/index.php?topic=12813.msg369597#msg369597
(defun c:IB (/ #Ent #Read *error* blobj Ang lastpt cpt bname w ws bscale sObj oLay Snap Spt *thisdrawing* *modelspace* *paperspace*)
;;Error routine adapted from:
;; --=={ Dynamic Text Curve Align }==-- ;;
;; AUTHOR: ;;
;; ;;
;; Copyright © Lee McDonnell, November 2009. All Rights Reserved. ;;
;; ;;
;; { Contact: Lee Mac @ TheSwamp.org, CADTutor.net } ;;
(defun *error* (msg)
(and blobj(or (and pLst (mapcar (function (lambda (x) (vlax-put blobj (car x) (cdr x)))) pLst)) (and (not (vlax-erased-p blobj)) (vla-delete blobj))))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(redraw)
(princ)
)
(setq TMP nil)
(vl-load-com)
(setq bname "3W")
(setq W 3)
(setq bscale (/ (getvar "dimscale") 96))
(vl-cmdf "._insert" bname)(command)
(setq *thisdrawing* (vla-get-activedocument
(vlax-get-acad-object)
) ;_ end of vla-get-activedocument
*modelspace* (vla-get-ModelSpace *thisdrawing*)
*paperspace* (vla-get-PaperSpace *thisdrawing*))
(and
(setq #Ent (nentselp "\nSelect Item to Insert Block On: "))
(vl-position (cdr (assoc 0 (entget (car #Ent))))
'("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE")
)
(setq #Read (caddr #Ent)
#Ent (entmakex (append (entget (car #Ent)) (list (cons 60 1))))
)
(setq Sobj (vlax-ename->vla-object #Ent)
oLay (vla-get-Layer Sobj))
(or (not #Read)
(not (vla-transformby Sobj (vlax-tmatrix #Read)))
)
(not
(while (not (eq 25 (car (setq #Read (grread T 15 0)))))
(princ "\rSpecify point for block ([W]ires/[A]rrow/[C]ontinuation block/[T]ype block name/[E]ndpoint): ")
(redraw)
(cond
((eq 3 (car #Read))
(if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
(setq blobj (vla-InsertBlock *modelspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
(setq blobj (vla-InsertBlock *paperspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
)
(vla-put-Layer blobj oLay)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 101) (= (cadr #Read) 69)))
(if (/= Snap "_End")
(setq Snap "_End")
(setq Snap nil)
)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 119) (= (cadr #Read) 87)))
(if (< W 5)
(setq W (+ W 1))
(setq W 3)
)
(setq WS (rtos W 2 0))
(setq bname (strcat WS "W"))
(vl-cmdf "._insert" bname)(command)
(setq Snap nil)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 65) (= (cadr #Read) 97)))
(cond
((= bname "hr")
(setq bname "hr2-11")
(setq Snap "_End")
)
(T
(setq bname "hr")
(setq Snap nil)
)
)
(vl-cmdf "._insert" bname)(command)
)
((and (= (car #Read) 2) (or (= (cadr #Read) 99) (= (cadr #Read) 67)))
(setq bname "cb")
(vl-cmdf "._insert" bname)(command)
(setq Snap "_End")
)
((and (= (car #Read) 2) (or (= (cadr #Read) 116) (= (cadr #Read) 84)))
(setq bname nil)
(while (or (= bname nil) (= bname ""))
(setq bname (getstring T "\nEnter Block Name: "))
)
(vl-cmdf "._insert" bname)(command)
(setq Snap nil)
)
(T
(if (vl-consp (cadr #Read))
(progn
(if (= lastpt nil)
(setq lastpt (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(progn
(setq cpt (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
(setq data (trans (cadr #Read) 1 0))
(setq Ang (+ (angle data cpt) (D2R 90)))
(if (/= snap nil)
(setq Spt (osnap cpt Snap))
(setq Spt cpt)
)
(if (/= Spt nil)
(progn
(if (/= blobj nil)
(if (not (vlax-erased-p blobj)) (vla-delete blobj))
)
(if (or (/= (getvar "cvport") 1) (/= (getvar "tilemode") 0))
(setq blobj (vla-InsertBlock *modelspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
(setq blobj (vla-InsertBlock *paperspace* (vlax-3d-point Spt) bname bscale bscale bscale Ang))
)
)
)
(vla-put-Layer blobj oLay)
)
)
)
)
)
)
)
)
(entdel #Ent)
)
(redraw)
(princ)
)
; Convert value in radians to degrees
(defun R2D (nbrOfRadians)
(* 180.0 (/ nbrOfRadians pi))
)
; Convert value in degrees to radians
(defun D2R (numberOfDegrees)
(* pi (/ numberOfDegrees 180.0))
) ;_ end of defun
(defun c:ktst ()
(while
(setq input (grread t 4 4))
(princ "\n")
(princ (cadr input))
)
)The only problem that I am having is that if the object that you are inserting on is not closed, and you move the cursor off of the object, the block can get inserted in space (this seems to happen with the perpendicular line in the original code as well), any ideas on how to fix this?
(vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) [color=red]T[/color])Just take it out or set it to nil.
Thank you very much Alan, that did the trick.:)
;;;ss-grread
;;;
;;;get grread point , if type the keys then run Correlation function
;;;funkeys - Keywords from the keyboard
;;;fun_names - Function name or function name list
;;;funarg_list - The parameters list or parameters list tables used for the function
;;;
;;;Return the point list , Function during the implementation of fun1 arg1
;;;
;;;GSLS(ss) , 2010-07-21
(defun ss-grread (fun_keys fun_names funarg_list fun1 arg1 / is_go_on PT midkey pos funname funarglst)
(setq is_go_on T)
(while (and (setq PT (grread t 4 2))
(/= 3 (car PT))
(/= 25 (car pt))
is_go_on
)
(cond
((and (= 2 (car pt)) (or (eq (strcase (chr (cadr pt))) fun_keys) (eq (strcase (chr (cadr pt)) T) fun_keys)))
(wjm-fun fun_names funarg_list)
(setq is_go_on nil)
)
((and (= 2 (car pt)) (or (setq midkey (member (strcase (chr (cadr pt))) fun_keys)) (setq midkey (member (strcase (chr (cadr pt)) T) fun_keys))))
(setq pos (vl-position (car midkey) fun_keys)
funname (nth pos fun_names)
funarglst(nth pos funarg_list))
(wjm-fun funname funarglst)
(setq is_go_on nil)
)
(t
(if (and (= 5 (car PT)) (null fun_keys))
(progn
(wjm-fun fun1 arg1)
)
)
)
)
)
(cadr PT)
)
Used fun;;;the follow function coded by WJM
(defun wjm-fun (funname funarglist)
(if (progn (setq catchit (vl-catch-all-apply
funname
funarglist
)
)
(vl-catch-all-error-p catchit)
)
(progn
(princ "函数:")
(princ funname)
(princ "参数表:")
(princ funarglist)
(princ "\n捕捉到错误:")
(princ (vl-catch-all-error-message catchit))
)
)
catchit
)
;; wrote by eduardo fernal
;; 02/2011
(DEFUN c:teste (/ p1 e1 hf osmode attreq attdia cn)
(SETQ osmode (GETVAR "OSMODE")
cn 0
)
(SETVAR "OSMODE" 0)
(IF (NULL (TBLSEARCH "BLOCK" "EfPac0173"))
(PROGN (IF (NULL (TBLSEARCH "STYLE" "Tempsitc"))
(ENTMAKE '((0 . "STYLE")
(100 . "AcDbSymbolTableRecord")
(100 . "AcDbTextStyleTableRecord")
(2 . "Tempsitc")
(70 . 0)
(40 . 0.0)
(41 . 1.0)
(50 . 0.0)
(71 . 0)
(42 . 1.0)
(3 . "TEMPSITC.TTF")
(4 . "")
)
)
)
(ENTMAKE '((0 . "BLOCK") (2 . "EfPac0173") (70 . 2) (10 0.0 0.0 0.0)))
(ENTMAKE '((0 . "ATTDEF")
(100 . "AcDbEntity")
(8 . "0")
(100 . "AcDbText")
(10 3.93553 7.30553 0.0)
(40 . 1.0)
(1 . "")
(50 . 0.0)
(41 . 1.0)
(51 . 0.0)
(7 . "Tempsitc")
(71 . 0)
(72 . 0)
(11 0.0 0.0 0.0)
(100 . "AcDbAttributeDefinition")
(280 . 0)
(3 . "Norte")
(2 . "1")
(70 . 0)
(73 . 0)
(74 . 0)
(280 . 1)
)
)
(ENTMAKE '((0 . "ATTDEF")
(100 . "AcDbEntity")
(8 . "0")
(100 . "AcDbText")
(10 3.93553 5.64553 0.0)
(40 . 1.0)
(1 . "")
(50 . 0.0)
(41 . 1.0)
(51 . 0.0)
(7 . "Tempsitc")
(71 . 0)
(72 . 0)
(11 0.0 0.0 0.0)
(100 . "AcDbAttributeDefinition")
(280 . 0)
(3 . "Leste")
(2 . "2")
(70 . 0)
(73 . 0)
(74 . 0)
(280 . 1)
)
)
(ENTMAKE '((0 . "ATTDEF")
(100 . "AcDbEntity")
(8 . "0")
(100 . "AcDbText")
(10 3.93553 3.98553 0.0)
(40 . 1.0)
(1 . "")
(50 . 0.0)
(41 . 1.0)
(51 . 0.0)
(7 . "Tempsitc")
(71 . 0)
(72 . 0)
(11 0.0 0.0 0.0)
(100 . "AcDbAttributeDefinition")
(280 . 0)
(3 . "Cota")
(2 . "3")
(70 . 0)
(73 . 0)
(74 . 0)
(280 . 1)
)
)
(ENTMAKE '((0 . "ATTDEF")
(100 . "AcDbEntity")
(8 . "0")
(100 . "AcDbText")
(10 3.93553 1.98553 0.0)
(40 . 1.0)
(1 . "")
(50 . 0.0)
(41 . 1.0)
(51 . 0.0)
(7 . "Tempsitc")
(71 . 0)
(72 . 0)
(11 0.0 0.0 0.0)
(100 . "AcDbAttributeDefinition")
(280 . 0)
(3 . "Descrição")
(2 . "4")
(70 . 0)
(73 . 0)
(74 . 0)
(280 . 1)
)
)
(ENTMAKE '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(8 . "0")
(100 . "AcDbPolyline")
(90 . 7)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
(10 2.05061 2.05061)
(40 . 0.0)
(41 . 0.0)
(42 . 0.437869)
(91 . 0)
(10 1.4632 2.02708)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 0.0 0.0)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 2.02708 1.4632)
(40 . 0.0)
(41 . 0.0)
(42 . 0.437869)
(91 . 0)
(10 2.05061 2.05061)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 3.53553 3.53553)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
(10 13.5355 3.53553)
(40 . 0.0)
(41 . 0.0)
(42 . 0.0)
(91 . 0)
)
)
(ENTMAKE '((0 . "ENDBLK")))
)
nil
)
(SETVAR "OSMODE" 8)
(IF (OR (NOT g::efpac0173::hf)
(NOT (NUMBERP g::efpac0173::hf))
(<= g::efpac0173::hf 0.0)
)
(SETQ g::efpac0173::hf 1.0)
)
(SETQ
hf (GETREAL (STRCAT "\n-> Altura da fonte (font height) < " (RTOS g::efpac0173::hf 2 1) " > : "))
)
(IF (OR (NOT hf) (NOT (NUMBERP hf)) (<= hf 0))
(SETQ hf g::efpac0173::hf)
)
(SETQ g::efpac0173::hf hf
attreq (GETVAR "ATTREQ")
attdia (GETVAR "ATTDIA")
)
(SETVAR "ATTREQ" 1)
(SETVAR "ATTDIA" 0)
;;(PRINC "\n-> Tecle algo para encerrar ou posicione o cursor sobre pontos...")
(princ "\n-> Type a letter for finish or put cursor over points...")
(WHILE (LISTP (SETQ p1 (CADR (GRREAD 1 5 0))))
(IF (SETQ e1 (SSGET "C"
(LIST (- (CAR p1) 0.001) (- (CADR p1) 0.001) (CADDR p1))
(LIST (+ (CAR p1) 0.001) (+ (CADR p1) 0.001) (CADDR p1))
(LIST (CONS 0 "POINT"))
)
)
(PROGN
(SETQ e1 (ENTGET (SSNAME e1 0))
p1 (CDR (ASSOC 10 e1))
p3 (MAPCAR '+ '(5 5 0) p1)
)
(IF (NOT (SSGET "x" (LIST (CONS 0 "INSERT") (CONS 2 "EfPac0173") (CONS 10 p1))))
(COMMAND "_.-INSERT"
"EfPac0173"
"_NON"
p1
g::efpac0173::hf
g::efpac0173::hf
0.0
(STRCAT "N=" (RTOS (CADR p1) 2 3))
(STRCAT "L=" (RTOS (CAR p1) 2 3))
(STRCAT "E=" (RTOS (CADDR p1) 2 3))
(ITOA (SETQ cn (1+ cn)))
)
)
)
)
)
(SETVAR "OSMODE" osmode)
(SETVAR "ATTREQ" attreq)
(SETVAR "ATTDIA" attdia)
(PRINC)
)
;; wrote by eduardo fernal
;; 02/2011
(DEFUN c:teste (/ p1 e1 hf osmode attreq attdia cn)
.........
Lee,
perfect, thank you sir.....
Steve
It does have a dependence on the TTF file being available.
I have modified it slightly, perhaps try the attached.
It does have a dependence on the TTF file being available.
I have modified it slightly, perhaps try the attached.
Lee, one thing puzzles me... when the program inserts the leader block and you explode it, the attributes are listed as North, East, Elev, and Description. However before exploding, the attributes are really East, North, Elev and Description. How did the North and East get reversed ? I know you math guys think of x and y, but we engineers/surveyors think N and E (y and x). How can we get the block to tell the "truth" ?
Steve
(defun c:test ( / p l g )
(if (setq p (getpoint "\nSpecify First Point: "))
(progn
(setq l
(entget
(entmakex
(list
(cons 0 "LINE") (cons 10 (trans p 1 0)) (cons 11 (trans p 1 0))
)
)
)
)
(princ "\nSpecify Next Point: ")
(while (= 5 (car (setq g (grread t 13 0))))
(entupd
(cdr
(assoc -1
(entmod
(list (assoc -1 l)
(cons 11
(trans
(polar p (/ pi 4.)
(
(if
(minusp
(
(lambda ( n )
(- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
)
(polar '(0. 0. 0.) (/ pi 4.) 1.)
)
)
- +
)
(distance p (cadr g))
)
)
1 0
)
)
)
)
)
)
)
)
)
)
(princ)
)
(defun cs_ENTSEL (STR FILTER / PT SS_NAME area_mid SS old_modemacro)
(setq old_modemacro (getvar "MODEMACRO"))
(if (/= (type STR) 'STR)
(progn
(princ "\n变量类型不对，STR应为字符串。\n")
(eval NIL)
)
(progn
(if (/= (type FILTER) 'list)
(progn
(princ "\n变量类型不对，FILTER应为表。\n")
(eval NIL)
)
(progn
(princ STR)
(setq PT (grread t 4 2))
(setq is_go_on t)
(while (and (/= 3 (car PT))
(/= 25 (car pt))
is_go_on
)
(cond
((and (= 2 (car pt))
(or (= 13 (cadr pt)) (= 32 (cadr pt)))
) ;_Enter,Space.
(setq is_go_on nil)
)
((and (= 2 (car pt))
(or (= 115 (cadr pt)) (= 83 (cadr pt)))
) ;_S set arg.
(if (dcl_Form_IsActive CS_ODCLINIT)
nil
(c:asd)
)
(setq is_go_on t)
)
(t
(progn
(if (= 5 (car PT))
(progn
(setq PT (cadr PT))
(setq SS (ssget PT FILTER)) ;_perhaps this take a lag !
(if SS_NAME
(progn
(redraw SS_NAME 4) ;_release high-display .
)
)
) ;_progn
)
(setq SS_NAME NIL)
(if SS
(progn
(setq str (cdr (assoc 1 (entget (ssname SS 0)))))
(setq SS_NAME (ssname SS 0))
(redraw SS_NAME 3)
)
(setvar "MODEMACRO" old_modemacro)
)
) ;_progn
)
) ;_cond
(setq PT (grread t 4 2))
) ;_while
(setvar "MODEMACRO" old_modemacro)
(if (/= 25 (car pt))
(progn
(setq PT (cadr PT))
(setq SS (ssget PT FILTER))
(if SS_NAME
(redraw SS_NAME 4)
)
(setq SS_NAME NIL)
(if SS
(progn
(setq SS_NAME (ssname SS 0))
(list PT SS_NAME)
)
(list PT)
)
)
nil
)
)
)
)
)
)
for test code (defun c:test (/ en)
(setq
en
(cs_ENTSEL
"\n请选取计算书或配筋文字[设置(S)]:"
'((1
.
"G*[-=]*,*[-=]*[-=]*,VT*[-=]*,*%%13[01234]*,N*%%13[01234],*L*,*[xX]*"
)
)
)
)
(princ en)
)That looks crazy! :lol:Nicely done Lee. I actually coded this just yesterday and was wondering how you could code it to account for the opposite direction.
Was looking at Evgeniy's example of 'line<45' at the start of the thread, perhaps this might be another way to code it:
(defun _grAtAngle (pt ang / gr point)
(while
(progn (setq gr (grread T 15 0))
(cond ((eq 5 (car gr)) (redraw) (grdraw pt (polar pt ang (distance pt (cadr gr))) 7 -1) T)
((eq 3 (car gr)) (setq point (cadr gr)) (redraw))
)
)
)
point
)(defun line<ang ( p a / g )
(while (= 5 (car (setq g (grread t 13 0)))) (redraw)
(grdraw p
(polar p a
(
(if
(minusp
(
(lambda ( n )
(- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
)
(polar '(0. 0. 0.) a 1.)
)
)
- +
)
(distance p (cadr g))
)
)
-1
)
)
(redraw) (if (listp (cadr g)) (cadr g))
)
(defun line<ang ( p a / g )
(while (= 5 (car (setq g (grread t 13 0)))) (redraw)
(grdraw p
(polar p a
(
(if (minusp (cos (- (angle p (polar p a 1.)) (angle p (cadr g)))))
- +
)
(distance p (cadr g))
)
)
-1
)
)
(redraw) (if (listp (cadr g)) (cadr g))
)Cheers Alan :-)Care to explain the method/math? I *think* I get the cosine one, but I'm not 100% and I don't understand the trans one at all.
Perhaps two methods:Code: [Select](defun line<ang ( p a / g )
(while (= 5 (car (setq g (grread t 13 0)))) (redraw)
(grdraw p
(polar p a
(
(if
(minusp
(
(lambda ( n )
(- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
)
(polar '(0. 0. 0.) a 1.)
)
)
- +
)
(distance p (cadr g))
)
)
-1
)
)
(redraw) (if (listp (cadr g)) (cadr g))
)Code: [Select](defun line<ang ( p a / g )
(while (= 5 (car (setq g (grread t 13 0)))) (redraw)
(grdraw p
(polar p a
(
(if (minusp (cos (- (angle p (polar p a 1.)) (angle p (cadr g)))))
- +
)
(distance p (cadr g))
)
)
-1
)
)
(redraw) (if (listp (cadr g)) (cadr g))
)
:-)
Care to explain the method/math? I *think* I get the cosine one, but I'm not 100% and I don't understand the trans one at all.
(
(lambda ( n )
(- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))
)
(polar '(0. 0. 0.) a 1.)
)(polar '(0. 0. 0.) a 1.)(- (caddr (trans (cadr g) 1 n)) (caddr (trans p 1 n)))(defun fe-follow-mouse (_sset / pos_mouse pt_mouse pt)
;;(command "_.copy" _sset "" (list 0 0 0) (list 0 0 0))
(setvar "OSMODE" 0)
(command)
(setq pt (cadr (grread t 1 0)))
(while (= (car (setq pos_mouse (grread t 1 0))) 5)
(setq pt_mouse (cadr pos_mouse))
(command "_.move" _sset "" pt pt_mouse)
(setq pt pt_mouse)
)
)
For OSnap etc, you might like to look at acet-ss-drag-move (http://www.theswamp.org/index.php?topic=36515.msg415112#msg415112), although this is outside the intention of this 'grread' oriented thread.Still a useful sub.
BTW was my last explanation clearer for you?I didn't even see that one, have to give it a read.
(defun ucsline ( p a / g )
(while (= 5 (car (setq g (grread t 13 0)))) (redraw) (setq g (cadr g))
(grdraw p
(apply 'polar
(cons p
(
(lambda ( n / x z )
(setq x (- (car (trans g 1 n)) (car (trans p 1 n)))
z (- (caddr (trans g 1 n)) (caddr (trans p 1 n)))
)
(if (< (abs z) (abs x)) (list (+ a (/ pi 2.)) x) (list a z))
)
(polar '(0. 0. 0.) a 1.0)
)
)
)
-1
)
)
(redraw) (if (listp (cadr g)) (cadr g))
)(ucsline (getpoint "\nBase Point: ") (/ pi 6.))
(if (and (listp (cadr g)) (eq 3 (car g))) (cadr g))
You should change this line so the point is only return if the user left-clicks - matches actual functionality of AutoCAD.Code: [Select](if (and (listp (cadr g)) (eq 3 (car g))) (cadr g))
(defun c:test ( / p g a ) (setq a (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 1 t)))
(if (setq p (getpoint "\nSpecify First Point: "))
(while (or (= 5 (car (setq g (grread t 15 0)))) (= 2 (car g))) (redraw) (setq g (cadr g))
(if (listp g)
(grdraw p
(if (zerop (getvar 'ORTHOMODE)) g
(apply 'polar
(cons p
(
(lambda ( n / x z )
(setq x (- (car (trans g 1 n)) (car (trans p 1 n)))
z (- (caddr (trans g 1 n)) (caddr (trans p 1 n)))
)
(if (< (abs z) (abs x)) (list (+ a (/ pi 2.)) x) (list a z))
)
(polar '(0. 0. 0.) a 1.0)
)
)
)
)
-1
)
(if (= 15 g) (setvar 'ORTHOMODE (- 1 (getvar 'ORTHOMODE))))
)
)
)
(redraw) (if (listp (cadr g)) (cadr g))
)
Nevermind, I'm retarded. :ugly:You should change this line so the point is only return if the user left-clicks - matches actual functionality of AutoCAD.Code: [Select](if (and (listp (cadr g)) (eq 3 (car g))) (cadr g))
Does it not already have that behaviour?
;;;to draw a leader and change the direction with mouse move
;;;by GSLS(SS)
(defun c:ss_JT (/ pt1 pt2 pt3 pt is_back0 is_go_on en en1)
(svos)
(setvar 'cmdecho 0)
(setvar 'PICKSTYLE 0)
(setq pt1 (getpoint))
(setq pt2 (getpoint pt1))
(entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt2)))
(setq en1 (entlast))
(redraw en1 3)
(setq pt3 (getpoint pt2))
(draw-pline
(list pt1 pt2 (polar pt3 (angle pt3 pt2) 450) pt3) ;_here you can change the Neck Point Distance '450'
'((0.0 0.0) (0.0 0.0) (150.0 0.0) (0.0 0.0)); here you can change the Neck Width '150.0'
nil
nil
-1
0
)
(setq en (entlast))
(redraw en 3)
(entdel en1)
(setq pt (grread t 4 2))
(setq is_back0
(if (< (distance (cadr pt) pt3) (distance (cadr pt) pt1))
1
-1
)
is_go_on T
)
(while (and (/= 3 (car PT))
(/= 25 (car pt))
is_go_on
)
(cond
((and (= 2 (car pt)) (or (= 13 (cadr pt)) (= 32 (cadr pt)))) ;_Space or Enter
(setq is_go_on nil)
(setq is_back
(if
(< (distance (cadr pt) pt3) (distance (cadr pt) pt1))
1
-1
)
)
(if (< (* is_back0 is_back) 0)
(progn (entdel en)
(if (= is_back 1)
(draw-pline
(list pt1 pt2 (polar pt3 (angle pt3 pt2) 450) pt3)
'((0.0 0.0) (0.0 0.0) (150.0 0.0) (0.0 0.0))
nil
nil
-1
0
)
(draw-pline
(list pt1 (polar pt1 (angle pt1 pt2) 450) pt2 pt3)
'((0.0 150.0) (0.0 0.0) (0.0 0.0) (0.0 0.0))
nil
nil
-1
0
)
)
(setq en (entlast))
(redraw en 4)
)
)
)
(t
(setq is_back
(if
(< (distance (cadr pt) pt3) (distance (cadr pt) pt1))
1
-1
)
)
(if (< (* is_back0 is_back) 0)
(progn (entdel en)
(if (= is_back 1)
(draw-pline
(list pt1 pt2 (polar pt3 (angle pt3 pt2) 450) pt3)
'((0.0 0.0) (0.0 0.0) (150.0 0.0) (0.0 0.0))
nil
nil
-1
0
)
(draw-pline
(list pt1 (polar pt1 (angle pt1 pt2) 450) pt2 pt3)
'((0.0 150.0) (0.0 0.0) (0.0 0.0) (0.0 0.0))
nil
nil
-1
0
)
)
(setq en (entlast))
(redraw en 3)
)
)
(setq is_back0 is_back)
)
) ;_cond
(setq PT (grread t 4 2))
)
(redraw en 4)
(clos)
(princ)
)
;;;Error-handing
(defun ss-errexit (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\n错误: " msg))
)
(clos)
)
;;;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)
)
;;;--------------------------------------------------------------------------------------;;;
;;;drwa-pline ;;;
;;;--------------------------------------------------------------------------------------;;;
;;;
;;;function: to make a polyline by code and return ename
;;;
;;;Variants:
;;;pl_list: the points list offered by order
;;;width : 0.0 or num, or a list like ((0.0 0.0) (0.0 20) (20 0.0)...),if nil it will getvar "plinewid" ,
;;; if it's length noteq d90 then wid41 and wid42 equal to 0.0 .
;;;d42_lst: 0.0 or num, or nil, if nil or it's length noteq d90 then d42 equal to 0.0 .
;;;
;;;lay_pl: layername, if nil it will getvar "CLAYER"
;;;
;;;color : color number, if it's -1 then getvar "COLOR" ellse set it by the given color number
;;;
;;;Prompt:
;;;If width list or d42_lst list is Exist , it's order must be same to the pl_list,
;;; otherwise it will take out a wrong polyline .
;;;
;;;Written By GSLS(SS),2010.06.30
;;;
(defun draw-pline
(pl_list width d42_lst lay_pl color d70
/ d90 i wid d42 wid40
wid41 en000 pb
)
(setq d90 (length pl_list)
pb '()
i 0
)
(cond ((and (listp width)
(listp d42_lst)
(= (length width) (length d42_lst) d90)
)
(foreach pt pl_list
(setq wid (nth i width)
d42 (nth i d42_lst)
wid40 (car wid)
wid41 (cadr wid)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
((and (or (numberp width) (null width))
(listp d42_lst)
(= (length d42_lst) d90)
)
(if (null width)
(setq wid40 (getvar "plinewid")
wid41 (getvar "plinewid")
)
(setq wid40 width
wid41 width
)
)
(foreach pt pl_list
(setq d42 (nth i d42_lst)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
((and (listp width)
(= (length width) d90)
(or (null d42_lst) (numberp d42_lst))
)
(if (null d42_lst)
(setq d42 0.0)
(setq d42 d42_lst)
)
(foreach pt pl_list
(setq wid (nth i width)
wid40 (car wid)
wid41 (cadr wid)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
(t
(if (numberp width)
(setq wid40 width
wid41 width
)
(setq wid40 0.0
wid41 0.0
)
)
(foreach pt pl_list
(setq pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 0.0)
)
)
)
)
)
)
(setq en000 (append (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 8
(if (and lay_pl (/= lay_pl ""))
lay_pl
(getvar "CLAYER")
)
)
(cons 100 "AcDbPolyline")
(cons 90 d90)
(cons 70 d70)
)
pb
)
)
(if (and color (/= -1 color))
(setq en000 (append en000 (list (cons 62 color))))
)
(if (= nil (entmake en000))
(princ "\nerror:entity-list error.")
)
(entlast)
)
hi allNice work,chlh_jd !
here's draw a leader , it's so simple
(defun c:Arrow (/ a b)
;; Draw quick arrow
;; Alan J. Thompson
(if (and (setq a (getpoint "\nSpecify first point: "))
(setq b (getpoint a "\nSpecity next point: "))
)
(command "_.leader" "_non" a "_non" b "" "" "_N")
)
(princ)
)but chlh_jd and boredom inspired me to write these...(defun c:Arrow (/ _group _dist lastentity p1 p2 ent obj gr coords pt)
;; Draw quick arrow
;; Alan J. Thompson, 03.13.11
(defun _group (l)
(if (caddr l)
(cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
)
)
(defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
(setq lastentity (entlast))
(if (and (setq p1 (getpoint "\nSpecify first point: "))
(setq p2 (getpoint p1 "\nSpecity next point: "))
(vl-cmdf "_.leader" "_non" p2 "_non" p1 "" "" "_N")
(not (equal lastentity (setq ent (entlast))))
(setq obj (vlax-ename->vla-object ent))
)
(while (eq 5 (car (setq gr (grread T 15 0))))
(redraw)
(grdraw (cadr gr)
(trans (vlax-curve-getClosestPointTo ent (setq pt (trans (cadr gr) 1 0))) 0 1)
3
-1
)
(if
(equal
(last (setq coords (_group (vlax-get obj 'Coordinates))))
(car (vl-sort coords (function (lambda (a b) (< (_dist a pt) (_dist b pt))))))
)
(vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
)
(grdraw (cadr gr) (trans (car coords) 0 1) 1 -1)
)
)
(redraw)
(princ)
)(defun c:ArrowM
(/ _group _getPoints _arrow _closestpt AT:Arrow lastentity AT:Midpoint lst ent obj gr coords)
;; Draw Arrow
;; Alan J. Thompson, 03.13.11
(defun _group (l)
(if (caddr l)
(cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))
)
)
(defun _getPoints (/ lst pt)
(if (car (setq lst (list (getpoint "\nSpecify first point: "))))
((lambda (color)
(while (setq pt (getpoint (car lst) "\nSpecify next point: "))
(redraw)
(mapcar (function (lambda (a b) (and a b (grdraw a b color -1))))
(setq lst (cons pt lst))
(cdr lst)
)
(AT:Arrow (car lst) (angle (cadr lst) (car lst)))
)
(redraw)
lst
)
(cdr (assoc 62 (tblsearch "LAYER" (getvar 'CLAYER))))
)
)
)
(defun _arrow (lst)
(mapcar
(function
(lambda (a b)
(and a b (AT:Arrow (trans (AT:MidPoint a b) 0 1) (angle (trans b 0 1) (trans a 0 1))))
)
)
lst
(cdr lst)
)
)
(defun _closestpt (lst p)
(car (vl-sort lst (function (lambda (a b) (< (distance a p) (distance b p))))))
)
(defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
;; Display directional arrow
;; #Location - arrow placement point
;; #Angle - arrow directional angle
;; Alan J. Thompson, 04.28.09
(setq #Size (* (getvar "viewsize") 0.02)
#Point1 (polar #Location #Angle #Size)
#Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
#Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
)
(grvecs (list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1))
#Location
)
(defun AT:Midpoint (p1 p2)
;; Midpoint between two points
;; Alan J. Thompson, 04.23.09
(mapcar (function (lambda (a b) (/ (+ a b) 2.))) p1 p2)
)
(setq lastentity (entlast))
(if (and (setq lst (_getPoints))
(progn (vl-cmdf "_.leader") (foreach p lst (vl-cmdf "_non" p)) (vl-cmdf "" "" "_N"))
(not (equal lastentity (setq ent (entlast))))
(setq obj (vlax-ename->vla-object ent))
)
(while (eq 5 (car (setq gr (grread T 15 0))))
(redraw)
(grdraw (cadr gr) (trans (vlax-curve-getClosestPointTo ent (trans (cadr gr) 1 0)) 0 1) 3 -1)
(grdraw (cadr gr) (trans (car (setq coords (_group (vlax-get obj 'Coordinates)))) 0 1) 1 -1)
(_arrow coords)
(if (equal (last coords) (_closestpt coords (trans (cadr gr) 1 0)))
(vlax-put obj 'Coordinates (apply (function append) (reverse coords)))
)
)
)
(redraw)
(princ)
)(defun c:PW (/ _width _colorUp _dist AT:SS->List sslst gr p&c wd)
;; set LWPolyline Width
;; Alan J. Thompson, 03.12.11
(vl-load-com)
(defun _width (d w) (entupd (cdr (assoc -1 (entmod (subst (cons 43 w) (assoc 43 d) d))))))
(defun _colorUp (n)
(if (> (setq n (+ n 100)) 249)
1
n
)
)
(defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
(defun AT:SS->List (ss vla / i l)
;; Convert selection set to list of ename or vla objects
;; ss - SSGET selection set
;; vla - T for vla objects, nil for ename
;; Alan J. Thompson, 04.01.10
(if (eq (type ss) 'PICKSET)
(if vla
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
(repeat (setq i (sslength ss)) (setq l (cons (ssname ss (setq i (1- i))) l)))
)
)
)
(if (setq sslst (AT:SS->List (ssget "_:L" '((0 . "LWPOLYLINE"))) nil))
(progn (while (eq 5 (car (setq gr (grread T 15 0))))
(redraw)
(grdraw
(cadr gr)
(car (setq p&c
(car
(vl-sort
(mapcar
(function
(lambda (e / d)
(cons (trans (vlax-curve-getClosestPointTo e (trans (cadr gr) 1 0)) 0 1)
(_colorUp (cond ((cdr (assoc 62 (setq d (entget e)))))
((cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 d))))))
)
)
)
)
)
sslst
)
(function (lambda (a b) (< (_dist (car a) (cadr gr)) (_dist (car b) (cadr gr)))))
)
)
)
)
(cdr p&c)
-1
)
(princ (strcat "\rLWPolyline width: "
(rtos (setq wd (* (_dist (cadr gr) (car p&c)) 2.)))
" "
)
)
(foreach e sslst (_width (entget e) wd))
)
)
)
(redraw)
(princ)
)Excellent , Alan ! :-)Enjoy. I had a bit of fun writing it.
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Excellent , Alan ! :-)Enjoy. I had a bit of fun writing it.
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Thanks.Excellent , Alan ! :-)Enjoy. I had a bit of fun writing it.
You have used the better method grdraw to show middle routine . I can learn a lot from your code
Nice routine.
To activate the PW command grread function, I have to hit the space bar after selecting the polyline.
Thanks for the two leader arrow routines Alan. Very useful.Enjoy. :-)
(defun AT:CycleThroughENames (lst / l n i g e)
;; Cycle through a list of ENames to choose one
;; lst - list of ENames
;; Alan J. Thompson, 03.29.11
(if (>= (setq l (length lst)) 2)
(progn
(princ "\n<Tab> to cycle through entities: ")
(redraw (setq i (nth (setq n 0) lst)) 3)
(while (progn (setq g (grread nil 10))
(cond ((equal g '(2 9))
(redraw i 4)
(redraw (setq i (nth (setq n (rem (1+ n) l)) lst)) 3)
T
)
((or (member g '((2 32) (2 13))) (eq (car g) 25)) (redraw (setq e i) 4))
(T (redraw i 4))
)
)
)
e
)
(car lst)
)
)(defun ss->lst (ss / i l)
(if (eq (type ss) 'PICKSET)
(repeat (setq i (sslength ss)) (setq l (cons (ssname ss (setq i (1- i))) l)))
)
)
(defun c:Test (/ ent)
(if (setq ent (AT:CycleThroughENames (ss->lst (ssget))))
(sssetfirst nil (ssadd ent))
)
(princ)
)
(defun c:Test2 (/ pt ent)
(if (and (setq pt (getpoint "\nSpecify point: "))
(setq ent (AT:CycleThroughENames (ss->lst (ssget "_C" pt pt))))
)
(sssetfirst nil (ssadd ent))
)
(princ)
)(defun c:msel ( / ss i l )
(and
(setq ss (ssget))
(setq i -1 l (sslength ss))
(princ "\nPress Tab to Cycle Through Selection <Exit>: ")
(while (= 9 (cadr (grread nil 10))) (sssetfirst nil (ssadd (ssname ss (setq i (rem (1+ i) l))))))
)
(princ)
)
(rem (1+ i) l)Clever. :kewl: You've proved me useless.
Quote(rem (1+ i) l)Clever. :kewl: You've proved me useless.
(defun AT:CycleThroughENames (lst / l i n)
(if (>= (setq l (length lst)) 2)
(progn (princ "\n<Tab> to cycle through entities: ")
(redraw (setq i (nth (setq n 0) lst)) 3)
(while (eq (cadr (grread nil 10)) 9)
(mapcar 'redraw (list i (setq i (nth (setq n (rem (1+ n) l)) lst))) '(4 3))
)
(redraw i 4)
i
)
(car lst)
)
)
(defun AT:CycleThroughSS (ss / l i e)
(if (eq (type ss) 'PICKSET)
(if (eq (setq l (sslength ss)) 1)
(ssname ss 0)
(progn (princ "\n<Tab> to cycle through entities: ")
(redraw (setq e (ssname ss (setq i 0))) 3)
(while (eq (cadr (grread nil 10)) 9)
(mapcar 'redraw (list e (setq e (ssname ss (setq i (rem (1+ i) l))))) '(4 3))
)
(redraw e 4)
e
)
)
)
)Can grread retrieve infos from a "gripped" object?
Question:You can select the 'gripped' object with (ssget "_I") and extract info from there.
Can grread retrieve infos from a "gripped" object?
You can select the 'gripped' object with (ssget "_I") and extract info from there.
grread is simply a function to monitor user input.
(cadr (ssgetfirst))
Oreven better.Code: [Select](cadr (ssgetfirst))
OrCode: [Select](cadr (ssgetfirst))
(defun c:Test (/ _grAngle _ss2lst lst gr pt)
(vl-load-com)
(defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
(defun _ss2lst (ss / i l)
(if (eq (type ss) 'PICKSET)
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(if (setq lst (_ss2lst (ssget "_:L" '((0 . "INSERT")))))
(while (eq 5 (car (setq gr (grread T 15 0))))
(setq pt (trans (cadr gr) 1 0))
(redraw)
(foreach o lst (vla-put-rotation o (_grAngle (vlax-get o 'InsertionPoint) pt)))
)
)
(redraw)
(princ)
)That looks fun! :lol::-D
Interesting tool Alan. Not sure when I'd use it but you never know. 8-)Thanks Alan. :) I won't ever use it - no OSnaps. I just thought I'd do a fun one.
In the tool box it goes.
Thanks
(defun c:RBP (/ ss pt)
;; Rotate Blocks to Point
;; Alan J. Thompson
(if (and (setq ss (ssget "_:L" '((0 . "INSERT"))))
(setq pt
(if (eq 1 (sslength ss))
(getpoint (trans (cdr (assoc 10 (entget (ssname ss 0)))) 0 1) "\nSpecify base point: ")
(getpoint "\nSpecify base point: ")
)
)
)
((lambda (p)
(vlax-for x (setq ss (vla-get-activeselectionset
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument
(vlax-get-acad-object)
)
)
)
)
)
)
(vla-put-rotation x (angle (vlax-get x 'InsertionPoint) p))
)
(vla-delete ss)
)
(trans pt 1 0)
)
)
(princ)
)
Wrote a more practical one and thought I'd do a crappy GRREAD example:haha, good stuff to learn mr. alanjt :-)Code: [Select](defun c:Test (/ _grAngle _ss2lst lst gr pt)
(vl-load-com)
(defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
(defun _ss2lst (ss / i l)
(if (eq (type ss) 'PICKSET)
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(if (setq lst (_ss2lst (ssget "_:L" '((0 . "INSERT")))))
(while (eq 5 (car (setq gr (grread T 15 0))))
(setq pt (trans (cadr gr) 1 0))
(redraw)
(foreach o lst (vla-put-rotation o (_grAngle (vlax-get o 'InsertionPoint) pt)))
)
)
(redraw)
(princ)
)
(http://www.theswamp.org/screens/alanjt/RotateBlocksToGrReadPoint.gif)
haha, good stuff to learn mr. alanjt :-)enjoy. :)
kruuger
(defun c:test (/ CreateList _grAngle adoc Plines obj cnt ent ObjectPointList
PtAngleList Xpoint gr NewLine
)
;;; pBe April 2011 ;;;
(vl-load-com)
(defun CreateList (p) (setq ObjectPointList (cons (cdr p) ObjectPointList)))
;;; Alanjt ;;;
(defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
;;; ;;;
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(if (setq Plines (ssget ":L" '((0 . "LWPOLYLINE"))))
(progn
(repeat (setq cnt (sslength Plines))
(setq obj (ssname Plines (setq cnt (1- cnt)))
ent (entget obj))
(mapcar
'CreateList
(vl-remove-if-not '(lambda (x) (= (car x) 10)) ent)
)
(ssdel obj Plines)
)
(if ObjectPointList
(progn
;;; Alanjt ;;;
(while (eq 5 (car (setq gr (grread T 15 0))))
(setq Xpoint (trans (cadr gr) 1 0))
(redraw)
(foreach pts ObjectPointList (_grAngle pts Xpoint))
)
;;; ;;;
(redraw)
(foreach
itm ObjectPointList
(setq
NewLine
(vla-addline
(vlax-get (vla-get-activelayout adoc) 'Block)
(vlax-3d-point Xpoint)
(vlax-3d-point itm)
)
)
)
)
)
)
)
(princ)
)(defun c:ZLBL (/ pt txt pt2 gr ang)
;; Alan J. Thompson, 04.18.11
(vl-load-com)
(if
(and (setq pt (getpoint "\nSpecify point: "))
(setq txt (vla-addMText
(vlax-get-property
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
)
(if (eq 1 (getvar 'cvport))
'PaperSpace
'ModelSpace
)
)
(setq pt2 (vlax-3d-point (trans pt 1 0)))
0.
""
)
)
)
(progn
(vla-put-textstring
txt
(strcat "%<\\AcObjProp Object(%<\\_ObjId "
(itoa (vla-get-objectID txt))
">%).InsertionPoint \\f \"%lu2%pt4%pr2\">%"
)
)
(vla-regen *AcadDoc* acActiveViewport)
(while (eq 5 (car (setq gr (grread T 15 0))))
(mapcar
(function (lambda (p v) (vlax-put-property txt p v)))
'(Rotation AttachmentPoint InsertionPoint)
(if (or (<= (setq ang (angle pt (cadr gr))) (/ pi 2.)) (>= ang (* pi 1.5)))
(list ang 4 pt2)
(list (+ pi ang) 6 pt2)
)
)
)
)
)
(princ)
)
(defun c:test (/ en ent str pt)
(if (and (setq en (car (entsel "Select Integer Number Text :")))
(setq ent (entget en))
(setq str (cdr (assoc 1 ent)))
(numberp (eval (read str)))
(equal (atoi str) (atof str))
)
(while (and (setq pt (grread t 4 2))
(not (and (= 2 (car pt))
(or (= 13 (cadr pt)) (= 32 (cadr pt)))
)
) ;_Enter Space
)
(cond ((= (car pt) 3);_Mouse Left button
(setq str (rtos (1+ (atoi str)) 2 0))
(setq ent (subst (cons 1 str) (assoc 1 ent) ent))
(entmod ent)
)
((or (= (car pt) 11) (= (car pt) 25));_Mouse Right button
(setq str (rtos (1- (atoi str)) 2 0))
(setq ent (subst (cons 1 str) (assoc 1 ent) ent))
(entmod ent)
)
)
)
(princ)
)
(princ)
)
(grread 1 13 1) can be used ?(defun c:Test (/ e g l c)
(if (and (setq e (car (entsel "\nSelect text object: ")))
(member (cdr (assoc 0 (entget e))) '("MTEXT" "TEXT"))
)
(while (eq 5 (car (setq g (grread T 15 0))))
(cond ((not l) (setq l (cons (cadadr g) l)))
((apply 'equal (setq c (list (car (setq l (cons (cadadr g) l))) (cadr l)))))
((apply '> c)
(entmod (list (cons 1 (rtos (1+ (distof (cdr (assoc 1 (entget e))))))) (cons -1 e)))
)
((apply '< c)
(entmod (list (cons 1 (rtos (1- (distof (cdr (assoc 1 (entget e))))))) (cons -1 e)))
)
)
)
)
(princ)
)
(defun c:test ( / c e f i l s ss )
(if
(and (setq ss (ssget "_:L" '((0 . "TEXT"))))
(progn
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i)))
s (cdr (assoc 1 (entget e)))
)
(if (equal (atoi s) (read s)) (setq l (cons e l)) l)
)
)
(princ "\nPress [+/-] to Increment/Decrement text...")
)
(while (member (setq c (cadr (grread nil 14 1))) '(43 45 61 95))
(setq f (if (member c '(45 95)) 1- 1+))
(foreach e l
(setq e (entget e))
(entmod (subst (cons 1 (itoa (f (atoi (cdr (assoc 1 e)))))) (assoc 1 e) e))
)
)
)
(princ)
)Nice idea Alan :-)Thanks and nice one to you too. :)
This was my take:
(entmod (list (cons 1 (rtos (1+ (distof (cdr (assoc 1 (entget e))))))) (cons -1 e)))Nice mothod !!!
Nice Idea Alan , how to Against mousewheel zoom .Beats me dude. I did mine the way I did because of your inquiries into the mouse wheel.
Lee Mac Nice too .
Thank you a lot .
You can't detect mouse-wheel scroll using GrRead and I don't think there is an acet-sys-* function for it :-(Probably has to do with GRREAD being created before the mouse had a wheel. :-P
You can't detect mouse-wheel scroll using GrRead and I don't think there is an acet-sys-* function for it :-(Probably has to do with GRREAD being created before the mouse had a wheel. :-P
Thank Alan , Thank Lee :angel:Thank you Lee. :lol:
(defun c:test (/ en ent str pt)
(if (and (setq en (car (entsel "Select Integer Number Text :")))
(setq ent (entget en))
(setq str (cdr (assoc 1 ent)))
(numberp (eval (read str)))
(equal (atoi str) (atof str))
)
(while (and (setq pt (grread t 15 0))
(not (and (= 2 (car pt))
(or (= 13 (cadr pt)) (= 32 (cadr pt)))
)
) ;_Enter Space
(not (or (= (car pt) 11) (= (car pt) 25)));_Right button
)
(cond ((and (= (car pt) 2) (member (cadr pt) (list 65 83 97 115)));_type "a s A S"
(setq str (rtos (1+ (atoi str)) 2 0))
(setq ent (subst (cons 1 str) (assoc 1 ent) ent))
(entmod ent)
)
((and (= (car pt) 2) (member (cadr pt) (list 68 70 100 102)))
(setq str (rtos (1- (atoi str)) 2 0))
(setq ent (subst (cons 1 str) (assoc 1 ent) ent))
(entmod ent)
)
)
)
(princ)
)
(princ)
)
;;;use Alan method
;;;to easy to control add method devided by viewsize .
(defun c:test (/ en ent str ds pto pt)
(if (and (setq en (car (entsel "Select Integer Number Text :")))
(setq ent (entget en))
(setq str (cdr (assoc 1 ent)))
(numberp (eval (read str)))
(equal (atoi str) (atof str))
(setq ds (/ (getvar "viewsize") 100.));_here can be changed cond to your need
(setq pto (grread t 15 0))
)
(while (and (setq pt (grread pto))
(not (and (= 2 (car pt))
(or (= 13 (cadr pt)) (= 32 (cadr pt)))
)
) ;_Enter Space
(not (or (= (car pt) 11) (= (car pt) 25))) ;_Right button
)
(if (and (= (car pt) 5)
(> (abs (- (cadadr pt) (cadadr pto))) ds)
)
(cond
((> (- (cadadr pt) (cadadr pto)) 0);_Y+ move
(setq str (rtos (1+ (atoi str)) 2 0))
(entmod (list (cons 1 str) (cons -1 en)))
(setq pto pt)
)
((< (- (cadadr pt) (cadadr pto)) 0);_Y- move
(setq str (rtos (1- (atoi str)) 2 0))
(entmod (list (cons 1 str) (cons -1 en)))
(setq pto pt)
)
)
(princ)
)
)
(princ)
)
(princ)
)
use type "a s A S" or "d f D F"Code: [Select](defun c:test (/ en ent str pt)
(if (and (setq en (car (entsel "Select Integer Number Text :")))
(setq ent (entget en))
(setq str (cdr (assoc 1 ent)))
(numberp (eval (read str)))
(equal (atoi str) (atof str))
)
(while (and (setq pt (grread t 15 0))
(not (and (= 2 (car pt))
(or (= 13 (cadr pt)) (= 32 (cadr pt)))
)
) ;_Enter Space
(not (or (= (car pt) 11) (= (car pt) 25)));_Right button
)
(cond ((and (= (car pt) 2) (member (cadr pt) (list 65 83 97 115)));_type "a s A S"
(setq str (rtos (1+ (atoi str)) 2 0))
(setq ent (subst (cons 1 str) (assoc 1 ent) ent))
(entmod ent)
)
((and (= (car pt) 2) (member (cadr pt) (list 68 70 100 102)))
(setq str (rtos (1- (atoi str)) 2 0))
(setq ent (subst (cons 1 str) (assoc 1 ent) ent))
(entmod ent)
)
)
)
(princ)
)
(princ)
)
(defun c:hlines ( / *error* g1 g2 gr h l ms p p1 p2 v )
;; Lee Mac 2011
(defun *error* ( m ) (redraw) (princ))
(or *n (setq *n 3))
(if (setq p1 (getpoint "\nSpecify First Corner: "))
(progn
(setq ms (princ "\nSpecify Opposite Corner [+/-]: "))
(while
(progn (setq gr (grread t 15 0) g1 (car gr) g2 (cadr gr))
(cond
( (= 5 g1)(redraw)
(setq h (- (car g2) (car p1))
v (/ (- (cadr g2) (cadr p1)) (1+ *n))
p p1
)
(repeat *n
(setq p (list (car p) (+ v (cadr p)) (caddr p)))
(grdraw p (list (+ (car p) h) (cadr p) (caddr p)) -1)
)
(setq l
(list
p1 (list (+ (car p1) h) (cadr p1) (caddr p1))
g2 (list (car p) (+ v (cadr p)) (caddr p))
)
)
(mapcar '(lambda ( a b ) (grdraw a b 1 -1)) l (append (cdr l) (list (car l))))
)
( (= 2 g1)
(cond
( (member g2 '(45 95))
(if (= 1 *n)
(princ (strcat "\n--> Minimum Number of Lines Reached." ms))
(setq *n (1- *n))
)
)
( (member g2 '(43 61))
(setq *n (1+ *n))
)
)
)
( (= 3 g1)
(setq h (- (car g2) (car p1))
v (/ (- (cadr g2) (cadr p1)) (1+ *n))
)
(repeat *n (setq p1 (list (car p1) (+ v (cadr p1)) (caddr p1)))
(entmakex
(list
(cons 0 "LINE")
(cons 10 (trans p1 1 0))
(cons 11 (trans (list (+ (car p1) h) (cadr p1) (caddr p1)) 1 0))
)
)
)
nil
)
)
)
)
)
)
(redraw) (princ)
)(defun c:vlines ( / *error* g1 g2 gr h l ms p p1 p2 v )
;; Lee Mac 2011
(defun *error* ( m ) (redraw) (princ))
(or *n (setq *n 3))
(if (setq p1 (getpoint "\nSpecify First Corner: "))
(progn
(setq ms (princ "\nSpecify Opposite Corner [+/-]: "))
(while
(progn (setq gr (grread t 15 0) g1 (car gr) g2 (cadr gr))
(cond
( (= 5 g1)(redraw)
(setq h (/ (- (car g2) (car p1)) (1+ *n))
v (- (cadr g2) (cadr p1))
p p1
)
(repeat *n
(setq p (list (+ h (car p)) (cadr p) (caddr p)))
(grdraw p (list (car p) (+ v (cadr p)) (caddr p)) -1)
)
(setq l
(list
p1 (list (car p1) (+ v (cadr p1)) (caddr p1))
g2 (list (+ h (car p)) (cadr p) (caddr p))
)
)
(mapcar '(lambda ( a b ) (grdraw a b 1 -1)) l (append (cdr l) (list (car l))))
)
( (= 2 g1)
(cond
( (member g2 '(45 95))
(if (= 1 *n)
(princ (strcat "\n--> Minimum Number of Lines Reached." ms))
(setq *n (1- *n))
)
)
( (member g2 '(43 61))
(setq *n (1+ *n))
)
)
)
( (= 3 g1)
(setq h (/ (- (car g2) (car p1)) (1+ *n))
v (- (cadr g2) (cadr p1))
)
(repeat *n (setq p1 (list (+ h (car p1)) (cadr p1) (caddr p1)))
(entmakex
(list
(cons 0 "LINE")
(cons 10 (trans p1 1 0))
(cons 11 (trans (list (car p1) (+ v (cadr p1)) (caddr p1)) 1 0))
)
)
)
nil
)
)
)
)
)
)
(redraw) (princ)
)(defun c:hvlines ( / *error* g1 g2 gr h l ms p p1 p2 v )
;; Lee Mac 2011
(defun *error* ( m ) (redraw) (princ))
(or *n (setq *n 3))
(if (setq p1 (getpoint "\nSpecify First Corner: "))
(progn
(setq ms (princ "\nSpecify Opposite Corner [TAB/+/-]: "))
(while
(progn (setq gr (grread t 15 0) g1 (car gr) g2 (cadr gr))
(cond
( (= 5 g1)(redraw)
(if *v
(progn
(setq h (/ (- (car g2) (car p1)) (1+ *n))
v (- (cadr g2) (cadr p1))
p p1
)
(repeat *n
(setq p (list (+ h (car p)) (cadr p) (caddr p)))
(grdraw p (list (car p) (+ v (cadr p)) (caddr p)) -1)
)
(setq l
(list
p1 (list (car p1) (+ v (cadr p1)) (caddr p1))
g2 (list (+ h (car p)) (cadr p) (caddr p))
)
)
)
(progn
(setq h (- (car g2) (car p1))
v (/ (- (cadr g2) (cadr p1)) (1+ *n))
p p1
)
(repeat *n
(setq p (list (car p) (+ v (cadr p)) (caddr p)))
(grdraw p (list (+ (car p) h) (cadr p) (caddr p)) -1)
)
(setq l
(list
p1 (list (+ (car p1) h) (cadr p1) (caddr p1))
g2 (list (car p) (+ v (cadr p)) (caddr p))
)
)
)
)
(mapcar '(lambda ( a b ) (grdraw a b 1 -1)) l (append (cdr l) (list (car l))))
)
( (= 2 g1)
(cond
( (member g2 '(45 95))
(if (= 1 *n)
(princ (strcat "\n--> Minimum Number of Lines Reached." ms))
(setq *n (1- *n))
)
)
( (member g2 '(43 61))
(setq *n (1+ *n))
)
( (= 9 g2)
(setq *v (not *v)) t
)
)
)
( (= 3 g1)
(if *v
(progn
(setq h (/ (- (car g2) (car p1)) (1+ *n))
v (- (cadr g2) (cadr p1))
)
(repeat *n (setq p1 (list (+ h (car p1)) (cadr p1) (caddr p1)))
(entmakex
(list
(cons 0 "LINE")
(cons 10 (trans p1 1 0))
(cons 11 (trans (list (car p1) (+ v (cadr p1)) (caddr p1)) 1 0))
)
)
)
)
(progn
(setq h (- (car g2) (car p1))
v (/ (- (cadr g2) (cadr p1)) (1+ *n))
)
(repeat *n (setq p1 (list (car p1) (+ v (cadr p1)) (caddr p1)))
(entmakex
(list
(cons 0 "LINE")
(cons 10 (trans p1 1 0))
(cons 11 (trans (list (+ (car p1) h) (cadr p1) (caddr p1)) 1 0))
)
)
)
)
)
nil
)
)
)
)
)
)
(redraw) (princ)
)Wrote a more practical one and thought I'd do a crappy GRREAD example:I like thi motion, so i change a little to do with almost object type. With vla-rotate, Lines like ceiling fans ^^Code: [Select](defun c:Test (/ _grAngle _ss2lst lst gr pt)
(vl-load-com)
(defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
(defun _ss2lst (ss / i l)
(if (eq (type ss) 'PICKSET)
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(if (setq lst (_ss2lst (ssget "_:L" '((0 . "INSERT")))))
(while (eq 5 (car (setq gr (grread T 15 0))))
(setq pt (trans (cadr gr) 1 0))
(redraw)
(foreach o lst (vla-put-rotation o (_grAngle (vlax-get o 'InsertionPoint) pt)))
)
)
(redraw)
(princ)
)
(http://www.theswamp.org/screens/alanjt/RotateBlocksToGrReadPoint.gif)
(defun _grAngle (a b) (grdraw (trans a 0 1) (cadr gr) 1 -1) (angle a b))
(defun _Bound-Center (ent opt / p1 p2 _ent eType mid)
;Get center boundingbox of object. If opt, choice InsertionPoint instead of
(setq eType (cdadr (entget (vlax-vla-object->ename ent))))
(setq mid (cond ((and opt (wcmatch eType "INSERT,TEXT,MTEXT"))
(vlax-get ent 'InsertionPoint))
(T
(vla-getboundingbox ent 'p1 'p2)
(mapcar '(lambda (a b) (* 0.5 (+ a b)))
(vlax-safearray->list p1) (vlax-safearray->list p2))
)
)
))
(defun c:Test1 (/ lst gr pt SelSet)
(vl-load-com)
(if (and (setq lst (ssget "_:L"))
(setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))))
(while (eq 5 (car (setq gr (grread T 15 0))))
(setq pt (trans (cadr gr) 1 0))
(redraw)
(vlax-for object Selset (vla-rotate object (vlax-3d-point (_Bound-Center object nil)) (_grAngle (_Bound-Center object nil) pt)))
)
)
(redraw)
(princ)
)
(defun c:Test2 (/ lst gr pt SelSet)
(vl-load-com)
(if (and (setq lst (ssget "_:L"))
(setq SelSet (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))))
(while (eq 5 (car (setq gr (grread T 15 0))))
(setq pt (trans (cadr gr) 1 0))
(redraw)
(vlax-for object Selset (vla-rotate object (vlax-3d-point (_Bound-Center object T)) (_grAngle (_Bound-Center object T) pt)))
)
)
(redraw)
(princ)
)
(defun c:THZ ( / e i j ) (vl-load-com) (setq i (/ pi 2.) j -1.);;-1.
(setq e (entsel "\nText wählen: "))
(setq el1 (entget (car e)))
(setq p0 (cdr (assoc 10 el1)))
(setq muster (cdr (assoc 1 el1)))
(while (setq p1 (getpoint p0 "\nText anschreiben: "))
(progn
(setq p0 p1)
(setq txt (umw_muster (cdr (assoc 1 el1))))
(setq el1 (subst (cons 1 txt) (assoc 1 el1) el1))
(setq el1 (subst (cons 10 p1) (assoc 10 el1) el1))
(entmake el1)
)
;; © Lee Mac 2011
(if
(and
(setq e (entlast))
(eq (vla-get-Objectname (setq e (vlax-ename->vla-object e))) "AcDbText")
(princ "\nPress [Tab] to Change Projection <Accept>")
)
(while (= 9 (cadr (grread nil 12 0)))
(vla-put-rotation e i)
(vla-put-obliqueangle e (setq i (* i (setq j (- j)))))
)
)
)
)
Dynamic Arrow Size:enjoy.
Nice one Alan. This will be very helpful
~Greg
Code: [Select][quote author=Lee Mac link=topic=12813.msg440380#msg440380 date=1310689668]
Some fun with
...
Combining the two
:-)
(defun c:select_text (/ dim_scale half_pi loop new_entity old_entity
ret_val two_pi
)
(defun get_text (cursor_point offset_distance filter / angle1 angle2 ; gets text using a bounding box
base_angle base_point box entity LL point1 point2
selset text_ename text_height UR
)
(defun delta (a1 a2 / r1) ; gets the absolute angle between two vectors
(cond ((> a1 (+ a2 pi)) (setq a2 (+ a2 two_pi))) ; based on code by John Uhden
((> a2 (+ a1 pi)) (setq a1 (+ a1 two_pi)))
)
(setq r1 (- a2 a1))
(if (< r1 0.0)
(setq r1 (+ r1 two_pi))
)
r1
)
(if (vl-string-search "BRICSCAD" (strcase (getvar "acadver"))) ; Bricscad does not like really small selection windows
(if (< offset_distance 0.001) (setq offset_distance 0.001))
)
(setq selset (ssget "c" ; get the text entities at the cursor
(list (- (car cursor_point) offset_distance) (- (cadr cursor_point) offset_distance))
(list (+ (car cursor_point) offset_distance) (+ (cadr cursor_point) offset_distance))
filter
)
)
(setq counter 0
text_ename nil
)
(if selset
(progn
(setq entity (entget (ssname selset 0)) ; just look at first entity
text_height (cdr (assoc 40 entity))
base_angle (cdr (assoc 50 entity))
base_point (cdr (assoc 10 entity))
box (textbox entity) ; get the normalized containing box
point1 (car box) ; normalized LL point
point2 (cadr box) ; normalized UR point
LL (polar (trans (cdr (assoc 10 entity)) 0 1) ; actual LL point
(+ (angle '(0 0) point1) base_angle)
(distance '(0 0) point1)
)
UR (polar LL ; actual UR point
(+ base_angle (angle point1 point2))
(distance point1 point2)
)
angle1 (delta base_angle (angle LL cursor_point)) ; angle from LL to cursor
angle2 (delta base_angle (angle UR cursor_point)) ; from UL to cursor
)
(if (and (>= angle1 0.0) ; test if the cursor is in the included
(<= angle1 half_pi) ; angle at the LL and UL
(>= angle2 pi)
(<= angle2 (+ pi half_pi))
)
(setq text_ename (cdr (assoc -1 entity))) ; return the text's ename
)
(setq counter (1+ counter))
)
)
text_ename
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq old_entity nil
new_entity nil
loop T
dim_scale (getvar "dimscale")
)
(setq half_pi (* PI 0.5)
two_pi (* PI 2.0)
)
(princ "\rSelect text: ")
(while loop
(setq ret_val (car (setq gr_data (grread t 15 2))))
(cond ((= ret_val 5)
(setq new_entity (get_text (cadr gr_data) (* dim_scale 0.05) '((0 . "TEXT"))))
; get text entities at the cursor
(if (/= new_entity old_entity) ; the entity has changed...
(if new_entity ; if the new entity is not nil...
(redraw new_entity 3) ; highlight the new entity
(if old_entity
(redraw old_entity 4) ; unhighlight the old entity
)
)
)
(setq old_entity new_entity) ; store the last entity
)
((= ret_val 3)
(setq loop nil)
)
)
)
(if new_entity ; if the new entity is not nil...
(redraw new_entity 4) ; highlight the new entity
)
(print new_entity) ; return the entity's ename
(princ)
)
A short, quick example to add to the collection:
(http://www.theswamp.org/lilly_pond/leemac/GrArcExample.gif)
Hi Lee! I see you are even taking up hockey in your spare time!
(defun c:cirt ( / cirl p n gr gp an d )
(defun cirl ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 2. pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.0))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.0))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq p (getpoint "\nPick or specify center point : "))
(prompt "\nSpecify precision (< / >) : ")
(setq n 6)
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq an (angle p gp))
(setq d (distance p gp))
(grvecs (cirl n 1)
(list
(list (* d (cos an)) (* d (- (sin an))) 0. (car p))
(list (* d (sin an)) (* d (cos an)) 0. (cadr p))
(list 0. 0. d (caddr p))
'(0. 0. 0. 1.)
)
)
)
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(entmake (list '(0 . "CIRCLE") (cons 10 p) (cons 40 d)))
(redraw)
(princ)
)
(defun c:g-helix ( / *error* _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun qcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (setq k (1+ k)))) g))
(setq p2 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (1+ k))) g))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) (* g g)))
(setq p2 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (1+ k))) (* g g)))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
(setq p2 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (1+ k))) (* g g g)))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq g (/ (- (sqrt 5.) 1.) 2.))
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 6)
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (qcirl1 n 1))
(setq l2 (qcirl2 n 1))
(setq l3 (qcirl3 n 1))
(setq l4 (qcirl4 n 1))
(grvecs (append l1 l2 l3 l4)
(list
(list (* d (cos an)) (* d (- (sin an))) 0. (car pp))
(list (* d (sin an)) (* d (cos an)) 0. (cadr pp))
(list 0. 0. d (caddr pp))
'(0. 0. 0. 1.)
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 0.5 pi) an) d))
(setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
(setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
(setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
'(38 . 0.0)
(cons 10 p1)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p2)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p3)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p4)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p5)
(cons 42 0.0)
'(210 0.0 0.0 1.0)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ pi an) (* d g g g g)))
(setq d (* d g g g g))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 0.5 pi) an) d))
(setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
(setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
(setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
'(38 . 0.0)
(cons 10 p1)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p2)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p3)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p4)
(cons 42 (- (sqrt 2.) 1.))
(cons 10 p5)
(cons 42 0.0)
'(210 0.0 0.0 1.0)
)
)
)
(*error* nil)
)
:)how to use it ? sample please ?
nice thread...
here a function I wrote...
its some kind of interface to speed up the work with the mouse... normally I type the commands, but then I worked with a pen on a tablet; it was annoying to go all the way to the buttons, so I wrote this (code in the attachment).
Its pretty easy to put in more commands... It identifys also right/left click and also one-char-shortcuts... It don't reconize enter or space yet to repeat the last command, but I wanna add this soon...
Have a look...
command = Interface
reltro
Hey kruuger...ahh those crazy evel
load it and then type Interface... ;)
:)
nice thread...
here a function I wrote...
its some kind of interface to speed up the work with the mouse... normally I type the commands, but then I worked with a pen on a tablet; it was annoying to go all the way to the buttons, so I wrote this (code in the attachment).
Its pretty easy to put in more commands... It identifys also right/left click and also one-char-shortcuts... It don't reconize enter or space yet to repeat the last command, but I wanna add this soon...
Have a look...
command = Interface
reltro
EDIT:o sh... sick... :)
That's pretty cool :kewl:
what method do you use to draw this "interfaca"?EDIT:o sh... sick... :)That's pretty cool :kewl:
:) thanks a lot...
Will add a guide to modify it... and the repeat-last-command... but at the moment there isn't much time...
Any other suggestions?
reltro
what method do you use to draw this "interfaca"?
what method do you use to draw this "interfaca"?It uses (grvecs ... ...) to draw and (redraw) to clean the display...
reltro
i mean how do you calculate all those points.? how do you prepare your "graphics"?
k.
;;reading the start-/end-point and also the color of any selected line-object...
(defun C:CreateSymbol (/ s Out ent)
(princ "\nselect Lines")
(if (setq s (ssget '((0 . "LINE"))))
(foreach e (ssnamex s)
(if (= 'ename (type (cadr e)))
(setq ent (entget (cadr e))
Out (cons
(cons
( (lambda (c / )
(if c
c
7
)
)
(cdr (assoc 62 ent))
)
(mapcar
'(lambda (g / p)
(setq p (cdr (assoc g ent)))
(mapcar
'(lambda (a / )
(fix (* a 1000))
)
(list (car p) (cadr p))
)
)
'(10 11)
)
)
Out
)
)
)
)
)
(apply 'append Out)
)
(defun c:ghcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n z gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun qcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -0.5 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -0.5 pi) n))
(repeat n
(setq p1 (polar (list 0. (- (- 1. g)) 0.) (+ (* -0.5 pi) (* a (setq k (1+ k)))) g))
(setq p2 (polar (list 0. (- (- 1. g)) 0.) (+ (* -0.5 pi) (* a (1+ k))) g))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -0.5 pi) n))
(repeat n
(setq p1 (polar (list (- (- g (* g g))) (- (- 1. g)) 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) (* g g)))
(setq p2 (polar (list (- (- g (* g g))) (- (- 1. g)) 0.) (+ (* -1.0 pi) (* a (1+ k))) (* g g)))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -0.5 pi) n))
(repeat n
(setq p1 (polar (list (- (- g (* g g))) (- (* g g g)) 0.) (+ (* -1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
(setq p2 (polar (list (- (- g (* g g))) (- (* g g g)) 0.) (+ (* -1.5 pi) (* a (1+ k))) (* g g g)))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq g (/ (- (sqrt 5.) 1.) 2.))
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 6)
(setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (qcirl1 n -1))
(setq l2 (qcirl2 n -1))
(setq l3 (qcirl3 n -1))
(setq l4 (qcirl4 n -1))
(grvecs (append l1 l2 l3 l4)
(append
(mapcar 'append
(mxm z
(list
(list (* d (cos an)) (* d (sin (- an))) 0.0)
(list (* d (sin an)) (* d (cos an)) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar 'list (trans pp 1 2))
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* -0.5 pi) an) d))
(setq p3 (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g)))
(setq p4 (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g)))
(setq p5 (polar (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g g g)) an (* d g g g)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p2 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p3 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p4 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ pi an) (* d g g g g)))
(setq d (* d g g g g))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* -0.5 pi) an) d))
(setq p3 (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g)))
(setq p4 (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g)))
(setq p5 (polar (polar (polar (polar pp (+ (* -0.5 pi) an) (* d g g)) (+ (- pi) an) (* d g g g)) (+ (* -1.5 pi) an) (* d g g g g)) an (* d g g g)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p2 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p3 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p4 1 z))
(cons 42 (- (- (sqrt 2.) 1.)))
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
)
(*error* nil)
)
(defun c:ghccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm qcirl1 qcirl2 qcirl3 qcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s g pp n z gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun qcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (setq k (1+ k)))) g))
(setq p2 (polar (list 0. (- 1. g) 0.) (+ (* 0.5 pi) (* a (1+ k))) g))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) (* g g)))
(setq p2 (polar (list (- (- g (* g g))) (- 1. g) 0.) (+ (* 1.0 pi) (* a (1+ k))) (* g g)))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun qcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 0.5 pi) n))
(repeat n
(setq p1 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (setq k (1+ k)))) (* g g g)))
(setq p2 (polar (list (- (- g (* g g))) (* g g g) 0.) (+ (* 1.5 pi) (* a (1+ k))) (* g g g)))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq g (/ (- (sqrt 5.) 1.) 2.))
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 6)
(setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (qcirl1 n -1))
(setq l2 (qcirl2 n -1))
(setq l3 (qcirl3 n -1))
(setq l4 (qcirl4 n -1))
(grvecs (append l1 l2 l3 l4)
(append
(mapcar 'append
(mxm z
(list
(list (* d (cos an)) (* d (sin (- an))) 0.0)
(list (* d (sin an)) (* d (cos an)) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar 'list (trans pp 1 2))
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 0.5 pi) an) d))
(setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
(setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
(setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p2 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p3 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p4 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ pi an) (* d g g g g)))
(setq d (* d g g g g))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 0.5 pi) an) d))
(setq p3 (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g)))
(setq p4 (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g)))
(setq p5 (polar (polar (polar (polar pp (+ (* 0.5 pi) an) (* d g g)) (+ pi an) (* d g g g)) (+ (* 1.5 pi) an) (* d g g g g)) an (* d g g g)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p2 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p3 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p4 1 z))
(cons 42 (- (sqrt 2.) 1.))
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
)
(*error* nil)
)
(defun c:chcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun hcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.5 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.5))
(setq p2 (polar (list -0.5 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.5))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.25))
(setq p2 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.25))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.375 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.125))
(setq p2 (polar (list -0.375 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.125))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 12)
(setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (hcirl1 n -1))
(setq l2 (hcirl2 n -1))
(setq l3 (hcirl3 n -1))
(setq l4 (hcirl4 n -1))
(grvecs (append l1 l2 l3 l4)
(append
(mapcar 'append
(mxm z
(list
(list (* d (cos an)) (* d (sin (- an))) 0.0)
(list (* d (sin an)) (* d (cos an)) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar 'list (trans pp 1 2))
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 pp)
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
(setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 -1.0)
(cons 10 (trans p2 1 z))
(cons 42 -1.0)
(cons 10 (trans p3 1 z))
(cons 42 -1.0)
(cons 10 (trans p4 1 z))
(cons 42 -1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.0625 d)))
(setq d (* 0.0625 d))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 pp)
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
(setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 -1.0)
(cons 10 (trans p2 1 z))
(cons 42 -1.0)
(cons 10 (trans p3 1 z))
(cons 42 -1.0)
(cons 10 (trans p4 1 z))
(cons 42 -1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
)
(*error* nil)
)
(defun c:chccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun hcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.5 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.5))
(setq p2 (polar (list -0.5 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.5))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.25))
(setq p2 (polar (list -0.25 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.25))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.375 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.125))
(setq p2 (polar (list -0.375 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.125))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 12)
(setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (hcirl1 n -1))
(setq l2 (hcirl2 n -1))
(setq l3 (hcirl3 n -1))
(setq l4 (hcirl4 n -1))
(grvecs (append l1 l2 l3 l4)
(append
(mapcar 'append
(mxm z
(list
(list (* d (cos an)) (* d (sin (- an))) 0.0)
(list (* d (sin an)) (* d (cos an)) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar 'list (trans pp 1 2))
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 pp)
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
(setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 1.0)
(cons 10 (trans p2 1 z))
(cons 42 1.0)
(cons 10 (trans p3 1 z))
(cons 42 1.0)
(cons 10 (trans p4 1 z))
(cons 42 1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.0625 d)))
(setq d (* 0.0625 d))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 pp)
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.5 d)))
(setq p5 (polar pp (+ (* 1.0 pi) an) (* 0.25 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 1.0)
(cons 10 (trans p2 1 z))
(cons 42 1.0)
(cons 10 (trans p3 1 z))
(cons 42 1.0)
(cons 10 (trans p4 1 z))
(cons 42 1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
)
(*error* nil)
)
(defun c:cqhcw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun hcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.25 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.75))
(setq p2 (polar (list -0.25 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.75))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.5625))
(setq p2 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.5625))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* -1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.203125 0. 0.) (+ (* -1.0 pi) (* a (setq k (1+ k)))) 0.421875))
(setq p2 (polar (list -0.203125 0. 0.) (+ (* -1.0 pi) (* a (1+ k))) 0.421875))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 12)
(setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (hcirl1 n -1))
(setq l2 (hcirl2 n -1))
(setq l3 (hcirl3 n -1))
(setq l4 (hcirl4 n -1))
(grvecs (append l1 l2 l3 l4)
(append
(mapcar 'append
(mxm z
(list
(list (* d (cos an)) (* d (sin (- an))) 0.0)
(list (* d (sin an)) (* d (cos an)) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar 'list (trans pp 1 2))
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 (polar pp an (* 0.5 d)))
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
(setq p5 (polar pp an (* 0.21875 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 -1.0)
(cons 10 (trans p2 1 z))
(cons 42 -1.0)
(cons 10 (trans p3 1 z))
(cons 42 -1.0)
(cons 10 (trans p4 1 z))
(cons 42 -1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.31640625 d)))
(setq d (* 0.31640625 d))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 (polar pp an (* 0.5 d)))
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
(setq p5 (polar pp an (* 0.21875 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 -1.0)
(cons 10 (trans p2 1 z))
(cons 42 -1.0)
(cons 10 (trans p3 1 z))
(cons 42 -1.0)
(cons 10 (trans p4 1 z))
(cons 42 -1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
)
(*error* nil)
)
(defun c:cqhccw ( / *error* trp mxm mxv _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho ape as osm hcirl1 hcirl2 hcirl3 hcirl4 l1 l2 l3 l4 p1 p2 p3 p4 p5 o p s pp n z gr gp gps gpp an d )
(vl-load-com)
(defun *error* ( msg )
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(if msg (prompt msg))
(princ)
)
;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix
(defun trp ( m )
(apply 'mapcar (cons 'list m))
)
;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices
(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(defun hcirl1 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar '(0. 0. 0.) (* a (setq k (1+ k))) 1.))
(setq p2 (polar '(0. 0. 0.) (* a (1+ k)) 1.))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl2 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.25 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.75))
(setq p2 (polar (list -0.25 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.75))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl3 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (setq k (1+ k)))) 0.5625))
(setq p2 (polar (list -0.0625 0. 0.) (+ (* 0.0 pi) (* a (1+ k))) 0.5625))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(defun hcirl4 ( n c / k a p1 p2 li lst )
(setq k -1)
(setq a (/ (* 1.0 pi) n))
(repeat n
(setq p1 (polar (list -0.203125 0. 0.) (+ (* 1.0 pi) (* a (setq k (1+ k)))) 0.421875))
(setq p2 (polar (list -0.203125 0. 0.) (+ (* 1.0 pi) (* a (1+ k))) 0.421875))
(setq li (cons c (list p1 p2)))
(setq lst (cons li lst))
)
(apply 'append (reverse lst))
)
(setq pp (getpoint "\nPick or specify center point : "))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq p t) (setq p nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
(prompt "\nSpecify precision (< / >) : ")
(setq n 12)
(setq z (trp (mapcar '(lambda ( x ) (trans x 1 2 t)) '((1.0 0.0) (0.0 1.0) (0.0 0.0)))))
(while (not (eq (car (setq gr (grread t 15 0))) 3))
(redraw)
(if (listp (cadr gr))
(progn
(setq gp (cadr gr))
(setq gpp (cadr gr))
(if gps (setq an (angle pp gps)) (setq an (angle pp gp)))
(if gps (setq d (distance pp gps)) (setq d (distance pp gp)))
(setq l1 (hcirl1 n -1))
(setq l2 (hcirl2 n -1))
(setq l3 (hcirl3 n -1))
(setq l4 (hcirl4 n -1))
(grvecs (append l1 l2 l3 l4)
(append
(mapcar 'append
(mxm z
(list
(list (* d (cos an)) (* d (sin (- an))) 0.0)
(list (* d (sin an)) (* d (cos an)) 0.0)
'(0.0 0.0 1.0)
)
)
(mapcar 'list (trans pp 1 2))
)
'((0.0 0.0 0.0 1.0))
)
)
)
)
(cond
( (eq (cadr gr) 15)
(if (eq o t) (setq o nil) (setq o t))
)
( (eq (cadr gr) 21)
(if (eq p t) (setq p nil) (setq p t))
)
( (eq (cadr gr) 6)
(if (eq s t) (setq s nil) (setq s t))
)
)
(cond
( (and o p s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pp gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pp gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pp gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pp gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pp gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(if (not (equal gps gpp 1e-6))
(_grX gps (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
(if (eq (cadr gr) 60) (setq n (1- n)))
(if (eq (cadr gr) 62) (setq n (1+ n)))
(if (zerop n) (setq n 1))
)
(setq an (angle pp gps))
(setq d (distance pp gps))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 (polar pp an (* 0.5 d)))
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
(setq p5 (polar pp an (* 0.21875 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 1.0)
(cons 10 (trans p2 1 z))
(cons 42 1.0)
(cons 10 (trans p3 1 z))
(cons 42 1.0)
(cons 10 (trans p4 1 z))
(cons 42 1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
(redraw)
(while (eq (getstring "\nAnother turn - ENTER; Any other key+ENTER to finish") "")
(setq pp (polar p5 (+ (* 1.0 pi) an) (* 0.31640625 d)))
(setq d (* 0.31640625 d))
(setq p1 (polar pp an d))
(setq p2 (polar pp (+ (* 1.0 pi) an) d))
(setq p3 (polar pp an (* 0.5 d)))
(setq p4 (polar pp (+ (* 1.0 pi) an) (* 0.625 d)))
(setq p5 (polar pp an (* 0.21875 d)))
(entmake (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 5)
(cons 70 (if (eq (getvar 'plinegen) 1) 128 0))
(cons 38 (caddr (trans pp 1 z)))
(cons 10 (trans p1 1 z))
(cons 42 1.0)
(cons 10 (trans p2 1 z))
(cons 42 1.0)
(cons 10 (trans p3 1 z))
(cons 42 1.0)
(cons 10 (trans p4 1 z))
(cons 42 1.0)
(cons 10 (trans p5 1 z))
(cons 42 0.0)
(cons 210 z)
)
)
)
(*error* nil)
)
(defun C:Rect,Ratio ( / P1 P vector,Len vector,Len,get vector,Len,set vector,cross opt arsin arcos opt2 Rect0 Rect1 Rect2 Rect3 tmpRatio typed UserPrompt)
(setq P1 (getpoint "Pick StartPoint: ")
vector,Len,get (lambda (v / ) (sqrt (apply '+ (mapcar '(lambda (a / ) (expt a 2)) v))))
vector,Len,set (lambda (v l / f) (setq f (/ (float l) (vector,Len,get v))) (mapcar '(lambda (a /) (* a f)) v))
vector,cross (lambda (a b)
(mapcar
'(lambda (n / )
(-
(* (nth (car n) a)(nth (cadr n) b))
(* (nth (cadr n) a) (nth (car n) b))
)
)
'((1 2) (2 0) (0 1))
)
)
arsin (lambda (x)
(cond
((= x 1.0) (/ pi 2.0))
((= x -1.0) (/ pi -2.0))
((< (abs x) 1.0) (atan (/ x (sqrt (- 1.0 (* x x))))))
('default (*error* (strcat "\n error: bad argument: " (rtos (abs x) 2) ">1.0\n ")))
)
)
opt 0
opt2 0
ratio 2
)
(setq UserPrompt (lambda (/) (princ "\nPick Second Point or toogle between modes with RIGHTMOUSE and TAB or enter a new ratio (1:x) ")))
(eval
(list 'defun '*error* '(msg / )
(list
(lambda (err / )
(setq *error* err)
(redraw)
(if msg
(progn
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
(princ msg)
)
(*error* msg)
)
)
)
*error*
)
)
)
(UserPrompt)
(while (not (= (car (setq P (grread 'T))) 3))
(cond
((= (car P) 5)
( (lambda (P / v l v,perp H ang)
(setq v (mapcar '- P P1)
l (vector,Len,get v)
)
(if (> l 0)
(cond
((= opt 0)
(setq v,perp
(vector,Len,set
(vector,cross v '(0 0 1))
(if (= opt2 0)
(/ l (float ratio))
(* l ratio)
)
)
)
(setq Rect0 P1
Rect1 (mapcar '+ P1 v,perp)
Rect2 (mapcar '+ Rect1 v)
Rect3 P
)
(redraw)
(grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
)
((= opt 1)
(setq v,perp
(vector,Len,set
(vector,cross v '(0 0 -1))
(if (= opt2 0)
(/ l (float ratio))
(* l ratio)
)
)
)
(setq Rect0 P1
Rect1 (mapcar '+ P1 v,perp)
Rect2 (mapcar '+ Rect1 v)
Rect3 P
)
(redraw)
(grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
)
((= opt 2)
(setq H (sqrt (+ 1 (expt ratio 2))))
(setq ang (arsin (/ ratio H)))
(setq l (* (cos ang) l))
(setq ang
(if (= opt2 0)
(- (angle P1 P) ang)
(+ (angle P1 P) ang)
)
)
(setq Rect0 P1
Rect1 (polar P1 ang l)
Rect2 P
Rect3 (polar Rect2 ang (* -1 l))
)
(redraw)
(grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
)
)
)
)
(cadr P)
)
)
((= (car P) 25)
(if (= opt 2)
(setq opt 0)
(setq opt (1+ opt))
)
)
((and (= (car P) 2) (or (and (> (cadr P) 47) (< (cadr P) 58)) (= (cadr P) 46)))
(setq typed (chr (cadr P)))
(princ typed)
(setq tmpRatio (cons typed tmpRatio))
)
((and (= (car P) 2) (= (cadr P) 8))
(princ (chr (cadr P)))
(setq tmpRatio (cdr tmpRatio))
)
((and (= (car P) 2) (or (= (cadr P) 13) (= (cadr P) 32)))
(if tmpRatio
(setq ratio (read (apply 'strcat (reverse tmpRatio)))
tmpRatio nil
)
)
(UserPrompt)
)
((and (= (car P) 2) (= (cadr P) 9))
(if (= opt2 1)
(setq opt2 0)
(setq opt2 1)
)
)
)
)
(if (apply 'and '(Rect0 Rect1 Rect2 Rect3))
(command "_pline" Rect0 Rect1 Rect2 Rect3 "_close")
)
(*error* nil)
)
Its a lil useless without OSNAP... :(
(defun C:Rect,Ratio ( / _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho P1 P PS oo pp ss vector,Len vector,Len,get vector,Len,set vector,cross opt arsin arcos opt2 Rect0 Rect1 Rect2 Rect3 tmpRatio typed UserPrompt )
(vl-load-com)
(defun _acapp nil
(eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
(_acapp)
)
(defun _getosmode ( os / lst )
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _grX ( p s c / -s r j )
(setq -s (- s)
r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
j p
)
(grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
(grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
p
)
(defun _OLE->ACI ( c )
(apply '_RGB->ACI (_OLE->RGB c))
)
(defun _OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
(defun _RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (_acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
(defun _snap ( p osm )
(if (osnap p (_getosmode osm))
(osnap p (_getosmode osm))
p
)
)
(defun _polarangs ( ang / n k a l )
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar ( p0 p flag ang / a b an )
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho ( p0 p flag )
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(setq P1 (getpoint "\nPick StartPoint : ")
vector,Len,get (lambda (v / ) (sqrt (apply '+ (mapcar '(lambda (a / ) (expt a 2)) v))))
vector,Len,set (lambda (v l / f) (setq f (/ (float l) (vector,Len,get v))) (mapcar '(lambda (a /) (* a f)) v))
vector,cross (lambda (a b)
(mapcar
'(lambda (n / )
(-
(* (nth (car n) a)(nth (cadr n) b))
(* (nth (cadr n) a) (nth (car n) b))
)
)
'((1 2) (2 0) (0 1))
)
)
arsin (lambda (x)
(cond
((= x 1.0) (/ pi 2.0))
((= x -1.0) (/ pi -2.0))
((< (abs x) 1.0) (atan (/ x (sqrt (- 1.0 (* x x))))))
('default (*error* (strcat "\n error: bad argument: " (rtos (abs x) 2) ">1.0\n ")))
)
)
opt 0
opt2 0
ratio 2
)
(setq UserPrompt (lambda (/) (princ "\nPick Second Point or toogle between modes with RIGHTMOUSE and TAB or enter a new ratio (1:x) = 1:")))
(setvar 'orthomode 1)
(setq ape (getvar 'aperture))
(setvar 'aperture 40)
(setq as (getvar 'autosnap))
(setvar 'autosnap 31)
(setq osm (getvar 'osmode))
(setvar 'osmode 15359)
(if (eq (getvar 'orthomode) 1) (setq oo t) (setq oo nil))
(if (eq (logand (getvar 'autosnap) 8) 8) (setq pp t) (setq pp nil))
(if (eq (logand (getvar 'autosnap) 16) 16) (setq ss t) (setq ss nil))
(eval
(list 'defun '*error* '(msg / )
(list
(lambda (err / )
(setq *error* err)
(if ape (setvar 'aperture ape))
(if as (setvar 'autosnap as))
(if osm (setvar 'osmode osm))
(redraw)
(if msg
(progn
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
(princ msg)
)
(*error* msg)
)
)
(princ)
)
*error*
)
)
)
(UserPrompt)
(while (not (= (car (setq P (grread 'T))) 3))
(cond
((= (car P) 5)
( (lambda (P / v l v,perp H ang)
(cond
( (and oo pp ss)
(setq PS (_snap (_ortho P1 P t) (getvar 'osmode)))
)
( (and oo (not pp) ss)
(setq PS (_snap (_ortho P1 P t) (getvar 'osmode)))
)
( (and (not oo) pp ss)
(setq PS (_snap (_polar P1 P t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not oo) (not pp) ss)
(setq PS (_snap P (getvar 'osmode)))
)
( (and oo pp (not ss))
(setq PS (_ortho P1 P t))
)
( (and oo (not pp) (not ss))
(setq PS (_ortho P1 P t))
)
( (and (not oo) pp (not ss))
(setq PS (_polar P1 P t (getvar 'polarang)))
)
( (and (not oo) (not pp) (not ss))
(setq PS P)
)
)
(setq v (mapcar '- PS P1)
l (vector,Len,get v)
)
(if (> l 0)
(cond
((= opt 0)
(setq v,perp
(vector,Len,set
(vector,cross v '(0 0 1))
(if (= opt2 0)
(/ l (float ratio))
(* l ratio)
)
)
)
(setq Rect0 P1
Rect1 (mapcar '+ P1 v,perp)
Rect2 (mapcar '+ Rect1 v)
Rect3 PS
)
(redraw)
(grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
)
((= opt 1)
(setq v,perp
(vector,Len,set
(vector,cross v '(0 0 -1))
(if (= opt2 0)
(/ l (float ratio))
(* l ratio)
)
)
)
(setq Rect0 P1
Rect1 (mapcar '+ P1 v,perp)
Rect2 (mapcar '+ Rect1 v)
Rect3 PS
)
(redraw)
(grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
)
((= opt 2)
(setq H (sqrt (+ 1 (expt ratio 2))))
(setq ang (arsin (/ ratio H)))
(setq l (* (cos ang) l))
(setq ang
(if (= opt2 0)
(- (angle P1 PS) ang)
(+ (angle P1 PS) ang)
)
)
(setq Rect0 P1
Rect1 (polar P1 ang l)
Rect2 PS
Rect3 (polar Rect2 ang (* -1 l))
)
(redraw)
(grvecs (list -7 Rect0 Rect1 Rect1 Rect2 Rect2 Rect3 Rect3 Rect0))
)
)
)
)
(cadr P)
)
)
((= (car P) 25)
(if (= opt 2)
(setq opt 0)
(setq opt (1+ opt))
)
)
((and (= (car P) 2) (or (and (> (cadr P) 47) (< (cadr P) 58)) (= (cadr P) 46)))
(setq typed (chr (cadr P)))
(princ typed)
(setq tmpRatio (cons typed tmpRatio))
)
((and (= (car P) 2) (= (cadr P) 8))
(princ (chr (cadr P)))
(setq tmpRatio (cdr tmpRatio))
)
((and (= (car P) 2) (or (= (cadr P) 13) (= (cadr P) 32)))
(if tmpRatio
(setq ratio (read (apply 'strcat (reverse tmpRatio)))
tmpRatio nil
)
)
(UserPrompt)
)
((and (= (car P) 2) (= (cadr P) 9))
(if (= opt2 1)
(setq opt2 0)
(setq opt2 1)
)
)
((and (= (car P) 2) (= (cadr P) 15))
(if (eq oo t) (setq oo nil) (setq oo t))
)
((and (= (car P) 2) (= (cadr P) 21))
(if (eq pp t) (setq pp nil) (setq pp t))
)
((and (= (car P) 2) (= (cadr P) 6))
(if (eq ss t) (setq ss nil) (setq ss t))
)
)
(if (not (equal PS (cadr P) 1e-6))
(_grX PS (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
)
)
(if (apply 'and '(Rect0 Rect1 Rect2 Rect3))
(command "_pline" "_non" Rect0 "_non" Rect1 "_non" Rect2 "_non" Rect3 "_close")
)
(*error* nil)
)
Reltro,
Very neat menu concept! Have you considered using entmake to create text on the fly rather than vectoring it? One small suggestion, make the text that names the current command a different color than white so that it stands out a little more.
I've implemented Lee's SNAPS to your function... Hope you don't mind...
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?
I've implemented Lee's SNAPS to your function... Hope you don't mind...Why do you insist on removing my name & author prefix from every line of code that you steal from me...?
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?
Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable...
Why do you insist on removing my name & author prefix from every line of code that you steal from me...?
Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable...
That is feeble excuse in my opinion -
Removing the author prefix shortens the code by what, 2 characters?
And if anything, the headers add clarity to the code, as they describe the purpose of each function.
I don't wish to derail this thread, but in short, if you are going to copy/paste entire chunks of my code, at least have the courtesy to retain the few headers which accompany it, and not go to every effort to remove all attribution from the code.
Im not turning a blind eye nor do I condone ...
I'm with you, bud :)Why do you insist on removing my name & author prefix from every line of code that you steal from me...?
Simple reason of removing prefixes is to avoid confusion, to shorten code and to make it more readable...
That is feeble excuse in my opinion -
Removing the author prefix shortens the code by what, 2 characters?
And if anything, the headers add clarity to the code, as they describe the purpose of each function.
I don't wish to derail this thread, but in short, if you are going to copy/paste entire chunks of my code, at least have the courtesy to retain the few headers which accompany it, and not go to every effort to remove all attribution from the code.
I'm with Lee 100% here. This community has immense power because of the people who freely contribute and they have earned the right to be recognized for it.
Ah, well, I apologize for trying to keep the conversation civil then. Feel free to insult, abuse, attack, insult as you see fit.Lee did not insult or abuse, he simply asked why the person always removes his credit from his posts.
…where were you guys during my "moderator cleanup effort", "subject lines are good", and "or is evil campaign"?
(vl-load-com)
;; I usually set these globally before any drawing session begins but I explicitly set them
;; here to make the code work for you.
(setq *ax-acad-object* (vlax-get-acad-object)
*ax-active-document* (vla-get-ActiveDocument *ax-acad-object*)
)
;; test function
(defun c:activetext ( / gr cp obj oldh ip h hr)
;...initially create our mtext before actively moving it
(setq hr 60)
(setq cp (getvar 'VIEWCTR))
(setq oldh (getvar 'VIEWSIZE))
(setq obj (axdraw-mtext (pt-to-callout cp) cp 8))
(vla-put-AttachmentPoint obj acAttachmentPointMiddleCenter)
(vla-put-Height obj (/ oldh hr))
(put-transparency nil 15)
;....move the text around
(while (= 5 (car (setq gr (grread T 1 0))))
(setq p (cadr gr) ;this is the current cursor position
ip (vla-get-InsertionPoint obj)
)
(vla-put-TextString obj (pt-to-callout p))
;...if we have zoomed in or out then readjust the text height to remain constant
(if (/= oldh (setq h (getvar 'VIEWSIZE)))
(progn
(vla-ScaleEntity obj ip (/ h oldh))
(setq oldh h)
)
)
;...if the cursor has moved then move the mtext to comply
(if (not (equal ip p))(vla-move obj ip (vlax-3D-point p)))
)
(vla-Delete obj) ;now delete the text because we picked a point on the screen
(princ)
)
;; Change the transparency of an entity
(defun put-transparency ( nam n / echo )
(setq echo (getvar 'CMDECHO))
(if (null nam)(setq nam (entlast)))
(setvar 'CMDECHO 0)
(vl-cmdf "._CHPROP" nam "TR" n "" "")
(setvar 'CMDECHO echo)
)
;; Return the object for the space that the user is currently in.
(defun ActiveSpace nil
(vlax-get-property (eval *ax-active-document*)
(if (= (getvar 'CVPORT) 1) 'PaperSpace 'ModelSpace)))
;; Place a piece of mtext into the drawing
(defun axdraw-mtext ( str ip wid )
(vla-AddMtext (ActiveSpace) (vlax-3D-point (trans ip 1 0)) wid str)
)
;; Given a point format a text input for the coordinates of the point
(defun pt-to-callout ( p / x y xstr yxtr )
(setq x (car p)
y (cadr p)
xstr (strcat "X: " (rtos x 2 6))
ystr (strcat "Y: " (rtos y 2 6))
)
(strcat xstr "\\P" ystr)
)
;v1.1: add object
(defun hp:pointer (_pt c obj / p tp l ip vs) ; v1.1
(if obj (setq obj(vlax-ename->vla-object obj)))
(while (and (= (setq p (car (setq tp (grread t 15 0)))) 5) (setq l (cadr tp)))
(redraw)
(grvecs
(apply
'append
(mapcar
''((x)
(list
6
_pt
(polar _pt (* pi x)(* 50. (setq vs (/ (getvar "viewsize") (cadr (getvar "screensize"))))))
)
)
'(0.0 0.5 1.0 1.5)
) ;_ end of mapcar
) ;_ end of apply
) ;_ end of grvecs
(setq ip (osnap l "_nea")
ip (if ip
ip
l
) ;_ end of if
a (angle _pt ip)
sz (* 50. vs)
ang (/ pi 6.37)
d (* sz 0.25)
ep (polar ip (+ a pi) 0. );(* sz 0.5)
) ;_ end of setq
(grvecs
(apply 'append
(mapcar ''((x) (list c ep x))
(list (polar ip a sz ) (polar ep (+ a ang) d) (polar ep (- a ang) d))
) ;_ end of mapcar
) ;_ end of apply
) ;_ end of grvecs
(if obj
(vlax-put obj "InsertionPoint" (polar _pt (angle _pt ip) (+(distance _pt ip) 0.2 sz))))
) ;_ end of while
;;; (redraw)
ip
) ;_ end of defun
http://www.theswamp.org/index.php?topic=12813.225
;example call:(defun c:test (/ tx)
(setq tx (car (entsel)))
(hp:pointer (getpoint) 2 tx))
(defun c:myline ( / *error* osm omo aus ape doc drft osGrv o p s
osMark _getosmode get_osmode osmode-grvecs-lst _snap _polarangs _polar _ortho
pt gr gp oPt gps )
(vl-load-com)
(defun *error* (msg)
(if osm (setvar 'osmode osm))
(if omo (setvar 'orthomode omo))
(if aus (setvar 'autosnap aus))
(if ape (setvar 'aperture ape))
(if msg (prompt msg))
(redraw)
(princ)
)
(setq osm (getvar 'osmode))
(setq omo (getvar 'orthomode))
(setq aus (getvar 'autosnap))
(if (eq omo 1) (setq o t) (setq o nil))
(if (eq (logand aus 8) 8) (setq p t) (setq p nil))
(if (< 0 osm 16384) (setq s t) (setq s nil))
(setq ape (getvar 'aperture))
(setvar 'aperture 10)
(defun _getosmode (os / lst)
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun osMark (o / s)
(setq s (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))
o (cons (trans (car o) 1 3) (cdr o)))
(grvecs (cdr (assoc (cadr o) osGrv))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
(list 0. 0. 0. 1.))))
(defun get_osmode nil ; by Evgeniy Elpanov
(mapcar
(function cdr)
(vl-remove-if
(function (lambda (x) (zerop (logand (getvar "OSMODE") (car x)))))
'((0 . "_non")
(1 . "_end")
(2 . "_mid")
(4 . "_cen")
(8 . "_nod")
(16 . "_qua")
(32 . "_int")
(64 . "_ins")
(128 . "_per")
(256 . "_tan")
(512 . "_nea")
(2048 . "_app")))))
(defun osmode-grvecs-lst (col ass / -ass)
; By Evgeniy Elpanov (Modified by Lee Mac)
(setq -ass (- ass))
(list (list "_non"
col (list 0.0 -ass) (list 0.0 ass)
col (list -ass 0.0) (list ass 0.0))
(list "_end"
col (list -ass -ass) (list -ass ass)
col (list (1- -ass) (1- -ass)) (list (1- -ass) (1+ ass))
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list ass ass) (list ass -ass)
col (list (1+ ass) (1+ ass)) (list (1+ ass) (1- -ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
(list "_mid"
col (list -ass -ass) (list 0. ass)
col (list (1- -ass) (1- -ass)) (list 0. (1+ ass))
col (list 0. ass) (list ass -ass)
col (list 0. (1+ ass)) (list (1+ ass) (1- -ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
(list "_cen"
7 (list (* -ass 0.2) 0.) (list (* ass 0.2) 0.)
7 (list 0. (* -ass 0.2)) (list 0. (* ass 0.2))
col (list -ass 0.) (list (* -ass 0.86) (* ass 0.5))
col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
col (list 0. ass) (list (* ass 0.5) (* ass 0.86))
col (list (* ass 0.5) (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
col (list (* ass 0.86) (* ass 0.5)) (list ass 0.)
col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
col (list (* -ass 0.5) (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
col (list (* -ass 0.86) (* -ass 0.5)) (list -ass 0.))
(list "_nod"
col (list -ass -ass) (list ass ass)
col (list -ass ass) (list ass -ass)
col (list -ass 0.) (list (* -ass 0.86) (* ass 0.5))
col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
col (list 0. ass) (list (* ass 0.5) (* ass 0.86))
col (list (* ass 0.5) (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
col (list (* ass 0.86) (* ass 0.5)) (list ass 0.)
col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
col (list (* -ass 0.5) (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
col (list (* -ass 0.86) (* -ass 0.5)) (list -ass 0.))
(list "_qua"
col (list 0. -ass) (list -ass 0.)
col (list 0. (1- -ass)) (list (1- -ass) 0.)
col (list -ass 0.) (list 0. ass)
col (list (1- -ass) 0.) (list 0. (1+ ass))
col (list 0. ass) (list ass 0.)
col (list 0. (1+ ass)) (list (1+ ass) 0.)
col (list ass 0.) (list 0. -ass)
col (list (1+ ass) 0.) (list 0. (1- -ass)))
(list "_int"
col (list -ass -ass) (list ass ass)
col (list -ass (1+ -ass)) (list ass (1+ ass))
col (list (1+ -ass) -ass) (list (1+ ass) ass)
col (list -ass ass) (list ass -ass)
col (list -ass (1+ ass)) (list ass (1+ -ass))
col (list (1+ -ass) ass) (list (1+ ass) -ass))
(list "_ins"
col (list (* -ass 0.1) (* -ass 0.1)) (list -ass (* -ass 0.1))
col (list -ass (* -ass 0.1)) (list -ass ass)
col (list -ass ass) (list (* ass 0.1) ass)
col (list (* ass 0.1) ass) (list (* ass 0.1) (* ass 0.1))
col (list (* ass 0.1) (* ass 0.1)) (list ass (* ass 0.1))
col (list ass (* ass 0.1)) (list ass -ass)
col (list ass -ass) (list (* -ass 0.1) -ass)
col (list (* -ass 0.1) -ass) (list (* -ass 0.1) (* -ass 0.1))
col (list (1- (* -ass 0.1)) (1- (* -ass 0.1))) (list (1- -ass) (1- (* -ass 0.1)))
col (list (1- -ass) (1- (* -ass 0.1))) (list (1- -ass) (1+ ass))
col (list (1- -ass) (1+ ass)) (list (1+ (* ass 0.1)) (1+ ass))
col (list (1+ (* ass 0.1)) (1+ ass)) (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
col (list (1+ (* ass 0.1)) (1+ (* ass 0.1))) (list (1+ ass) (1+ (* ass 0.1)))
col (list (1+ ass) (1+ (* ass 0.1))) (list (1+ ass) (1- -ass))
col (list (1+ ass) (1- -ass)) (list (1- (* -ass 0.1)) (1- -ass))
col (list (1- (* -ass 0.1)) (1- -ass)) (list (1- (* -ass 0.1)) (1- (* -ass 0.1))))
(list "_tan"
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list -ass 0.) (list (* -ass 0.86) (* ass 0.5))
col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
col (list 0. ass) (list (* ass 0.5) (* ass 0.86))
col (list (* ass 0.5) (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
col (list (* ass 0.86) (* ass 0.5)) (list ass 0.)
col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
col (list (* -ass 0.5)(* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
col (list (* -ass 0.86)(* -ass 0.5)) (list -ass 0.))
(list "_per"
col (list -ass -ass) (list -ass ass)
col (list (1- -ass) (1- -ass)) (list (1- -ass) (1+ ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass))
col (list -ass 0.) (list 0. 0.)
col (list -ass -1.) (list 0. -1.)
col (list 0. 0.) (list 0. -ass)
col (list -1. 0.) (list -1. -ass))
(list "_nea"
col (list -ass -ass) (list ass ass)
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list -ass ass) (list ass -ass)
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
(list "_app"
col (list -ass -ass) (list ass ass)
col (list ass -ass) (list -ass ass)
col (list -ass -ass) (list -ass ass)
col (list (1- -ass) (1- -ass)) (list (1- -ass) (1+ ass))
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list ass ass) (list ass -ass)
col (list (1+ ass) (1+ ass)) (list (1+ ass) (1- -ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))))
(defun _snap (p os)
(if (osnap p (_getosmode os))
(osnap p (_getosmode os))
p
)
)
(defun _polarangs (ang / n k a l)
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar (p0 p flag ang / a b an)
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho (p0 p flag)
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object))
drft (vla-get-drafting
(vla-get-preferences
(vlax-get-acad-object)))
osGrv (osmode-grvecs-lst
(vla-get-AutoSnapMarkerColor drft)
(vla-get-AutoSnapMarkerSize drft)))
;;;--------- main function ---------;;;
(setq pt (getpoint "\nPick or specify point : "))
(while (/= 3 (car (setq gr (grread 't 15 0))))
(redraw)
(cond
( (and (= (car gr) 5) (listp (setq gp (cadr gr))))
(if (and (< 0 (getvar "OSMODE") 16384)
(setq oPt (vl-remove-if (function null)
(mapcar
(function
(lambda (x / o)
(if (setq o (osnap gp x))
(list (distance gp o) o x gp)))) (get_osmode)))))
(setq oPt (cdar (vl-sort oPt (function (lambda (a b) (< (car a) (car b)))))))
(setq oPt (list (osnap gp "_non") "_non" gp)))
(and oPt (OsMark oPt))
(cond
( (and o p s)
(setq gps (_snap (_ortho pt gp t) (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap (_ortho pt gp t) (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap (_polar pt gp t (getvar 'polarang)) (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap gp (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pt gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pt gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pt gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(grdraw pt gps 3 1)
)
( (and (= (car gr) 2) (= (cadr gr) 6))
(cond
( (< 0 osm 16384) (setq osm (+ osm 16384)) (setvar 'osmode osm) )
( (>= osm 16384) (setq osm (- osm 16384)) (setvar 'osmode osm) )
)
(if (eq s t) (setq s nil) (setq s t))
)
( (and (= (car gr) 2) (= (cadr gr) 15))
(cond
( (= omo 0) (setq omo 1) (setvar 'orthomode 1) )
( (= omo 1) (setq omo 0) (setvar 'orthomode 0) )
)
(if (eq o t) (setq o nil) (setq o t))
)
( (and (= (car gr) 2) (= (cadr gr) 21))
(cond
( (= aus 0) (setq aus 8) (setvar 'autosnap 8) )
( (= aus 8) (setq aus 0) (setvar 'autosnap 0) )
( (= aus 16) (setq aus 24) (setvar 'autosnap 24) )
( (= aus 24) (setq aus 16) (setvar 'autosnap 16) )
)
(if (eq p t) (setq p nil) (setq p t))
)
( (and (= (car gr) 2) (= (cadr gr) 23))
(cond
( (= aus 0) (setq aus 16) (setvar 'autosnap 16) )
( (= aus 8) (setq aus 24) (setvar 'autosnap 24) )
( (= aus 16) (setq aus 0) (setvar 'autosnap 0) )
( (= aus 24) (setq aus 8) (setvar 'autosnap 8) )
)
)
)
)
(command "_.line" "_non" pt "_non" gps "")
(*error* nil)
)
@ ribarm: Function _getosmode is missing.
(boole 6 0 16) => 16
(boole 6 8 16) => 24
(boole 6 16 16) => 0
(boole 6 24 16) => 8
(defun c:myline ( / *error* osm omo aus ape doc drft osGrv o p s
osMark _getosmode get_osmode osmode-grvecs-lst _snap _polarangs _polar _ortho
pt loop gr gp oPt gps )
(vl-load-com)
(defun *error* (msg)
(if osm (setvar 'osmode osm))
(if omo (setvar 'orthomode omo))
(if aus (setvar 'autosnap aus))
(if ape (setvar 'aperture ape))
(if msg (prompt msg))
(redraw)
(princ)
)
(setq osm (getvar 'osmode))
(setq omo (getvar 'orthomode))
(setq aus (getvar 'autosnap))
(if (eq omo 1) (setq o t) (setq o nil))
(if (eq (logand aus 8) 8) (setq p t) (setq p nil))
(if (< 0 osm 16384) (setq s t) (setq s nil))
(setq ape (getvar 'aperture))
(setvar 'aperture 10)
(defun _getosmode (os / lst)
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun osMark (o / s)
(setq s (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))
o (cons (trans (car o) 1 3) (cdr o)))
(grvecs (cdr (assoc (cadr o) osGrv))
(list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s 0.)
(list 0. 0. 0. 1.))))
(defun get_osmode nil ; by Evgeniy Elpanov
(mapcar
(function cdr)
(vl-remove-if
(function (lambda (x) (zerop (logand (getvar "OSMODE") (car x)))))
'((0 . "_non")
(1 . "_end")
(2 . "_mid")
(4 . "_cen")
(8 . "_nod")
(16 . "_qua")
(32 . "_int")
(64 . "_ins")
(128 . "_per")
(256 . "_tan")
(512 . "_nea")
(2048 . "_app")))))
(defun osmode-grvecs-lst (col ass / -ass)
; By Evgeniy Elpanov (Modified by Lee Mac)
(setq -ass (- ass))
(list (list "_non"
col (list 0.0 -ass) (list 0.0 ass)
col (list -ass 0.0) (list ass 0.0))
(list "_end"
col (list -ass -ass) (list -ass ass)
col (list (1- -ass) (1- -ass)) (list (1- -ass) (1+ ass))
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list ass ass) (list ass -ass)
col (list (1+ ass) (1+ ass)) (list (1+ ass) (1- -ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
(list "_mid"
col (list -ass -ass) (list 0. ass)
col (list (1- -ass) (1- -ass)) (list 0. (1+ ass))
col (list 0. ass) (list ass -ass)
col (list 0. (1+ ass)) (list (1+ ass) (1- -ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
(list "_cen"
7 (list (* -ass 0.2) 0.) (list (* ass 0.2) 0.)
7 (list 0. (* -ass 0.2)) (list 0. (* ass 0.2))
col (list -ass 0.) (list (* -ass 0.86) (* ass 0.5))
col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
col (list 0. ass) (list (* ass 0.5) (* ass 0.86))
col (list (* ass 0.5) (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
col (list (* ass 0.86) (* ass 0.5)) (list ass 0.)
col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
col (list (* -ass 0.5) (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
col (list (* -ass 0.86) (* -ass 0.5)) (list -ass 0.))
(list "_nod"
col (list -ass -ass) (list ass ass)
col (list -ass ass) (list ass -ass)
col (list -ass 0.) (list (* -ass 0.86) (* ass 0.5))
col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
col (list 0. ass) (list (* ass 0.5) (* ass 0.86))
col (list (* ass 0.5) (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
col (list (* ass 0.86) (* ass 0.5)) (list ass 0.)
col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
col (list (* -ass 0.5) (* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
col (list (* -ass 0.86) (* -ass 0.5)) (list -ass 0.))
(list "_qua"
col (list 0. -ass) (list -ass 0.)
col (list 0. (1- -ass)) (list (1- -ass) 0.)
col (list -ass 0.) (list 0. ass)
col (list (1- -ass) 0.) (list 0. (1+ ass))
col (list 0. ass) (list ass 0.)
col (list 0. (1+ ass)) (list (1+ ass) 0.)
col (list ass 0.) (list 0. -ass)
col (list (1+ ass) 0.) (list 0. (1- -ass)))
(list "_int"
col (list -ass -ass) (list ass ass)
col (list -ass (1+ -ass)) (list ass (1+ ass))
col (list (1+ -ass) -ass) (list (1+ ass) ass)
col (list -ass ass) (list ass -ass)
col (list -ass (1+ ass)) (list ass (1+ -ass))
col (list (1+ -ass) ass) (list (1+ ass) -ass))
(list "_ins"
col (list (* -ass 0.1) (* -ass 0.1)) (list -ass (* -ass 0.1))
col (list -ass (* -ass 0.1)) (list -ass ass)
col (list -ass ass) (list (* ass 0.1) ass)
col (list (* ass 0.1) ass) (list (* ass 0.1) (* ass 0.1))
col (list (* ass 0.1) (* ass 0.1)) (list ass (* ass 0.1))
col (list ass (* ass 0.1)) (list ass -ass)
col (list ass -ass) (list (* -ass 0.1) -ass)
col (list (* -ass 0.1) -ass) (list (* -ass 0.1) (* -ass 0.1))
col (list (1- (* -ass 0.1)) (1- (* -ass 0.1))) (list (1- -ass) (1- (* -ass 0.1)))
col (list (1- -ass) (1- (* -ass 0.1))) (list (1- -ass) (1+ ass))
col (list (1- -ass) (1+ ass)) (list (1+ (* ass 0.1)) (1+ ass))
col (list (1+ (* ass 0.1)) (1+ ass)) (list (1+ (* ass 0.1)) (1+ (* ass 0.1)))
col (list (1+ (* ass 0.1)) (1+ (* ass 0.1))) (list (1+ ass) (1+ (* ass 0.1)))
col (list (1+ ass) (1+ (* ass 0.1))) (list (1+ ass) (1- -ass))
col (list (1+ ass) (1- -ass)) (list (1- (* -ass 0.1)) (1- -ass))
col (list (1- (* -ass 0.1)) (1- -ass)) (list (1- (* -ass 0.1)) (1- (* -ass 0.1))))
(list "_tan"
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list -ass 0.) (list (* -ass 0.86) (* ass 0.5))
col (list (* -ass 0.86) (* ass 0.5)) (list (* -ass 0.5) (* ass 0.86))
col (list (* -ass 0.5) (* ass 0.86)) (list 0. ass)
col (list 0. ass) (list (* ass 0.5) (* ass 0.86))
col (list (* ass 0.5) (* ass 0.86)) (list (* ass 0.86) (* ass 0.5))
col (list (* ass 0.86) (* ass 0.5)) (list ass 0.)
col (list ass 0.) (list (* ass 0.86) (* -ass 0.5))
col (list (* ass 0.86) (* -ass 0.5)) (list (* ass 0.5) (* -ass 0.86))
col (list (* ass 0.5) (* -ass 0.86)) (list 0. -ass)
col (list 0. -ass)(list (* -ass 0.5) (* -ass 0.86))
col (list (* -ass 0.5)(* -ass 0.86)) (list (* -ass 0.86) (* -ass 0.5))
col (list (* -ass 0.86)(* -ass 0.5)) (list -ass 0.))
(list "_per"
col (list -ass -ass) (list -ass ass)
col (list (1- -ass) (1- -ass)) (list (1- -ass) (1+ ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass))
col (list -ass 0.) (list 0. 0.)
col (list -ass -1.) (list 0. -1.)
col (list 0. 0.) (list 0. -ass)
col (list -1. 0.) (list -1. -ass))
(list "_nea"
col (list -ass -ass) (list ass ass)
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list -ass ass) (list ass -ass)
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))
(list "_app"
col (list -ass -ass) (list ass ass)
col (list ass -ass) (list -ass ass)
col (list -ass -ass) (list -ass ass)
col (list (1- -ass) (1- -ass)) (list (1- -ass) (1+ ass))
col (list -ass ass) (list ass ass)
col (list (1- -ass) (1+ ass)) (list (1+ ass) (1+ ass))
col (list ass ass) (list ass -ass)
col (list (1+ ass) (1+ ass)) (list (1+ ass) (1- -ass))
col (list ass -ass) (list -ass -ass)
col (list (1+ ass) (1- -ass)) (list (1- -ass) (1- -ass)))))
(defun _snap (p os)
(if (osnap p (_getosmode os))
(osnap p (_getosmode os))
(progn
(setq loop nil)
(getpoint p (_getosmode os))
)
)
)
(defun _polarangs (ang / n k a l)
(if (/= ang 0.0)
(progn
(setq n (/ 360.1 (cvunit ang "radians" "degrees")))
(setq k -1.0)
(repeat (1+ (fix n))
(setq a (* (setq k (1+ k)) ang))
(setq l (cons a l))
)
l
)
(list 0.0)
)
)
(defun _polar (p0 p flag ang / a b an)
(if flag
(progn
(setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
(if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
(inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
)
p
)
)
(defun _ortho (p0 p flag)
(if flag
(_polar p0 p t (* 0.5 pi))
p
)
)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object))
drft (vla-get-drafting
(vla-get-preferences
(vlax-get-acad-object)))
osGrv (osmode-grvecs-lst
(vla-get-AutoSnapMarkerColor drft)
(vla-get-AutoSnapMarkerSize drft)))
;;;--------- main function ---------;;;
(setq pt (getpoint "\nPick or specify point : "))
(setq loop t)
(while (and loop (/= 3 (car (setq gr (grread 't 15 0)))))
(redraw)
(cond
( (and (= (car gr) 5) (listp (setq gp (cadr gr))))
(if (and (< 0 (getvar "OSMODE") 16384)
(setq oPt (vl-remove-if (function null)
(mapcar
(function
(lambda (x / o)
(if (setq o (osnap gp x))
(list (distance gp o) o x gp)))) (get_osmode)))))
(setq oPt (cdar (vl-sort oPt (function (lambda (a b) (< (car a) (car b)))))))
(setq oPt (list (osnap gp "_non") "_non" gp)))
(and oPt (OsMark oPt))
(cond
( (and o p s)
(setq gps (_snap pt (getvar 'osmode)))
)
( (and o (not p) s)
(setq gps (_snap pt (getvar 'osmode)))
)
( (and (not o) p s)
(setq gps (_snap pt (getvar 'osmode)))
)
( (and (not o) (not p) s)
(setq gps (_snap pt (getvar 'osmode)))
)
( (and o p (not s))
(setq gps (_ortho pt gp t))
)
( (and o (not p) (not s))
(setq gps (_ortho pt gp t))
)
( (and (not o) p (not s))
(setq gps (_polar pt gp t (getvar 'polarang)))
)
( (and (not o) (not p) (not s))
(setq gps gp)
)
)
(grdraw pt gps 3 1)
)
( (and (= (car gr) 2) (= (cadr gr) 6))
(cond
( (< 0 osm 16384) (setq osm (+ osm 16384)) (setvar 'osmode osm) )
( (>= osm 16384) (setq osm (- osm 16384)) (setvar 'osmode osm) )
)
(if (eq s t) (setq s nil) (setq s t))
)
( (and (= (car gr) 2) (= (cadr gr) 15))
(cond
( (= omo 0) (setq omo 1) (setvar 'orthomode 1) )
( (= omo 1) (setq omo 0) (setvar 'orthomode 0) )
)
(if (eq o t) (setq o nil) (setq o t))
)
( (and (= (car gr) 2) (= (cadr gr) 21))
(cond
( (= aus 0) (setq aus 8) (setvar 'autosnap 8) )
( (= aus 8) (setq aus 0) (setvar 'autosnap 0) )
( (= aus 16) (setq aus 24) (setvar 'autosnap 24) )
( (= aus 24) (setq aus 16) (setvar 'autosnap 16) )
)
(if (eq p t) (setq p nil) (setq p t))
)
( (and (= (car gr) 2) (= (cadr gr) 23))
(cond
( (= aus 0) (setq aus 16) (setvar 'autosnap 16) )
( (= aus 8) (setq aus 24) (setvar 'autosnap 24) )
( (= aus 16) (setq aus 0) (setvar 'autosnap 0) )
( (= aus 24) (setq aus 8) (setvar 'autosnap 8) )
)
)
)
)
(command "_.line" "_non" pt "_non" gps "")
(*error* nil)
)
(defun c:myline ( / osm _getosmode _snap pt )
(setq osm (getvar 'osmode))
(defun _getosmode (os / lst)
(foreach mode
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(1024 . "_qui")
(2048 . "_app")
(4096 . "_ext")
(8192 . "_par")
)
(if (not (zerop (logand (car mode) os)))
(setq lst (cons "," (cons (cdr mode) lst)))
)
)
(apply 'strcat (cdr lst))
)
(defun _snap (p os)
(getpoint p (_getosmode os))
)
(setq pt (getpoint "\nPick or specify point : "))
(command "_.line" "_non" pt "_non" (_snap pt osm) "")
(princ)
)
No joke, I've changed my versions to accept new markers, and when you actually try to implement (getpoint) trick along with (grread) then you realize you have to do it like Evgeniy and Lee did...
Only now I couldn't do it with reltro's code... Maybe someone can, who knows...
M.R.
(defun _snap (p os)
(getpoint p (_getosmode os))
)Note that the 'osmode string' is the prompt message.
Hi reltro... See attachment... This file : Rect,Ratio-bad.lsp
But no really big deal... I am satisfied and with how it's working now as it is...
Regards...
Hi reltro... See attachment... This file : Rect,Ratio-bad.lsp
But no really big deal... I am satisfied and with how it's working now as it is...
Regards...
Hey Marko,
sry, but I do not get the code into my mind... can't rember wich parts of the code I wrote...
Greets reltro
Just tested on A2014 and my "o" - osnap option doesn't work correctly, but on A2012 an lower versions it's just fine... Never mind, in A2014 - firstly set osnap combination and switch osnap with F3, or use single osnap with "e" - endpoint (for ex.) and so on...
(while (not *StopLoop*)
(setq Input (grread T 4 4)
Code (car Input)
Data (cadr Input)
)
(redraw)
(cond
((= Code 5)
(setq Pt1 (trans InsPt 1 0)
Pt2 (trans Data 1 0)
FxPt (PolarSnap Pt1 Pt2 nil nil)
;Alternative: FxPt (PolarSnap Pt1 Pt2 Match_Angle Last_Angle)
)
(grdraw Pt1 FxPt 3 1)
)
)
)