Initial commit
This commit is contained in:
106
downloaded/ArcToLine.lsp
Normal file
106
downloaded/ArcToLine.lsp
Normal file
@@ -0,0 +1,106 @@
|
||||
(defun c:ArcToLine (/ *error* blg blk ent objts cnt blgLoc pts stp mxp cur
|
||||
ent2d)
|
||||
(vl-load-com)
|
||||
(defun *error* (msg)
|
||||
(and uFlag (vla-EndUndoMark doc))
|
||||
(and ov (mapcar (function setvar) vl ov))
|
||||
(and msg
|
||||
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
|
||||
(princ (strcat "\n** Error: " msg " **"))
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
(defun blg (ent num / blg)
|
||||
(repeat num
|
||||
(setq blg (cons (list
|
||||
(vla-getbulge ent (setq num (1- num)))
|
||||
(trans (vlax-safearray->list
|
||||
(variant-value
|
||||
(vla-Get-coordinate ent num)
|
||||
)
|
||||
)
|
||||
0
|
||||
1
|
||||
)
|
||||
)
|
||||
blg
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
)
|
||||
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
|
||||
vl '("CMDECHO" "OSMODE" "ORTHOMODE")
|
||||
ov (mapcar (function getvar) vl)
|
||||
)
|
||||
(prompt "\nSelect LWPOLYLINE To convert:")
|
||||
(if
|
||||
(and
|
||||
(setq uFlag (not (vla-StartUndoMark doc)))
|
||||
(mapcar (function setvar) vl '(0 0 0))
|
||||
(setq pts nil ent (car (entsel "\nSelect Polyline Boundary:\n")))
|
||||
(eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
|
||||
(setq alen (getdist "\nEnter line ncrement length: "))
|
||||
)
|
||||
(progn
|
||||
(setq objts (vlax-ename->vla-object ent))
|
||||
(setq cnt 0
|
||||
blgLoc (blg objts (cdr (assoc 90 (entget ent))))
|
||||
)
|
||||
(foreach itm blgLoc
|
||||
(setq cnt (1+ cnt))
|
||||
(if (= (car itm) 0.0)
|
||||
(setq pts (cons (trans (cadr itm) 1 0) pts))
|
||||
(progn
|
||||
(setq pts (cons (trans (cadr itm) 1 0) pts))
|
||||
(setq stp (if (zerop
|
||||
(setq cur (vlax-curve-getDistAtPoint
|
||||
objts
|
||||
(trans (cadr itm) 1 0)
|
||||
)
|
||||
)
|
||||
)
|
||||
(vla-get-length objts)
|
||||
cur
|
||||
)
|
||||
nxp (if (>= (1+ cnt) (cdr (assoc 90 (entget ent))))
|
||||
(vla-get-length objts)
|
||||
(vlax-curve-getDistAtPoint
|
||||
objts
|
||||
(trans (cadr (nth cnt blgLoc)) 1 0)
|
||||
)
|
||||
)
|
||||
)
|
||||
(while (< (setq stp (+ stp alen)) nxp)
|
||||
(setq
|
||||
pts (cons (vlax-curve-getPointAtDist objts stp) pts)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
clr
|
||||
(if pts
|
||||
(progn
|
||||
(setq
|
||||
ent2d (entmakex
|
||||
(append
|
||||
(list (cons 0 "LWPOLYLINE")
|
||||
(cons 100 "AcDbEntity")
|
||||
(cons 100 "AcDbPolyline")
|
||||
(cons 90 (length pts))
|
||||
(cons 70 0)
|
||||
)
|
||||
(mapcar (function (lambda (p) (cons 10 p))) pts)
|
||||
)
|
||||
)
|
||||
)(entdel ent)
|
||||
)
|
||||
)
|
||||
(setq uFlag (vla-EndUndoMark doc))
|
||||
)
|
||||
)
|
||||
(*error* nil)
|
||||
(princ)
|
||||
)
|
||||
90
downloaded/Blockreplace.lsp
Normal file
90
downloaded/Blockreplace.lsp
Normal file
@@ -0,0 +1,90 @@
|
||||
(defun c:BRE (/ *error* blk f ss temp)
|
||||
;; Replace multiple instances of selected blocks (can be different) with selected block
|
||||
;; Size and Rotation will be taken from original block and original will be deleted
|
||||
;; Required subroutines: AT:GetSel
|
||||
;; Alan J. Thompson, 02.09.10
|
||||
|
||||
(vl-load-com)
|
||||
|
||||
(defun *error* (msg)
|
||||
(and f *AcadDoc* (vla-endundomark *AcadDoc*))
|
||||
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
|
||||
(princ (strcat "\nError: " msg))
|
||||
)
|
||||
)
|
||||
|
||||
(if
|
||||
(and
|
||||
(AT:GetSel
|
||||
entsel
|
||||
"\nSelect replacement block: "
|
||||
(lambda (x / e)
|
||||
(if
|
||||
(and
|
||||
(eq "INSERT" (cdr (assoc 0 (setq e (entget (car x))))))
|
||||
(/= 4 (logand (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 e))))) 4))
|
||||
(/= 4 (logand (cdr (assoc 70 (entget (tblobjname "LAYER" (cdr (assoc 8 e)))))) 4))
|
||||
)
|
||||
(setq blk (vlax-ename->vla-object (car x)))
|
||||
)
|
||||
)
|
||||
)
|
||||
(princ "\nSelect blocks to be repalced: ")
|
||||
(setq ss (ssget "_:L" '((0 . "INSERT"))))
|
||||
)
|
||||
(progn
|
||||
(setq f (not (vla-startundomark
|
||||
(cond (*AcadDoc*)
|
||||
((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*))
|
||||
(setq temp (vla-copy blk))
|
||||
(mapcar (function (lambda (p)
|
||||
(vl-catch-all-apply
|
||||
(function vlax-put-property)
|
||||
(list temp p (vlax-get-property x p))
|
||||
)
|
||||
)
|
||||
)
|
||||
'(Insertionpoint Rotation XEffectiveScaleFactor YEffectiveScaleFactor
|
||||
ZEffectiveScaleFactor
|
||||
)
|
||||
)
|
||||
(vla-delete x)
|
||||
)
|
||||
(vla-delete ss)
|
||||
(*error* nil)
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(defun AT:GetSel (meth msg fnc / ent good)
|
||||
;; meth - selection method (entsel, nentsel, nentselp)
|
||||
;; msg - message to display (nil for default)
|
||||
;; fnc - optional function to apply to selected object
|
||||
;; Ex: (AT:GetSel entsel "\nSelect arc: " (lambda (x) (eq (cdr (assoc 0 (entget (car x)))) "ARC")))
|
||||
;; Alan J. Thompson, 05.25.10
|
||||
(setvar 'errno 0)
|
||||
(while (not good)
|
||||
(setq ent (meth (cond (msg)
|
||||
("\nSelect object: ")
|
||||
)
|
||||
)
|
||||
)
|
||||
(cond
|
||||
((vl-consp ent)
|
||||
(setq good (cond ((or (not fnc) (fnc ent)) ent)
|
||||
((prompt "\nInvalid object!"))
|
||||
)
|
||||
)
|
||||
)
|
||||
((eq (type ent) 'STR) (setq good ent))
|
||||
((setq good (eq 52 (getvar 'errno))) nil)
|
||||
((eq 7 (getvar 'errno)) (setq good (prompt "\nMissed, try again.")))
|
||||
)
|
||||
)
|
||||
)
|
||||
295
downloaded/ChangeBlockBasePointV1-5.lsp
Normal file
295
downloaded/ChangeBlockBasePointV1-5.lsp
Normal file
@@ -0,0 +1,295 @@
|
||||
;;--------------------=={ Change Block Base Point }==-------------------;;
|
||||
;; ;;
|
||||
;; This program allows the user to change the base point for all ;;
|
||||
;; block references of a block definition in a drawing. ;;
|
||||
;; ;;
|
||||
;; The program offers two commands: ;;
|
||||
;; ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; CBP (Change Base Point) ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; ;;
|
||||
;; This command will retain the insertion point coordinates for all ;;
|
||||
;; references of the selected block. Hence visually, the block ;;
|
||||
;; components will be moved around the insertion point when the ;;
|
||||
;; base point is changed. ;;
|
||||
;; ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; CBPR (Change Base Point Retain Reference Position) ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; ;;
|
||||
;; This command will retain the position of the each block reference ;;
|
||||
;; of the selected block. Hence, each block reference will be moved ;;
|
||||
;; to retain the visual position when the base point is changed. ;;
|
||||
;; ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; ;;
|
||||
;; Upon issuing a command syntax at the AutoCAD command-line, the ;;
|
||||
;; program will prompt the user to select a block for which to change ;;
|
||||
;; the base point. ;;
|
||||
;; ;;
|
||||
;; Following a valid selection, the user is then prompted to specify ;;
|
||||
;; a new base point relative to the selected block. ;;
|
||||
;; ;;
|
||||
;; The block definition (and block reference depending on the command ;;
|
||||
;; used) will then be modified to reflect the new block base point. ;;
|
||||
;; ;;
|
||||
;; If the selected block is attributed, an ATTSYNC operation will ;;
|
||||
;; also be performed to ensure all attributes are in the correct ;;
|
||||
;; positions relative to the new base point. ;;
|
||||
;; ;;
|
||||
;; Finally, the active viewport is regenerated to reflect the changes ;;
|
||||
;; throughout all references of the block. ;;
|
||||
;; ;;
|
||||
;; The program will furthermore perform successfully with rotated & ;;
|
||||
;; scaled block references, constructed in any UCS plane. ;;
|
||||
;; ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; Please Note: ;;
|
||||
;; ------------------------------------------------------------------ ;;
|
||||
;; ;;
|
||||
;; A REGEN is required if the UNDO command is used to undo the ;;
|
||||
;; operations performed by this program. ;;
|
||||
;; ;;
|
||||
;;----------------------------------------------------------------------;;
|
||||
;; Author: Lee Mac, Copyright <20> 2013 - www.lee-mac.com ;;
|
||||
;;----------------------------------------------------------------------;;
|
||||
;; Version 1.5 - 20-10-2013 ;;
|
||||
;;----------------------------------------------------------------------;;
|
||||
|
||||
;; Retains Insertion Point Coordinates
|
||||
(defun c:cbp nil (LM:changeblockbasepoint nil))
|
||||
|
||||
;; Retains Block Reference Position
|
||||
(defun c:cbpr nil (LM:changeblockbasepoint t))
|
||||
|
||||
;;----------------------------------------------------------------------;;
|
||||
|
||||
(defun LM:changeblockbasepoint ( flg / *error* bln cmd ent lck mat nbp vec )
|
||||
|
||||
(defun *error* ( msg )
|
||||
(foreach lay lck (vla-put-lock lay :vlax-true))
|
||||
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
|
||||
(LM:endundo (LM:acdoc))
|
||||
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
|
||||
(princ (strcat "\nError: " msg))
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(while
|
||||
(progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect Block: ")))
|
||||
(cond
|
||||
( (= 7 (getvar 'errno))
|
||||
(princ "\nMissed, try again.")
|
||||
)
|
||||
( (= 'ename (type ent))
|
||||
(if (/= "INSERT" (cdr (assoc 0 (entget ent))))
|
||||
(princ "\nSelected object is not a block.")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (and (= 'ename (type ent)) (setq nbp (getpoint "\nSpecify New Base Point: ")))
|
||||
(progn
|
||||
(setq mat (car (revrefgeom ent))
|
||||
vec (mxv mat (mapcar '- (trans nbp 1 0) (trans (cdr (assoc 10 (entget ent))) ent 0)))
|
||||
bln (LM:blockname (vlax-ename->vla-object ent))
|
||||
)
|
||||
(LM:startundo (LM:acdoc))
|
||||
(vlax-for lay (vla-get-layers (LM:acdoc))
|
||||
(if (= :vlax-true (vla-get-lock lay))
|
||||
(progn
|
||||
(vla-put-lock lay :vlax-false)
|
||||
(setq lck (cons lay lck))
|
||||
)
|
||||
)
|
||||
)
|
||||
(vlax-for obj (vla-item (vla-get-blocks (LM:acdoc)) bln)
|
||||
(vlax-invoke obj 'move vec '(0.0 0.0 0.0))
|
||||
)
|
||||
(if flg
|
||||
(vlax-for blk (vla-get-blocks (LM:acdoc))
|
||||
(if (= :vlax-false (vla-get-isxref blk))
|
||||
(vlax-for obj blk
|
||||
(if
|
||||
(and
|
||||
(= "AcDbBlockReference" (vla-get-objectname obj))
|
||||
(= bln (LM:blockname obj))
|
||||
(vlax-write-enabled-p obj)
|
||||
)
|
||||
(vlax-invoke obj 'move '(0.0 0.0 0.0) (mxv (car (refgeom (vlax-vla-object->ename obj))) vec))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (= 1 (cdr (assoc 66 (entget ent))))
|
||||
(progn
|
||||
(setq cmd (getvar 'cmdecho))
|
||||
(setvar 'cmdecho 0)
|
||||
(vl-cmdf "_.attsync" "_N" bln)
|
||||
(setvar 'cmdecho cmd)
|
||||
)
|
||||
)
|
||||
(foreach lay lck (vla-put-lock lay :vlax-true))
|
||||
(vla-regen (LM:acdoc) acallviewports)
|
||||
(LM:endundo (LM:acdoc))
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
;; RefGeom (gile)
|
||||
;; Returns a list whose first item is a 3x3 transformation matrix and
|
||||
;; second item the object insertion point in its parent (xref, block or space)
|
||||
|
||||
(defun refgeom ( ent / ang enx mat ocs )
|
||||
(setq enx (entget ent)
|
||||
ang (cdr (assoc 050 enx))
|
||||
ocs (cdr (assoc 210 enx))
|
||||
)
|
||||
(list
|
||||
(setq mat
|
||||
(mxm
|
||||
(mapcar '(lambda ( v ) (trans v 0 ocs t))
|
||||
'(
|
||||
(1.0 0.0 0.0)
|
||||
(0.0 1.0 0.0)
|
||||
(0.0 0.0 1.0)
|
||||
)
|
||||
)
|
||||
(mxm
|
||||
(list
|
||||
(list (cos ang) (- (sin ang)) 0.0)
|
||||
(list (sin ang) (cos ang) 0.0)
|
||||
'(0.0 0.0 1.0)
|
||||
)
|
||||
(list
|
||||
(list (cdr (assoc 41 enx)) 0.0 0.0)
|
||||
(list 0.0 (cdr (assoc 42 enx)) 0.0)
|
||||
(list 0.0 0.0 (cdr (assoc 43 enx)))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
|
||||
(mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; RevRefGeom (gile)
|
||||
;; The inverse of RefGeom
|
||||
|
||||
(defun revrefgeom ( ent / ang enx mat ocs )
|
||||
(setq enx (entget ent)
|
||||
ang (cdr (assoc 050 enx))
|
||||
ocs (cdr (assoc 210 enx))
|
||||
)
|
||||
(list
|
||||
(setq mat
|
||||
(mxm
|
||||
(list
|
||||
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
|
||||
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
|
||||
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
|
||||
)
|
||||
(mxm
|
||||
(list
|
||||
(list (cos ang) (sin ang) 0.0)
|
||||
(list (- (sin ang)) (cos ang) 0.0)
|
||||
'(0.0 0.0 1.0)
|
||||
)
|
||||
(mapcar '(lambda ( v ) (trans v ocs 0 t))
|
||||
'(
|
||||
(1.0 0.0 0.0)
|
||||
(0.0 1.0 0.0)
|
||||
(0.0 0.0 1.0)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
|
||||
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
;; 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)
|
||||
)
|
||||
|
||||
;; 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 Transpose - Doug Wilson
|
||||
;; Args: m - nxn matrix
|
||||
|
||||
(defun trp ( m )
|
||||
(apply 'mapcar (cons 'list m))
|
||||
)
|
||||
|
||||
;; Block Name - Lee Mac
|
||||
;; Returns the true (effective) name of a supplied block reference
|
||||
|
||||
(defun LM:blockname ( obj )
|
||||
(if (vlax-property-available-p obj 'effectivename)
|
||||
(defun LM:blockname ( obj ) (vla-get-effectivename obj))
|
||||
(defun LM:blockname ( obj ) (vla-get-name obj))
|
||||
)
|
||||
(LM:blockname obj)
|
||||
)
|
||||
|
||||
;; Start Undo - Lee Mac
|
||||
;; Opens an Undo Group.
|
||||
|
||||
(defun LM:startundo ( doc )
|
||||
(LM:endundo doc)
|
||||
(vla-startundomark doc)
|
||||
)
|
||||
|
||||
;; End Undo - Lee Mac
|
||||
;; Closes an Undo Group.
|
||||
|
||||
(defun LM:endundo ( doc )
|
||||
(while (= 8 (logand 8 (getvar 'undoctl)))
|
||||
(vla-endundomark doc)
|
||||
)
|
||||
)
|
||||
|
||||
;; Active Document - Lee Mac
|
||||
;; Returns the VLA Active Document Object
|
||||
|
||||
(defun LM:acdoc nil
|
||||
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
|
||||
(LM:acdoc)
|
||||
)
|
||||
|
||||
;;----------------------------------------------------------------------;;
|
||||
|
||||
(vl-load-com)
|
||||
(princ
|
||||
(strcat
|
||||
"\n:: ChangeBlockBasePoint.lsp | Version 1.5 | \\U+00A9 Lee Mac "
|
||||
(menucmd "m=$(edtime,0,yyyy)")
|
||||
" www.lee-mac.com ::"
|
||||
"\n:: Available Commands:"
|
||||
"\n:: \"CBP\" - Retain Insertion Point Position"
|
||||
"\n:: \"CBPR\" - Retain Block Reference Position"
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
|
||||
;;----------------------------------------------------------------------;;
|
||||
;; End of File ;;
|
||||
;;----------------------------------------------------------------------;;
|
||||
70
downloaded/Ellipse2pline.lsp
Normal file
70
downloaded/Ellipse2pline.lsp
Normal file
@@ -0,0 +1,70 @@
|
||||
; Ellipse or ellipse arc to polyline
|
||||
; Written By: Peter Jamtgaard 8/1/2006
|
||||
; Modified by Tom Beauford to convert Lines, Arcs, Splines, and Circles as well.
|
||||
; Menu item: ^P(or C:El2p (load "El2p.lsp"));El2p
|
||||
(defun C:El2p (/ El2p ss count)
|
||||
(defun El2p (ent / sngIncrement sngPosition pedacept)
|
||||
(setq obj (vlax-ename->vla-object ent)
|
||||
EnTyp (cdr (assoc 0 (entget ent)))
|
||||
)
|
||||
(princ "\nEntity Type = ")(princ EnTyp)
|
||||
(cond
|
||||
((= EnTyp "ELLIPSE")
|
||||
(setq obj (vlax-ename->vla-object ent)
|
||||
sngIncrement (/ (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) 100.0)
|
||||
sngPosition 0.0
|
||||
)
|
||||
(command "ortho" "off" "pline")
|
||||
(repeat 101
|
||||
(command (vlax-curve-getpointatdist obj sngPosition))
|
||||
(setq sngPosition (+ sngPosition sngIncrement))
|
||||
)
|
||||
(command "")
|
||||
); EnTyp = ELLIPSE
|
||||
((= EnTyp "CIRCLE")
|
||||
(setq obj (vlax-ename->vla-object ent)
|
||||
ps (vlax-variant-value (vlax-get-property obj 'Center)); Center
|
||||
center (vlax-safearray->list ps) ; Center
|
||||
radius (vlax-get-property obj 'Radius) ; Radius
|
||||
pt1 (polar center 0 radius) ; start point for polyline
|
||||
pt2 (polar center 3.14159 radius) ; second point for pline arc
|
||||
ELA (vlax-get-property obj 'Layer) ; layer
|
||||
ELT (vlax-get-property obj 'Linetype) ; Linetype
|
||||
ELS (vlax-get-property obj 'LinetypeScale) ; LinetypeScale
|
||||
PltSty (vlax-get-property obj 'PlotStyleName) ; PlotStyleName
|
||||
TruClr (vlax-get-property obj 'TrueColor) ; TrueColor
|
||||
)
|
||||
(command "pline" pt1 "Arc" "CE" center pt2 "Close")
|
||||
(setq ent (entlast)
|
||||
obj (vlax-ename->vla-object ent)
|
||||
)
|
||||
(vlax-dump-object EOBJ) ; List object properties
|
||||
(vl-catch-all-apply 'vla-put-Layer (list EOBJ ELA))
|
||||
(vl-catch-all-apply 'vla-put-Linetype (list EOBJ ELT))
|
||||
(vl-catch-all-apply 'vla-put-LinetypeScale (list EOBJ ELS))
|
||||
(vl-catch-all-apply 'vla-put-PlotStyleName (list EOBJ PltSty))
|
||||
(vl-catch-all-apply 'vla-put-TrueColor (list EOBJ TruClr))
|
||||
); EnTyp = CIRCLE
|
||||
|
||||
((or(= EnTyp "ARC")(= EnTyp "LINE"))
|
||||
(setq pedacept (Getvar "peditaccept"))
|
||||
(setvar "peditaccept" 1)
|
||||
(command "_.pedit" ent "_exit")
|
||||
(setvar "peditaccept" pedacept)
|
||||
); EnTyp = ARC or LINE
|
||||
(T(princ "\nEntity Type = ")(princ EnTyp))
|
||||
); if (= (type ent) 'ENAME)
|
||||
; (vla-delete objEllipse)
|
||||
(princ)
|
||||
)
|
||||
(princ "\nSelect Lines, Arcs, Splines, Circles, Ellipses, and Ellipse Arcs: ")
|
||||
(setq count 0)
|
||||
(if (setq ss (ssget '((0 . "line,arc,spline,circle,ellipse"))))
|
||||
(repeat (sslength ss)
|
||||
(el2p (ssname ss count))
|
||||
(setq count (1+ count))
|
||||
)
|
||||
(princ "\nNo modifyable objects selected!")
|
||||
)
|
||||
(princ)
|
||||
); defun C:El2p
|
||||
364
downloaded/HatchMaker.lsp
Normal file
364
downloaded/HatchMaker.lsp
Normal file
@@ -0,0 +1,364 @@
|
||||
;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele
|
||||
|
||||
;;;* ====== B E G I N C O D E N O W ======
|
||||
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
|
||||
;;;* Lanny.Schiele@tmisystems.com
|
||||
;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.
|
||||
|
||||
(defun C:DrawHatch (/)
|
||||
(command "undo" "be")
|
||||
(setq os (getvar "OSMODE"))
|
||||
(setvar "OSMODE" 0)
|
||||
(command "UCS" "w")
|
||||
(command "PLINE" "0,0" "0,1" "1,1" "1,0" "c")
|
||||
(command "zoom" "c" "0.5,0.5" 1.1)
|
||||
(setvar "OSMODE" os)
|
||||
(setvar "SNAPMODE" 1)
|
||||
(setvar "SNAPUNIT" (list 0.01 0.01))
|
||||
(command "undo" "e")
|
||||
(alert
|
||||
"Draw pattern within 1x1 box using LINE or POINT entities only..."
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(defun C:SaveHatch (/ round dxf ListToFile
|
||||
user SelSet SelSetSize ssNth
|
||||
Ent EntInfo EntType pt1 pt2
|
||||
Dist AngTo AngFrom XDir YDir
|
||||
Gap DeltaX DeltaY AngZone Counter
|
||||
Ratio Factor HatchName HatchDescr
|
||||
FileLines FileLines FileName
|
||||
Scaler ScaledX ScaledY RF x
|
||||
y h _AB _BC _AC
|
||||
_AD _DE _EF _EH _FH
|
||||
DimZin
|
||||
)
|
||||
;;;* BEGIN NESTED FUNCTIONS
|
||||
|
||||
(defun round (num)
|
||||
(if (>= (- num (fix num)) 0.5)
|
||||
(fix (1+ num))
|
||||
(fix num)
|
||||
)
|
||||
)
|
||||
|
||||
(defun dxf (code EnameOrElist / VarType)
|
||||
(setq VarType (type EnameOrElist))
|
||||
(if (= VarType (read "ENAME"))
|
||||
(cdr (assoc code (entget EnameOrElist)))
|
||||
(cdr (assoc code EnameOrElist))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(defun ListToFile (TextList FileName DoOpenWithNotepad
|
||||
AsAppend / TextItem
|
||||
File RetVal
|
||||
)
|
||||
(if (setq File (open FileName
|
||||
(if AsAppend
|
||||
"a"
|
||||
"w"
|
||||
)
|
||||
)
|
||||
)
|
||||
(progn
|
||||
(foreach TextItem TextList
|
||||
(write-line TextItem File)
|
||||
)
|
||||
(setq File (close File))
|
||||
(if DoOpenWithNotepad
|
||||
(startapp "notepad" FileName)
|
||||
)
|
||||
)
|
||||
)
|
||||
(FindFile FileName)
|
||||
)
|
||||
|
||||
;;;* END NESTED FUNCTIONS
|
||||
|
||||
(princ
|
||||
(strcat
|
||||
"\n."
|
||||
"\n 0,1 ----------- 1,1"
|
||||
"\n | | "
|
||||
"\n | Lines and | "
|
||||
"\n | points must | "
|
||||
"\n | be snapped | "
|
||||
"\n | to nearest | "
|
||||
"\n | 0.01 | "
|
||||
"\n | | "
|
||||
"\n 0,0 ----------- 1,0"
|
||||
"\n."
|
||||
"\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid."
|
||||
)
|
||||
)
|
||||
(textscr)
|
||||
(getstring "\nHit [ENTER] to continue...")
|
||||
|
||||
(princ
|
||||
"\nSelect 1x1 pattern of lines and/or points for new hatch pattern..."
|
||||
)
|
||||
(while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))
|
||||
)
|
||||
(setq ssNth 0
|
||||
SelSetSize (sslength SelSet)
|
||||
DimZin (getvar "DIMZIN")
|
||||
)
|
||||
(setvar "DIMZIN" 11)
|
||||
(if (> SelSetSize 0)
|
||||
(princ "\nAnalyaing entities...")
|
||||
)
|
||||
(while (< ssNth SelSetSize)
|
||||
(setq Ent (ssname SelSet ssNth)
|
||||
EntInfo (entget Ent)
|
||||
EntType (dxf 0 EntInfo)
|
||||
ssNth (+ ssNth 1)
|
||||
)
|
||||
(cond
|
||||
((= EntType "POINT")
|
||||
(setq pt1 (dxf 10 EntInfo)
|
||||
FileLine (strcat "0,"
|
||||
(rtos (car pt1) 2 6)
|
||||
","
|
||||
(rtos (cadr pt1) 2 6)
|
||||
",0,1,0,-1"
|
||||
)
|
||||
)
|
||||
(princ (strcat "\n" FileLine))
|
||||
(setq FileLines (cons FileLine FileLines))
|
||||
)
|
||||
((= EntType "LINE")
|
||||
(setq pt1 (dxf 10 EntInfo)
|
||||
pt2 (dxf 11 EntInfo)
|
||||
Dist (distance pt1 pt2)
|
||||
AngTo (angle pt1 pt2)
|
||||
AngFrom (angle pt2 pt1)
|
||||
IsValid nil
|
||||
)
|
||||
(if
|
||||
(or (equal (car pt1) (car pt2) 0.0001)
|
||||
(equal (cadr pt1) (cadr pt2) 0.0001)
|
||||
)
|
||||
(setq DeltaX 0
|
||||
DeltaY 1
|
||||
Gap (- Dist 1)
|
||||
IsValid T
|
||||
)
|
||||
(progn
|
||||
(setq Ang (if (< AngTo pi)
|
||||
AngTo
|
||||
AngFrom
|
||||
)
|
||||
AngZone (fix (/ Ang (/ pi 4)))
|
||||
XDir (abs (- (car pt2) (car pt1)))
|
||||
YDir (abs (- (cadr pt2) (cadr pt1)))
|
||||
Factor 1
|
||||
RF 1
|
||||
)
|
||||
(cond
|
||||
((= AngZone 0)
|
||||
(setq DeltaY (abs (sin Ang))
|
||||
DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))
|
||||
)
|
||||
)
|
||||
)
|
||||
((= AngZone 1)
|
||||
(setq DeltaY (abs (cos Ang))
|
||||
DeltaX (abs (sin Ang))
|
||||
)
|
||||
)
|
||||
((= AngZone 2)
|
||||
(setq DeltaY (abs (cos Ang))
|
||||
DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))
|
||||
)
|
||||
)
|
||||
)
|
||||
((= AngZone 3)
|
||||
(setq DeltaY (abs (sin Ang))
|
||||
DeltaX (abs (cos Ang))
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (not (equal XDir YDir 0.001))
|
||||
(progn
|
||||
(setq Ratio (if (< XDir YDir)
|
||||
(/ YDir XDir)
|
||||
(/ XDir YDir)
|
||||
)
|
||||
RF (* Ratio Factor)
|
||||
Scaler (/ 1
|
||||
(if (< XDir YDir)
|
||||
XDir
|
||||
YDir
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (not (equal Ratio (round Ratio) 0.001))
|
||||
(progn
|
||||
(while
|
||||
(and
|
||||
(<= Factor 100)
|
||||
(not (equal RF (round RF) 0.001))
|
||||
)
|
||||
(setq Factor (+ Factor 1)
|
||||
RF (* Ratio Factor)
|
||||
)
|
||||
)
|
||||
(if (and (> Factor 1) (<= Factor 100))
|
||||
(progn
|
||||
(setq _AB (* XDir Scaler Factor)
|
||||
_BC (* YDir Scaler Factor)
|
||||
_AC (sqrt (+ (* _AB _AB) (* _BC _BC)))
|
||||
_EF 1
|
||||
x 1
|
||||
)
|
||||
(while (< x (- _AB 0.5))
|
||||
(setq y (* x (/ YDir XDir))
|
||||
h (if (< Ang (/ pi 2))
|
||||
(- (+ 1 (fix y)) y)
|
||||
(- y (fix y))
|
||||
)
|
||||
)
|
||||
(if (< h _EF)
|
||||
(setq _AD x
|
||||
_DE y
|
||||
_AE (sqrt (+ (* x x) (* y y)))
|
||||
_EF h
|
||||
)
|
||||
)
|
||||
(setq x (+ x 1))
|
||||
)
|
||||
(if (< _EF 1)
|
||||
(setq _EH (/ (* _BC _EF) _AC)
|
||||
_FH (/ (* _AB _EF) _AC)
|
||||
DeltaX (+ _AE
|
||||
(if (> Ang (/ pi 2))
|
||||
(- _EH)
|
||||
_EH
|
||||
)
|
||||
)
|
||||
DeltaY (+ _FH)
|
||||
Gap (- Dist _AC)
|
||||
IsValid T
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (= Factor 1)
|
||||
(setq Gap (- Dist (abs (* Factor (/ 1 DeltaY))))
|
||||
IsValid T
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(if
|
||||
IsValid
|
||||
(progn
|
||||
(setq FileLine
|
||||
(strcat
|
||||
(angtos AngTo 0 6)
|
||||
","
|
||||
(rtos (car pt1) 2 8)
|
||||
","
|
||||
(rtos (cadr pt1) 2 8)
|
||||
","
|
||||
(rtos DeltaX 2 8)
|
||||
","
|
||||
(rtos DeltaY 2 8)
|
||||
","
|
||||
(rtos Dist 2 8)
|
||||
","
|
||||
(rtos Gap 2 8)
|
||||
)
|
||||
)
|
||||
(princ (strcat "\n" FileLine))
|
||||
(setq FileLines (cons FileLine FileLines))
|
||||
)
|
||||
(princ (strcat "\n * * * Line with invalid angle "
|
||||
(angtos AngTo 0 6)
|
||||
(chr 186)
|
||||
" omitted. * * *"
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
((princ
|
||||
(strcat "\n * * * Invalid entity " EntType " omitted.")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(setvar "DIMZIN" DimZin)
|
||||
(if
|
||||
(and
|
||||
FileLines
|
||||
(setq HatchDescr
|
||||
(getstring T
|
||||
"\nBriefly describe this hatch pattern: "
|
||||
)
|
||||
)
|
||||
(setq FileName (getfiled "Hatch Pattern File"
|
||||
"I:\\Acad\\Hatch\\"
|
||||
"pat"
|
||||
1
|
||||
)
|
||||
)
|
||||
)
|
||||
(progn
|
||||
(if (= HatchDescr "")
|
||||
(setq HatchDescr "Custom hatch pattern")
|
||||
)
|
||||
(setq HatchName (vl-filename-base FileName)
|
||||
FileLines (cons (strcat "*" HatchName "," HatchDescr)
|
||||
(reverse FileLines)
|
||||
)
|
||||
)
|
||||
(princ
|
||||
"\n============================================================"
|
||||
)
|
||||
(princ
|
||||
(strcat "\nPlease wait while the hatch file is created...\n"
|
||||
)
|
||||
)
|
||||
(ListToFile FileLines FileName nil nil)
|
||||
(command "delay" 1500) ;delay required so file can be created and found (silly, but req.)
|
||||
(if (findfile FileName)
|
||||
(progn
|
||||
(setvar "HPNAME" HatchName)
|
||||
(princ (strcat "\nHatch pattern '"
|
||||
HatchName
|
||||
"' is ready to use!"
|
||||
)
|
||||
)
|
||||
)
|
||||
(progn
|
||||
(princ "\nUnable to create hatch pattern file:")
|
||||
(princ (strcat "\n " FileName))
|
||||
)
|
||||
)
|
||||
)
|
||||
(princ
|
||||
(if FileLines
|
||||
"\nCancelled."
|
||||
"\nUnable to create hatch pattern from selected entities."
|
||||
)
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(princ "\n ************************************************************** ")
|
||||
(princ "\n** **")
|
||||
(princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *")
|
||||
(princ "\n* *")
|
||||
(princ "\n* Type in DRAWHATCH to have the environment created to draw. *")
|
||||
(princ "\n* Type in SAVEHATCH to save the pattern you created. *")
|
||||
(princ "\n** **")
|
||||
(princ "\n ************************************************************** ")
|
||||
(princ)
|
||||
364
downloaded/HatchMaker2.lsp
Normal file
364
downloaded/HatchMaker2.lsp
Normal file
@@ -0,0 +1,364 @@
|
||||
;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele
|
||||
|
||||
;;;* ====== B E G I N C O D E N O W ======
|
||||
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
|
||||
;;;* Lanny.Schiele@tmisystems.com
|
||||
;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.
|
||||
|
||||
(defun C:DrawHatch (/)
|
||||
(command "undo" "be")
|
||||
(setq os (getvar "OSMODE"))
|
||||
(setvar "OSMODE" 0)
|
||||
(command "UCS" "w")
|
||||
(command "PLINE" "0,0" "0,1" "1,1" "1,0" "c")
|
||||
(command "zoom" "c" "0.5,0.5" 1.1)
|
||||
(setvar "OSMODE" os)
|
||||
(setvar "SNAPMODE" 1)
|
||||
(setvar "SNAPUNIT" (list 0.01 0.01))
|
||||
(command "undo" "e")
|
||||
(alert
|
||||
"Draw pattern within 1x1 box using LINE or POINT entities only..."
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(defun C:SaveHatch (/ round dxf ListToFile
|
||||
user SelSet SelSetSize ssNth
|
||||
Ent EntInfo EntType pt1 pt2
|
||||
Dist AngTo AngFrom XDir YDir
|
||||
Gap DeltaX DeltaY AngZone Counter
|
||||
Ratio Factor HatchName HatchDescr
|
||||
FileLines FileLines FileName
|
||||
Scaler ScaledX ScaledY RF x
|
||||
y h _AB _BC _AC
|
||||
_AD _DE _EF _EH _FH
|
||||
DimZin
|
||||
)
|
||||
;;;* BEGIN NESTED FUNCTIONS
|
||||
|
||||
(defun round (num)
|
||||
(if (>= (- num (fix num)) 0.5)
|
||||
(fix (1+ num))
|
||||
(fix num)
|
||||
)
|
||||
)
|
||||
|
||||
(defun dxf (code EnameOrElist / VarType)
|
||||
(setq VarType (type EnameOrElist))
|
||||
(if (= VarType (read "ENAME"))
|
||||
(cdr (assoc code (entget EnameOrElist)))
|
||||
(cdr (assoc code EnameOrElist))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(defun ListToFile (TextList FileName DoOpenWithNotepad
|
||||
AsAppend / TextItem
|
||||
File RetVal
|
||||
)
|
||||
(if (setq File (open FileName
|
||||
(if AsAppend
|
||||
"a"
|
||||
"w"
|
||||
)
|
||||
)
|
||||
)
|
||||
(progn
|
||||
(foreach TextItem TextList
|
||||
(write-line TextItem File)
|
||||
)
|
||||
(setq File (close File))
|
||||
(if DoOpenWithNotepad
|
||||
(startapp "notepad" FileName)
|
||||
)
|
||||
)
|
||||
)
|
||||
(FindFile FileName)
|
||||
)
|
||||
|
||||
;;;* END NESTED FUNCTIONS
|
||||
|
||||
(princ
|
||||
(strcat
|
||||
"\n."
|
||||
"\n 0,1 ----------- 1,1"
|
||||
"\n | | "
|
||||
"\n | Lines and | "
|
||||
"\n | points must | "
|
||||
"\n | be snapped | "
|
||||
"\n | to nearest | "
|
||||
"\n | 0.01 | "
|
||||
"\n | | "
|
||||
"\n 0,0 ----------- 1,0"
|
||||
"\n."
|
||||
"\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid."
|
||||
)
|
||||
)
|
||||
(textscr)
|
||||
(getstring "\nHit [ENTER] to continue...")
|
||||
|
||||
(princ
|
||||
"\nSelect 1x1 pattern of lines and/or points for new hatch pattern..."
|
||||
)
|
||||
(while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))
|
||||
)
|
||||
(setq ssNth 0
|
||||
SelSetSize (sslength SelSet)
|
||||
DimZin (getvar "DIMZIN")
|
||||
)
|
||||
(setvar "DIMZIN" 11)
|
||||
(if (> SelSetSize 0)
|
||||
(princ "\nAnalyaing entities...")
|
||||
)
|
||||
(while (< ssNth SelSetSize)
|
||||
(setq Ent (ssname SelSet ssNth)
|
||||
EntInfo (entget Ent)
|
||||
EntType (dxf 0 EntInfo)
|
||||
ssNth (+ ssNth 1)
|
||||
)
|
||||
(cond
|
||||
((= EntType "POINT")
|
||||
(setq pt1 (dxf 10 EntInfo)
|
||||
FileLine (strcat "0,"
|
||||
(rtos (car pt1) 2 6)
|
||||
","
|
||||
(rtos (cadr pt1) 2 6)
|
||||
",0,1,0,-1"
|
||||
)
|
||||
)
|
||||
(princ (strcat "\n" FileLine))
|
||||
(setq FileLines (cons FileLine FileLines))
|
||||
)
|
||||
((= EntType "LINE")
|
||||
(setq pt1 (dxf 10 EntInfo)
|
||||
pt2 (dxf 11 EntInfo)
|
||||
Dist (distance pt1 pt2)
|
||||
AngTo (angle pt1 pt2)
|
||||
AngFrom (angle pt2 pt1)
|
||||
IsValid nil
|
||||
)
|
||||
(if
|
||||
(or (equal (car pt1) (car pt2) 0.00000000001)
|
||||
(equal (cadr pt1) (cadr pt2) 0.00000000001)
|
||||
)
|
||||
(setq DeltaX 0
|
||||
DeltaY 1
|
||||
Gap (- Dist 1)
|
||||
IsValid T
|
||||
)
|
||||
(progn
|
||||
(setq Ang (if (< AngTo pi)
|
||||
AngTo
|
||||
AngFrom
|
||||
)
|
||||
AngZone (fix (/ Ang (/ pi 4)))
|
||||
XDir (abs (- (car pt2) (car pt1)))
|
||||
YDir (abs (- (cadr pt2) (cadr pt1)))
|
||||
Factor 1
|
||||
RF 1
|
||||
)
|
||||
(cond
|
||||
((= AngZone 0)
|
||||
(setq DeltaY (abs (sin Ang))
|
||||
DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))
|
||||
)
|
||||
)
|
||||
)
|
||||
((= AngZone 1)
|
||||
(setq DeltaY (abs (cos Ang))
|
||||
DeltaX (abs (sin Ang))
|
||||
)
|
||||
)
|
||||
((= AngZone 2)
|
||||
(setq DeltaY (abs (cos Ang))
|
||||
DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))
|
||||
)
|
||||
)
|
||||
)
|
||||
((= AngZone 3)
|
||||
(setq DeltaY (abs (sin Ang))
|
||||
DeltaX (abs (cos Ang))
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (not (equal XDir YDir 0.001))
|
||||
(progn
|
||||
(setq Ratio (if (< XDir YDir)
|
||||
(/ YDir XDir)
|
||||
(/ XDir YDir)
|
||||
)
|
||||
RF (* Ratio Factor)
|
||||
Scaler (/ 1
|
||||
(if (< XDir YDir)
|
||||
XDir
|
||||
YDir
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (not (equal Ratio (round Ratio) 0.001))
|
||||
(progn
|
||||
(while
|
||||
(and
|
||||
(<= Factor 100)
|
||||
(not (equal RF (round RF) 0.001))
|
||||
)
|
||||
(setq Factor (+ Factor 1)
|
||||
RF (* Ratio Factor)
|
||||
)
|
||||
)
|
||||
(if (and (> Factor 1) (<= Factor 100))
|
||||
(progn
|
||||
(setq _AB (* XDir Scaler Factor)
|
||||
_BC (* YDir Scaler Factor)
|
||||
_AC (sqrt (+ (* _AB _AB) (* _BC _BC)))
|
||||
_EF 1
|
||||
x 1
|
||||
)
|
||||
(while (< x (- _AB 0.5))
|
||||
(setq y (* x (/ YDir XDir))
|
||||
h (if (< Ang (/ pi 2))
|
||||
(- (+ 1 (fix y)) y)
|
||||
(- y (fix y))
|
||||
)
|
||||
)
|
||||
(if (< h _EF)
|
||||
(setq _AD x
|
||||
_DE y
|
||||
_AE (sqrt (+ (* x x) (* y y)))
|
||||
_EF h
|
||||
)
|
||||
)
|
||||
(setq x (+ x 1))
|
||||
)
|
||||
(if (< _EF 1)
|
||||
(setq _EH (/ (* _BC _EF) _AC)
|
||||
_FH (/ (* _AB _EF) _AC)
|
||||
DeltaX (+ _AE
|
||||
(if (> Ang (/ pi 2))
|
||||
(- _EH)
|
||||
_EH
|
||||
)
|
||||
)
|
||||
DeltaY (+ _FH)
|
||||
Gap (- Dist _AC)
|
||||
IsValid T
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(if (= Factor 1)
|
||||
(setq Gap (- Dist (abs (* Factor (/ 1 DeltaY))))
|
||||
IsValid T
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(if
|
||||
IsValid
|
||||
(progn
|
||||
(setq FileLine
|
||||
(strcat
|
||||
(angtos AngTo 0 6)
|
||||
","
|
||||
(rtos (car pt1) 2 8)
|
||||
","
|
||||
(rtos (cadr pt1) 2 8)
|
||||
","
|
||||
(rtos DeltaX 2 8)
|
||||
","
|
||||
(rtos DeltaY 2 8)
|
||||
","
|
||||
(rtos Dist 2 8)
|
||||
","
|
||||
(rtos Gap 2 8)
|
||||
)
|
||||
)
|
||||
(princ (strcat "\n" FileLine))
|
||||
(setq FileLines (cons FileLine FileLines))
|
||||
)
|
||||
(princ (strcat "\n * * * Line with invalid angle "
|
||||
(angtos AngTo 0 6)
|
||||
(chr 186)
|
||||
" omitted. * * *"
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
((princ
|
||||
(strcat "\n * * * Invalid entity " EntType " omitted.")
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
(setvar "DIMZIN" DimZin)
|
||||
(if
|
||||
(and
|
||||
FileLines
|
||||
(setq HatchDescr
|
||||
(getstring T
|
||||
"\nBriefly describe this hatch pattern: "
|
||||
)
|
||||
)
|
||||
(setq FileName (getfiled "Hatch Pattern File"
|
||||
"I:\\Acad\\Hatch\\"
|
||||
"pat"
|
||||
1
|
||||
)
|
||||
)
|
||||
)
|
||||
(progn
|
||||
(if (= HatchDescr "")
|
||||
(setq HatchDescr "Custom hatch pattern")
|
||||
)
|
||||
(setq HatchName (vl-filename-base FileName)
|
||||
FileLines (cons (strcat "*" HatchName "," HatchDescr)
|
||||
(reverse FileLines)
|
||||
)
|
||||
)
|
||||
(princ
|
||||
"\n============================================================"
|
||||
)
|
||||
(princ
|
||||
(strcat "\nPlease wait while the hatch file is created...\n"
|
||||
)
|
||||
)
|
||||
(ListToFile FileLines FileName nil nil)
|
||||
(command "delay" 1500) ;delay required so file can be created and found (silly, but req.)
|
||||
(if (findfile FileName)
|
||||
(progn
|
||||
(setvar "HPNAME" HatchName)
|
||||
(princ (strcat "\nHatch pattern '"
|
||||
HatchName
|
||||
"' is ready to use!"
|
||||
)
|
||||
)
|
||||
)
|
||||
(progn
|
||||
(princ "\nUnable to create hatch pattern file:")
|
||||
(princ (strcat "\n " FileName))
|
||||
)
|
||||
)
|
||||
)
|
||||
(princ
|
||||
(if FileLines
|
||||
"\nCancelled."
|
||||
"\nUnable to create hatch pattern from selected entities."
|
||||
)
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
|
||||
(princ "\n ************************************************************** ")
|
||||
(princ "\n** **")
|
||||
(princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *")
|
||||
(princ "\n* *")
|
||||
(princ "\n* Type in DRAWHATCH to have the environment created to draw. *")
|
||||
(princ "\n* Type in SAVEHATCH to save the pattern you created. *")
|
||||
(princ "\n** **")
|
||||
(princ "\n ************************************************************** ")
|
||||
(princ)
|
||||
36
downloaded/MLLA.lsp
Normal file
36
downloaded/MLLA.lsp
Normal file
@@ -0,0 +1,36 @@
|
||||
(DEFUN C:MLLA ( / )
|
||||
(prompt "/nSelect multileaders: ")
|
||||
(if (setq ss (ssget ":L" '((0 . "MULTILEADER")))); IF anything is found when to makes a selection of mleaders
|
||||
(progn ; THEN
|
||||
(setq mlent (entsel "/nSelect multileader to align to: "); prompt user to select mleader to align others to
|
||||
ed (entget (car mlent)); store entity data for selected mleader
|
||||
txxpt(cadr(assoc 12 ed)); store x point for text insertion
|
||||
dlxpt(cadr (assoc 10 (member '(302 . "LEADER{") ed))); store x point for dogleg object
|
||||
entqty (sslength ss); store quantity of mleaders selected
|
||||
cnt 0); set counter to 0
|
||||
(while (< cnt entqty); while there are still mleaders in list
|
||||
(setq mlent (ssname ss cnt); store entity name (starting with the first mleader)
|
||||
ed (entget mlent); store entity definition
|
||||
|
||||
old_txxpt (assoc 12 ed); store entities text object point data
|
||||
new_txxpt (cons txxpt (cddr old_txxpt)); create new text object point data utilizing x point from mleader to align to
|
||||
ed (subst (cons 12 new_txxpt) old_txxpt ed); swap old text object point data for new in entity record
|
||||
|
||||
old_tfxpt (assoc 10 ed); store entities text frame object point data
|
||||
x-diff (- (- (cadr old_txxpt) txxpt)); find delta-x between current ent and selected alignment mleader
|
||||
newx (+ x-diff (cadr old_tfxpt)); create new x point coordinate for text frame object
|
||||
new_tfxpt (cons newx (cddr old_tfxpt)); create new text object point data utilizing newly created x point
|
||||
ed (subst (cons 10 new_tfxpt) old_tfxpt ed); swap old text frame object point data for new in entity record
|
||||
|
||||
old_dlxpt (assoc 10 (member '(302 . "LEADER{") ed)); store entities dogleg object point data
|
||||
new_dlxpt (cons dlxpt (cddr old_dlxpt)); create new dogleg object point data utilizing x point from mleader to align to
|
||||
ed (subst (cons 10 new_dlxpt) old_dlxpt ed)); swap old dogleg object point data for new in entity record
|
||||
(entmod ed); write new data to database
|
||||
|
||||
(setq cnt (1+ cnt)); set counter to advance to the next entity in selection set
|
||||
); end WHILE
|
||||
); end THEN
|
||||
); end IF (no ELSE statement specified)
|
||||
(princ); exit quietly
|
||||
)
|
||||
(princ); load clean
|
||||
221
downloaded/PLDiet.lsp
Normal file
221
downloaded/PLDiet.lsp
Normal file
@@ -0,0 +1,221 @@
|
||||
;;; PLDIET.lsp [command name: PLD]
|
||||
;;; To put lightweight PolyLines on a DIET (remove excess vertices); usually
|
||||
;;; used for contours with too many too-closely-spaced vertices.
|
||||
;;; Concept from PVD routine [posted on AutoCAD Customization Discussion
|
||||
;;; Group by oompa_l, July 2009] by Brian Hailey, added to by CAB, and
|
||||
;;; WEED and WEED2 routines by Skyler Mills at Cadalyst CAD Tips [older
|
||||
;;; routines for "heavy" Polylines that won't work on newer lightweight ones];
|
||||
;;; simplified in entity data list processing, and enhanced in other ways [error
|
||||
;;; handling, default values, join collinear segments beyond max. distance,
|
||||
;;; limit to current space/tab, account for change in direction across 0 degrees,
|
||||
;;; option to keep or eliminate arc segments] by Kent Cooper, August 2009.
|
||||
;;; Last edited 28 August 2013
|
||||
;
|
||||
(defun C:PLD
|
||||
(/ *error* cmde disttemp cidtemp arctemp plinc plsel pl
|
||||
pldata ucschanged front 10to42 vinc verts vert1 vert2 vert3)
|
||||
;
|
||||
(defun *error* (errmsg)
|
||||
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
|
||||
(princ (strcat "\nError: " errmsg))
|
||||
); end if
|
||||
(if ucschanged (command "_.ucs" "_prev"))
|
||||
; ^ i.e. don't go back unless routine reached UCS change but didn't change back
|
||||
(command "_.undo" "_end")
|
||||
(setvar 'cmdecho cmde)
|
||||
); end defun - *error*
|
||||
;
|
||||
(setq cmde (getvar 'cmdecho))
|
||||
(setvar 'cmdecho 0)
|
||||
(command "_.undo" "_begin")
|
||||
(setq
|
||||
disttemp
|
||||
(getdist
|
||||
(strcat
|
||||
"\nMaximum distance between non-collinear vertices to straighten"
|
||||
(if *distmax* (strcat " <" (rtos *distmax* 2 2) ">") ""); default only if not first use
|
||||
": "
|
||||
); end strcat
|
||||
); end getdist & disttemp
|
||||
*distmax*
|
||||
(cond
|
||||
(disttemp); user entered number or picked distance
|
||||
(*distmax*); otherwise, user hit Enter - keep value
|
||||
); end cond & *distmax*
|
||||
cidtemp
|
||||
(getangle
|
||||
(strcat
|
||||
"\nMaximum change in direction to straighten"
|
||||
(strcat ; offer prior choice if not first use; otherwise 15 degrees
|
||||
" <"
|
||||
(if *cidmax* (angtos *cidmax*) (angtos (/ pi 12)))
|
||||
">"
|
||||
); end strcat
|
||||
": "
|
||||
); end strcat
|
||||
); end getdist & cidtemp
|
||||
*cidmax*
|
||||
(cond
|
||||
(cidtemp); user entered number or picked angle
|
||||
(*cidmax*); Enter with prior value set - use that
|
||||
((/ pi 12)); otherwise [Enter on first use] - 15 degrees
|
||||
); end cond & *cidmax*
|
||||
plinc 0 ; incrementer through selection set of Polylines
|
||||
); end setq
|
||||
(initget "Retain Straighten")
|
||||
(setq
|
||||
arctemp
|
||||
(getkword
|
||||
(strcat
|
||||
"\nRetain or Straighten arc segments [R/S] <"
|
||||
(if *arcstr* (substr *arcstr* 1 1) "S"); at first use, S default; otherwise, prior choice
|
||||
">: "
|
||||
); end strcat
|
||||
); end getkword
|
||||
*arcstr*
|
||||
(cond
|
||||
(arctemp); if User typed something, use it
|
||||
(*arcstr*); if Enter and there's a prior choice, keep that
|
||||
("Straighten"); otherwise [Enter on first use], Straighten
|
||||
); end cond & *arcstr*
|
||||
); end setq
|
||||
;
|
||||
(prompt "\nSelect LWPolylines to put on a diet, or press Enter to select all: ")
|
||||
(cond
|
||||
((setq plsel (ssget '((0 . "LWPOLYLINE"))))); user-selected Polylines
|
||||
((setq plsel (ssget "X" (list '(0 . "LWPOLYLINE") (cons 410 (getvar 'ctab))))))
|
||||
; all Polylines [in current space/tab only]
|
||||
); end cond
|
||||
;
|
||||
(repeat (sslength plsel)
|
||||
(setq pl (ssname plsel plinc))
|
||||
(while
|
||||
(equal (vlax-curve-getStartPoint pl) (vlax-curve-getPointAtParam pl 1) 1e-6)
|
||||
; to correct for possibility that more than one vertices at beginning coincide,
|
||||
; in which case Pline does not define a CS under UCS OBject, causing error
|
||||
(command "_.pedit" pl "_edit" "_straighten" "" "" "_go" "_exit" "")
|
||||
); while
|
||||
(setq pldata (entget pl))
|
||||
(if (/= (cdr (last pldata)) (trans '(0 0 1) 1 0)); extr. direction not parallel current CS
|
||||
; for correct angle & distance calculations [projected onto current construction
|
||||
; plane], since 10-code entries for LWPolylines are only 2D points:
|
||||
(progn
|
||||
(command "_.ucs" "_new" "_object" pl) ; set UCS to match object
|
||||
(setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't
|
||||
); end progn
|
||||
); end if
|
||||
(setq
|
||||
front ; list of "front end" [pre-vertices] entries, minus entity names & handle
|
||||
(vl-remove-if
|
||||
'(lambda (x)
|
||||
(member (car x) '(-1 330 5 10 40 41 42 210))
|
||||
); end lambda
|
||||
pldata
|
||||
); end removal & front
|
||||
10to42 ; list of all code 10, 40, 41, 42 entries only
|
||||
(vl-remove-if-not
|
||||
'(lambda (x)
|
||||
(member (car x) '(10 40 41 42))
|
||||
); end lambda
|
||||
pldata
|
||||
); end removal & 10to42
|
||||
vinc (/ (length 10to42) 4); incrementer for vertices within each Polyline
|
||||
verts nil ; eliminate from previous Polyline [if any]
|
||||
); end setq
|
||||
(if (= *arcstr* "Straighten")
|
||||
(progn
|
||||
(setq bulges ; find any bulge factors
|
||||
(vl-remove-if-not
|
||||
'(lambda (x)
|
||||
(and
|
||||
(= (car x) 42)
|
||||
(/= (cdr x) 0.0)
|
||||
); end and
|
||||
); end lambda
|
||||
10to42
|
||||
); end removal & bulges
|
||||
); end setq
|
||||
(foreach x bulges (setq 10to42 (subst '(42 . 0.0) x 10to42)))
|
||||
; straighten all arc segments to line segments
|
||||
); end progn
|
||||
); end if
|
||||
(repeat vinc
|
||||
(setq
|
||||
verts ; sub-group list: separate list of four entries for each vertex
|
||||
(cons
|
||||
(list
|
||||
(nth (- (* vinc 4) 4) 10to42)
|
||||
(nth (- (* vinc 4) 3) 10to42)
|
||||
(nth (- (* vinc 4) 2) 10to42)
|
||||
(nth (1- (* vinc 4)) 10to42)
|
||||
); end list
|
||||
verts
|
||||
); end cons & verts
|
||||
vinc (1- vinc) ; will be 0 at end
|
||||
); end setq
|
||||
); end repeat
|
||||
(while (nth (+ vinc 2) verts); still at least 2 more vertices
|
||||
(if
|
||||
(or ; only possible if chose to Retain arc segments
|
||||
(/= (cdr (assoc 42 (nth vinc verts))) 0.0); next segment is arc
|
||||
(/= (cdr (assoc 42 (nth (1+ vinc) verts))) 0.0); following segment is arc
|
||||
); end or
|
||||
(setq vinc (1+ vinc)); then - don't straighten from here; move to next
|
||||
(progn ; else - analyze from current vertex
|
||||
(setq
|
||||
vert1 (cdar (nth vinc verts)) ; point-list location of current vertex
|
||||
vert2 (cdar (nth (1+ vinc) verts)); of next one
|
||||
vert3 (cdar (nth (+ vinc 2) verts)); of one after that
|
||||
ang1 (angle vert1 vert2)
|
||||
ang2 (angle vert2 vert3)
|
||||
); end setq
|
||||
(if
|
||||
(or
|
||||
(equal ang1 ang2 0.0001); collinear, ignoring distance
|
||||
(and
|
||||
(<= (distance vert1 vert3) *distmax*)
|
||||
; straightens if direct distance from current vertex to two vertices later is
|
||||
; less than or equal to maximum; if preferred to compare distance along
|
||||
; Polyline through intermediate vertex, replace above line with this:
|
||||
; (<= (+ (distance vert1 vert2) (distance vert2 vert3)) *distmax*)
|
||||
(<=
|
||||
(if (> (abs (- ang1 ang2)) pi); if difference > 180 degrees
|
||||
(+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
|
||||
; then - compensate for change in direction crossing 0 degrees
|
||||
(abs (- ang1 ang2)); else - size of difference
|
||||
); end if
|
||||
*cidmax*
|
||||
); end <=
|
||||
); end and
|
||||
); end or
|
||||
(setq verts (vl-remove (nth (1+ vinc) verts) verts))
|
||||
; then - remove next vertext, stay at current vertex for next comparison
|
||||
(setq vinc (1+ vinc)); else - leave next vertex, move to it as new base
|
||||
); end if - distance & change in direction analysis
|
||||
); end progn - line segments
|
||||
); end if - arc segment check
|
||||
); end while - working through vertices
|
||||
(setq
|
||||
front (subst (cons 90 (length verts)) (assoc 90 front) front)
|
||||
; update quantity of vertices for front end
|
||||
10to42 nil ; clear original set
|
||||
); end setq
|
||||
(foreach x verts (setq 10to42 (append 10to42 x)))
|
||||
; un-group four-list vertex sub-lists back to one list of all 10, 40, 41, 42 entries
|
||||
(setq pldata (append front 10to42 (list (last pldata))))
|
||||
; put front end, vertex entries and extrusion direction back together
|
||||
(entmake pldata)
|
||||
(entdel pl); remove original
|
||||
(setq plinc (1+ plinc)); go on to next Polyline
|
||||
(if ucschanged
|
||||
(progn
|
||||
(command "_.ucs" "_prev")
|
||||
(setq ucschanged nil) ; eliminate UCS reset in *error* since routine did it already
|
||||
); end progn
|
||||
); end if - UCS reset
|
||||
); end repeat - stepping through set of Polylines
|
||||
(command "_.undo" "_end")
|
||||
(setvar 'cmdecho cmde)
|
||||
(princ)
|
||||
); end defun - PLD
|
||||
(prompt "\nType PLD to put PolyLines on a Diet.")
|
||||
35
downloaded/Polyarea.lsp
Normal file
35
downloaded/Polyarea.lsp
Normal file
@@ -0,0 +1,35 @@
|
||||
;;POLYAREA.LSP
|
||||
;; Adds the area of one or more closed polylines
|
||||
;;
|
||||
(defun C:POLYAREA (/ a ss n du)
|
||||
(setq a 0
|
||||
du (getvar "dimunit")
|
||||
ss (ssget '((0 . "*POLYLINE"))))
|
||||
(if ss
|
||||
(progn
|
||||
(setq n (1- (sslength ss)))
|
||||
(while (>= n 0)
|
||||
(command "_.area" "_o" (ssname ss n))
|
||||
(setq a (+ a (getvar "area"))
|
||||
n (1- n)))
|
||||
(alert
|
||||
(strcat "The total area of the selected\nobject(s) is "
|
||||
(if (or (= du 3)(= du 4)(= du 6))
|
||||
;
|
||||
;The following 2 lines translate the area to square inches and feet
|
||||
;for users using US engineering or architectural units:
|
||||
;
|
||||
(strcat (rtos a 2 2) " square inches,\nor "
|
||||
(rtos (/ a 144.0) 2 3) " square feet.")
|
||||
;
|
||||
;In the following line, change the word "units" to whatever units
|
||||
;you are using - meters, millimeters, feet, etc.
|
||||
;
|
||||
(strcat (rtos (/ a 10000) 2 3) " square meters.")))))
|
||||
(alert "\nNo Polylines selected!"))
|
||||
(princ)
|
||||
)
|
||||
(alert
|
||||
(strcat "POLYAREA.LSP"
|
||||
"\n\n Type POLYAREA to start"))
|
||||
(princ)
|
||||
1696
downloaded/StripMtext v5-0c.lsp
Normal file
1696
downloaded/StripMtext v5-0c.lsp
Normal file
File diff suppressed because it is too large
Load Diff
105
downloaded/XClipM.lsp
Normal file
105
downloaded/XClipM.lsp
Normal file
@@ -0,0 +1,105 @@
|
||||
; XClipM.lsp allows user to select supported objects to Clip using multiple boundaries
|
||||
; Current supported objects are:
|
||||
; Block Insert, External Reference, Image, DGN, DWF, PDF
|
||||
; Creating a donut hole clip is not supported
|
||||
; written by: Paul Li - 12/02/2010
|
||||
; updated on 3/19/2014 to support multiple objects to clip
|
||||
; Note: circle shaped pline boundaries are not supported
|
||||
(princ"\nLoading XclipM...")(princ)
|
||||
(defun c:xclipm
|
||||
(/ cmdecho count count1 emax emax1 en ChkClpBnd menuecho obxr obdxr obdxrtype obxrcopy ss ss1 xclipm_err xclipm_olderr) ; declare locally
|
||||
(defun xclipm_err (msg) ; define own error function
|
||||
(if (not (member msg '("console break" "Function cancelled" "quit / exit abort" ""))) ; if function not cancelled by user
|
||||
(princ (strcat "\nError: " msg)) ; then show error message
|
||||
) ; if
|
||||
(setvar "cmdecho" cmdecho) ; restore command echo
|
||||
(setvar "menuecho" menuecho)
|
||||
(princ)
|
||||
) ; defun
|
||||
;end error function
|
||||
(defun ChkClpBnd (ename / Data Dict tempDict)
|
||||
; Check if object has existing clipping boundry
|
||||
(if
|
||||
(and
|
||||
(setq Data (entget ename))
|
||||
(setq Dict (cdr (assoc 360 Data)))
|
||||
(setq tempDict (dictsearch Dict "ACAD_FILTER"))
|
||||
(setq tempDict (dictsearch (cdr (assoc -1 tempDict)) "SPATIAL"))
|
||||
)
|
||||
(cons '(0 . "SPATIAL_FILTER") (member (assoc 100 tempDict) tempDict)) ; return object if existing clipping boundary found
|
||||
)
|
||||
) ; ChkClpBnd
|
||||
(setq xclipm_olderr *error* ; Save error routine
|
||||
*error* xclipm_err ; Substitute ours
|
||||
)
|
||||
(setq cmdecho (getvar"cmdecho")) ; save command echos
|
||||
(setq menuecho (getvar"menuecho"))
|
||||
(setvar"cmdecho"0)(setvar"menuecho"0) ; turn off command echos
|
||||
(princ "\nSelect Block, DGN, DWF, Image, PDF or Xref to Clip:")
|
||||
(setq ss1 (ssget '((-4 . "<OR")(0 . "IMAGE") (0 . "DGNUNDERLAY") (0 . "DWFUNDERLAY") (0 . "PDFUNDERLAY") (0 . "INSERT")(-4 . "OR>"))))
|
||||
(if ss1
|
||||
(progn
|
||||
(princ"\nSelect Closed Boundaries to Use for Clipping:")
|
||||
(setq ss (ssget (list '(-4 . "<AND") '(0 . "LWPOLYLINE") '(-4 . "&") '(70 . 1) '(-4 . "AND>"))))
|
||||
(if ss
|
||||
(progn
|
||||
(setq count1 0) ; initialize counter
|
||||
(setq emax1 (sslength ss1)) ; get length of ss1
|
||||
(while (< count1 emax1) ; while there are still entities in ss1
|
||||
(setq obxr (ssname ss1 count1)) ; get entity's name
|
||||
(redraw obxr 3) ; highlite selected object
|
||||
(setq obdxr (entget obxr)) ; retrieve objectives data
|
||||
(setq obdxrtype (cdr(assoc 0 obdxr))) ; retrieve object type
|
||||
(princ (strcat "\n" obdxrtype " Selected for Clipping..."))
|
||||
(setq count 0) ; initialize counter
|
||||
(setq emax (sslength ss)) ; get length of ss
|
||||
(while (< count emax) ; while there are still entities in ss
|
||||
(setq en (ssname ss count)) ; get entity's name
|
||||
(cond
|
||||
((= obdxrtype "INSERT") ; if block insert or xref
|
||||
(command"_.COPY" obxr "" "0,0,0" "0,0,0") ; make copy of object to clip
|
||||
(setq obxrcopy (entlast))
|
||||
(if (ChkClpBnd obxrcopy)(command"_.XCLIP" obxrcopy "" "_D")) ; check if there's a clipping boundary & delete
|
||||
(command"_.XCLIP" obxrcopy "" "_New" "_S" en) ; clip
|
||||
)
|
||||
((= obdxrtype "IMAGE") ; if image
|
||||
(command"_.COPY" obxr "" "0,0,0" "0,0,0")
|
||||
(setq obxrcopy (entlast))
|
||||
(command"_.IMAGECLIP" obxrcopy "_D")
|
||||
(command"_.IMAGECLIP" obxrcopy "_New" "_S" en)
|
||||
)
|
||||
((= obdxrtype "DGNUNDERLAY") ; if dgn
|
||||
(command"_.COPY" obxr "" "0,0,0" "0,0,0")
|
||||
(setq obxrcopy (entlast))
|
||||
(command"_.DGNCLIP" obxrcopy "_D")
|
||||
(command"_.DGNCLIP" obxrcopy "_New" "_S" en)
|
||||
)
|
||||
((= obdxrtype "DWFUNDERLAY") ; if dwf
|
||||
(command"_.COPY" obxr "" "0,0,0" "0,0,0")
|
||||
(setq obxrcopy (entlast))
|
||||
(command"_.DWFCLIP" obxrcopy "_D")
|
||||
(command"_.DWFCLIP" obxrcopy "_New" "_S" en)
|
||||
)
|
||||
((= obdxrtype "PDFUNDERLAY") ; if pdf
|
||||
(command"_.COPY" obxr "" "0,0,0" "0,0,0")
|
||||
(setq obxrcopy (entlast))
|
||||
(command"_.PDFCLIP" obxrcopy "_D")
|
||||
(command"_.PDFCLIP" obxrcopy "_New" "_S" en)
|
||||
)
|
||||
) ; cond
|
||||
(setq count (1+ count)) ; advance to next boundary object
|
||||
) ; while
|
||||
(princ (strcat "\n" obdxrtype " Clipped Successfully to Selected Boundaries."))
|
||||
(command"_.ERASE" obxr "") ; erase original object
|
||||
(setq count1 (1+ count1)) ; advance to next boundary object
|
||||
) ; while
|
||||
) ; progn
|
||||
(princ"\nNo Supported Closed Boundaries Selected.")
|
||||
) ; if
|
||||
) ; progn
|
||||
(princ"\nNo Supported Objects Selected for Clipping.")
|
||||
) ; if ss1
|
||||
(if xclipm_olderr (setq *error* xclipm_olderr)) ; Restore old *error* handler
|
||||
(setvar"cmdecho"cmdecho)(setvar"menuecho"menuecho)(princ) ; restore command echos
|
||||
) ; defun xclipm
|
||||
(princ"... Command loaded.")(princ)
|
||||
BIN
downloaded/cad-corner.com/90lsp.zip
Normal file
BIN
downloaded/cad-corner.com/90lsp.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/Best Of Lisp.rar
Normal file
BIN
downloaded/cad-corner.com/Best Of Lisp.rar
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/DetailBook.zip
Normal file
BIN
downloaded/cad-corner.com/DetailBook.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/Power.rar
Normal file
BIN
downloaded/cad-corner.com/Power.rar
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/archcalc.zip
Normal file
BIN
downloaded/cad-corner.com/archcalc.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/autopat.zip
Normal file
BIN
downloaded/cad-corner.com/autopat.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/bylaybk.zip
Normal file
BIN
downloaded/cad-corner.com/bylaybk.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/calc.zip
Normal file
BIN
downloaded/cad-corner.com/calc.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/clock.zip
Normal file
BIN
downloaded/cad-corner.com/clock.zip
Normal file
Binary file not shown.
32
downloaded/cad-corner.com/flat.lsp
Normal file
32
downloaded/cad-corner.com/flat.lsp
Normal file
@@ -0,0 +1,32 @@
|
||||
; Flatten a 3D drawing
|
||||
; Written by Eduard
|
||||
; This command will set all elevations and points to zero, efectively flattening any 3D drawing.
|
||||
;
|
||||
(defun c:flat (/ total-nabor)
|
||||
(vl-load-com)
|
||||
(if
|
||||
(setq total-nabor (ssget "x" '((410 . "model"))))
|
||||
(progn
|
||||
(setq total-nabor
|
||||
(mapcar 'vlax-ename->vla-object
|
||||
(mapcar 'cadr
|
||||
(ssnamex total-nabor)
|
||||
|
||||
) ;_ end of mapcar
|
||||
) ;_ end of mapcar
|
||||
) ;_ end of setq
|
||||
(foreach i '(1e99 -1e99)
|
||||
(mapcar (function (lambda (x)
|
||||
(vla-move x
|
||||
(vlax-3d-point (list 0 0 0))
|
||||
(vlax-3d-point (list 0 0 i))
|
||||
) ;_ end of vla-move
|
||||
) ;_ end of lambda
|
||||
) ;_ end of function
|
||||
total-nabor
|
||||
) ;_ end of mapcar
|
||||
) ;_ end of foreach
|
||||
) ;_ end of progn
|
||||
) ;_ end of if
|
||||
(princ)
|
||||
) ;_ end of defun
|
||||
BIN
downloaded/cad-corner.com/grabbag.zip
Normal file
BIN
downloaded/cad-corner.com/grabbag.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/library.zip
Normal file
BIN
downloaded/cad-corner.com/library.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/mlayer.zip
Normal file
BIN
downloaded/cad-corner.com/mlayer.zip
Normal file
Binary file not shown.
BIN
downloaded/cad-corner.com/protxlsp.zip
Normal file
BIN
downloaded/cad-corner.com/protxlsp.zip
Normal file
Binary file not shown.
52
downloaded/mtext to mleader.lsp
Normal file
52
downloaded/mtext to mleader.lsp
Normal file
@@ -0,0 +1,52 @@
|
||||
|
||||
;;; By RonJon
|
||||
;;; Found at http://www.cadtutor.net/forum/showthread.php?41822-changing-text-mtext-to-multileaders...
|
||||
(defun c:am (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth)
|
||||
(vl-load-com)
|
||||
(defun rjp-getbbwdth (obj / out ll ur)
|
||||
(vla-getboundingbox obj 'll 'ur)
|
||||
(setq out (mapcar 'vlax-safearray->list (list ll ur)))
|
||||
(distance (car out) (list (caadr out) (cadar out)))
|
||||
)
|
||||
(if (setq ss (ssget '((0 . "*TEXT"))))
|
||||
(progn (setq txt (apply
|
||||
'strcat
|
||||
(mapcar
|
||||
'cdr
|
||||
(vl-sort
|
||||
(mapcar '(lambda (x)
|
||||
(cons (vlax-get x 'insertionpoint)
|
||||
(strcat (vlax-get x 'textstring) " ")
|
||||
)
|
||||
)
|
||||
(setq
|
||||
ss (mapcar
|
||||
'vlax-ename->vla-object
|
||||
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
|
||||
)
|
||||
)
|
||||
)
|
||||
(function (lambda (y1 y2) (< (cadr (car y2)) (cadr (car y1))))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
w (car (vl-sort (mapcar 'rjp-getbbwdth ss) '>))
|
||||
txt (apply 'strcat
|
||||
(mapcar 'chr (reverse (cdr (reverse (vl-string->list txt)))))
|
||||
)
|
||||
)
|
||||
(mapcar 'vla-delete ss)
|
||||
)
|
||||
)
|
||||
(if (and (setq pt1 (getpoint "\nSpecify leader arrowhead location: "))
|
||||
(setq pt2 (getpoint pt1 "\nSpecify landing location: "))
|
||||
)
|
||||
(progn (command "._MLEADER" pt1 pt2 "")
|
||||
(setq newleader (vlax-ename->vla-object (entlast)))
|
||||
(vla-put-textstring newleader txt)
|
||||
(vla-put-textwidth newleader w)
|
||||
)
|
||||
)
|
||||
(princ)
|
||||
)
|
||||
32
downloaded/tlen.lsp
Normal file
32
downloaded/tlen.lsp
Normal file
@@ -0,0 +1,32 @@
|
||||
;|
|
||||
|
||||
TLEN.LSP - Total LENgth of selected objects
|
||||
(c) 1998 Tee Square Graphics
|
||||
|
||||
|;
|
||||
|
||||
(defun C:TLEN (/ ss tl n ent itm obj l)
|
||||
(setq ss (ssget)
|
||||
tl 0
|
||||
n (1- (sslength ss)))
|
||||
(while (>= n 0)
|
||||
(setq ent (entget (setq itm (ssname ss n)))
|
||||
obj (cdr (assoc 0 ent))
|
||||
l (cond
|
||||
((= obj "LINE")
|
||||
(distance (cdr (assoc 10 ent))(cdr (assoc 11 ent))))
|
||||
((= obj "ARC")
|
||||
(* (cdr (assoc 40 ent))
|
||||
(if (minusp (setq l (- (cdr (assoc 51 ent))
|
||||
(cdr (assoc 50 ent)))))
|
||||
(+ pi pi l) l)))
|
||||
((or (= obj "CIRCLE")(= obj "SPLINE")(= obj "POLYLINE")
|
||||
(= obj "LWPOLYLINE")(= obj "ELLIPSE"))
|
||||
(command "_.area" "_o" itm)
|
||||
(getvar "perimeter"))
|
||||
(T 0))
|
||||
tl (+ tl l)
|
||||
n (1- n)))
|
||||
(alert (strcat "Total length of selected objects is " (rtos tl)))
|
||||
(princ)
|
||||
)
|
||||
Reference in New Issue
Block a user