TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: Krushert on January 20, 2010, 09:13:39 PM
-
I am cobbling this together from a handful of routines but I crashing at this point.
(setq objectlayer (cdr [color=red](assoc 8 PlineID)[/color]))
Well that is what the debugger is telling me
Anyway I coming up with nothing on what to replace it with so I am asking for a little help.
Thanks a million.
;;;; User Selection of PolyLine and test thereof
(IF
(setq
ss (ssget
'((0 . "LWPOLYLINE"))
)
)
(setq
PlineID
(vla-get-objectid (vlax-ename->vla-object (ssname ss 0)))
)
)
;;;; Generating of FeildString Variable for the plines length
;;;; Use the FIELD-command to compose the next line: (itoa PlineID)
(setq fieldstring
(strcat "%<\\AcObjProp Object(%<\\_ObjId "
(itoa PlineID)
">%).Length \\f \"%lu6\">%"
)
)
;;;; Gathering Layer Info from User Selected object changes current layer to that of selected object
(setq objectlayer (cdr [color=red](assoc 8 PlineID)[/color]))
(setq curlay (getvar "clayer"))
(setvar "clayer" objectlayer)
-
You're getting Entity, Object and Objectid mixed up.
See if this helps
(IF (setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq PlineID (vla-get-objectid
(vlax-ename->vla-object (setq ent (ssname ss 0)))
)
)
)
;;
(setq layerName (cdr (assoc 8 (entget ent))))
;;//--------------------------------------
(IF (setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq PlineID (vla-get-objectid (vlax-ename->vla-object (ssname ss 0))))
)
(setq *AcadDocument (vla-get-activedocument (vlax-get-acad-object))
layerObject (vla-ObjectIDToObject *AcadDocument PlineID)
layerName (vla-get-layer layerObject)
)
;;//--------------------------------------
(IF (setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq
PlineID (vla-get-objectid
(setq ObjectPline (vlax-ename->vla-object (ssname ss 0)))
)
)
)
(setq layerName (vla-get-layer ObjectPline))
;;//--------------------------------------
-
You're getting Entity, Object and Objectid mixed up.
Thought as much from taking a breather and then studying past examples. Looks like I got some reading to do with the above.
I was trying to figure out how to use (setq layerName (cdr (assoc 8 (entget ent)))) in the first option that you show and I actually tried the vla-get-layer halfheartedly. I see that I need that extra Setq in there somewhere. Anyway I choose the 3rd option and the the routine works.
-
Just thought of something to kick this routine up a notch. Where can I find some examples of combining the ssget function with the getpoint function all with one user pick?
I need to cull the above info from a multi-segmented pline along with angle immediate segment that the user picked on and the point on where the user picked. The latter two would be to insert a block on a pline at that point and rotate the block to align with pline.
-
Do you want multiple entitys
(ssget ....
or a single entity
(entsel ....
-
Do you want multiple entitys
(ssget ....
or a single entity
(entsel ....
I am selecting a single entity. :?
-
To break the process up, see how this goes for a start ..
Note: Code reads best in the Mercury forum theme.
[add:] Profile->LookAndLayoutPreferences->CurrentTheme(change)->Mercury
LIBRARY FUNCTIONS
;;;------------------------------------------------------------------
;; (KDUB:ENTSel_3 <Promptmsg> <typelist > <nentselflag > )
(defun kdub:entsel_3 (promptmsg ;
typelist ; List of entity types allowed to be selected
nentselflag ; If true nentsel permitted , otherwise use entsel.
/ pickok returnvalue
tmp
)
(setq promptmsg (strcat "\n"
(cond (promptmsg)
("Select object")
)
" : "
)
)
(while (not pickok)
(setvar "ERRNO" 0)
(setq returnvalue (if nentselflag
(nentsel promptmsg)
(entsel promptmsg)
)
)
(cond
((= (getvar "ERRNO") 52) ; enter
;; skip out
(setq pickok t)
)
((= (getvar "ERRNO") 7)
(princ "Nothing found at selectedpoint. ")
)
((and
(setq tmp (entget (car returnvalue))) ; object type
typelist
(not (member (cdr (assoc 0 tmp)) (mapcar 'strcase typelist)))
) ; wrong type
(alert
(strcat "Selected object is not"
"\na "
(apply 'strcat
(cons (car typelist)
(mapcar '(lambda (x) (strcat "\nor " x))
(cdr typelist)
)
)
)
". "
)
)
)
;; skip out
((setq pickok t))
)
)
;; return EntityENAME/PickPoint List
returnvalue
)
;;;------------------------------------------------------------------
;;
(defun kdub:getsegment (obj pt / cpt eparam stparam)
;; Stig Madsen
(cond
((setq cpt (vlax-curve-getclosestpointto obj pt t))
(setq eparam (fix (vlax-curve-getendparam obj)))
(if (= eparam
(setq stparam (fix (vlax-curve-getparamatpoint obj cpt)))
)
(setq stparam (1- stparam))
(setq eparam (1+ stparam))
)
(list eparam
(vlax-curve-getpointatparam obj stparam)
(vlax-curve-getpointatparam obj eparam)
)
)
)
)
;;;------------------------------------------------------------------
;;
TEST CODE
Should return the start end endpoint of the Selected LINE or LWPOLYLINE Segment
(if (setq plineent (kdub:entsel_3 "Select Work line"
'("LINE" "LWPOLYLINE")
t
)
)
(progn (setq plineobj (vlax-ename->vla-object (car plineent))
;; PickPoint (osnap (cadr plineent) "_nea")
PickPointWorld (trans (osnap (cadr plineent) "_nea") acUCS acWorld)
)
(kdub:getsegment plineobj PickPointWorld)
)
)
Once you understand that, deal with inserting the block.
-
Thanks Kerry. I see it is not an easy nut to crack. I will pick away at it and will be back with questions.
-
Here is an old routine that may be modified for your use.
;; 03.17.08 CAB modified the block insert to use the Scale of the first
;; block inserted. Also changed the entget to getpoint for the object
;; selection so that osnaps will be visible
;; http://forums.cadalyst.com/showthread.php?p=20949#post20949
;| This routine is further modified by Alan Butler aka CAB aka CAB2k
The routine will work with a block without attributes so I modified
it to work with most blocks in that the break points are determined
by the intersect points of LINES that are farthest apart.
I renamed it BlockInsert for my use. I did minimal testing with a
valve symbol inserted into a pline. No UCS testing.
This routine works by exploding the block, then determining the intersect
points. After the exploded block is removed.
Note that this will not work with all blocks.
|;
;|Routine to label contours drawn by Line/Arc/Polyline. Originally penned by
CiphDRMRS, aka T.Willey, on the AUGI Forums. Modified by Jeff Mishler.
An assumption is made that a valid block with 1 attribute is selected.
|;
(defun c:BlockInsert (/ atts ent entobj inspt
intpts lastent oldecho oldreq oldosnap p1
p2 pt sel tmplist tmplist2 tmpobj
inpt re elst *error*
)
; (setq *bname nil) ; force new block each time, or
;; paste at the command line to reset the block name
(vl-load-com)
(defun *error* (msg)
(if msg
(princ msg)
)
(setvar "attreq" oldreq)
(setvar "osmode" oldosnap)
(command "undo" "end")
(setvar "cmdecho" oldecho)
(princ)
)
;; CAB 05/07/06
;; group on the first three elements A B C of a flat list A B C D E F
;; list must be divisable by 3, no error checking
;; InpLst is the flat list ((A B C) (D E F) (G H I)...)
(defun group_on3 (inplst / outlst tmp grp idx sub)
(while inplst
(setq outlst (cons (list (car inplst) (cadr inplst) (caddr inplst)) outlst))
(setq inplst (cdddr inplst))
)
outlst
)
(setq OldReq (getvar "attreq")
oldecho (getvar "cmdecho")
oldOsnap (getvar "osmode")
)
(setvar "cmdecho" 0)
(command "undo" "end")
(command "undo" "be")
(setvar "attreq" 0)
(setvar "osmode" 512)
;; CAB made *bname var global so that I could reuse the var in a session
;; If you want the block name to be changed at each start uncomment the next line
;; (setq *bname nil)
(while
(and
;; use getpoint for osnaps to work
(setq inspt (getpoint "\n Select object where you wish the block to be inserted: "))
(setq inspt (osnap inspt "_near"))
(setq Sel (nentselp inspt))
)
(setq Ent (car Sel)
entObj (vlax-ename->vla-object Ent)
)
(if (not *bname)
(progn
(setvar "cmdecho" 1)
(initdia)
(command "_.insert")
(command InsPt)
(while (> (getvar "cmdactive") 0)
(command pause)
)
(setvar "cmdecho" 0)
(setq LastEnt (entlast)
elst (entget LastEnt)
*bname (cdr (assoc 2 elst))
*ScaleX (cdr (assoc 41 elst))
*ScaleY (cdr (assoc 42 elst))
)
)
(progn
(setvar "cmdecho" 1)
(command "_.-insert" *bname)
(command InsPt *ScaleX *ScaleY pause)
(setvar "cmdecho" 0)
(setq LastEnt (entlast))
)
)
(setq tmpObj (vlax-ename->vla-object LastEnt)
z (last inspt)
)
(setq tmpList (vlax-invoke tmpObj 'Explode))
;;==================================================================
;; CAB modified this section & removed some code
(setq Intpts nil ; CAB
re nil)
(foreach i tmpList
(mapcar '(lambda (x)
(vlax-invoke x 'move (list 0.0 0.0 0.0) '(0.0 0.0 1e99))
(vlax-invoke x 'move (list 0.0 0.0 0.0) '(0.0 0.0 -1e99))
)
(list entobj i)
)
;; collect all points of intersect
;; CAB revised 11.08.07 to accommodate objects that have more than one
;; intersect point
(if (setq inpt (vlax-invoke entobj 'intersectwith i acextendnone)) ; CAB
(setq inpt (group_on3 inpt) ; CAB revised 11.08.07
intpts (append inpt intpts)) ; CAB revised 11.08.07
)
(vlax-invoke entobj 'move (list 0.0 0.0 0.0) (list 0.0 0.0 z))
(vlax-invoke i 'move (list 0.0 0.0 0.0) (list 0.0 0.0 z))
(vla-delete i)
)
;;==================================================================
;; CAB added this section of code
;; Find the two points farthest apart
(mapcar
'(lambda(x)
(mapcar
'(lambda(y)
(cond
((null re)(setq re (list x y)))
((> (distance x y) (distance (car re) (cadr re)))
(setq re (list x y)))
)
)
IntPts
)
)
IntPts
)
;; restore the Z
(setq p1 (list (caar re) (cadar re) z)
p2 (list (caadr re) (cadadr re) z))
;;==================================================================
(if (and p1 p2)
(command "_.break" Ent
(trans p1 0 1) ; had to add trans to both points
(trans p2 0 1) ; here is the second point
)
(progn
(alert (strcat "Can not break object."
"\n Error in getting the two points needed."
"\nSelect OK then select the 2 points to break at."
)
)
(setvar "osmode" 32)
(if (and (setq p1 (getpoint "\nFirst break point: "))
(setq p2 (getpoint p1 "....second break point: "))
)
(command ".break" Ent p1 p2)
)
(setvar "osmode" 512)
)
)
(if (setq atts (vlax-invoke tmpObj 'getattributes))
(vla-put-textstring (car atts) (rtos z 2 0))
)
)
(*error* nil)
(princ)
)
-
Thanks CAB. I will take a look at this also.
This is all making my head start that spinning thing. :grazy:
-
This is the way that I would normally approach it, sometimes excluding the last condition, so that the user may exit if he/she doesn't select something:
(while
(progn
(setq ent (car (entsel "\nSelect Entity: ")))
(cond ( (eq 'ENAME (type ent))
(if (not (member (cdr (assoc 0 (entget ent))) '("LINE" "ARC")))
(princ "\n** Invalid Object Selected **")))
(t (princ "\n** Nothing Selected **")))))
-
Guys I have been teleported to a project that needs to get out the door. I will be back. Thanks for the help.
-
I was thinking about something along these lines the other day and this is as far as I got (though I'm sure there are more better ways to go about it... I was sorta thinking out loud):
(setq Item (entsel)
Pick (cadr Item)
VLAItem (vlax-ename->vla-object (car Item))
ItemAngle
(* 180.0
(/
(angle
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property VLAItem 'StartPoint)
)
)
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property VLAItem 'EndPoint)
)
)
)
pi
)
)
)
(princ "\nThe user picked the item at point ")(princ Pick)
(princ (strcat "\nThe angle of the item is " (rtos ItemAngle 2 2)))
(princ)
I'm purty darned positive that there's a better way to do it but I got about this far before I got pulled off and put on something else
-
How about with vlax-curve?
;; GetAngle CAB 01.22.2010
(defun c:GetAngle(/ ent pt ang)
(vl-load-com)
;; CAB test to see if vlax-curve can be used on an object
(defun curveOK (ent) ; returns nil if not allowed
(not (vl-catch-all-error-p
(vl-catch-all-apply 'vlax-curve-getendparam (list ent))
)
)
)
;; Loop until something is picked
(while (or (and (not (setq ent (entsel "\nSelect an object:")))
(princ "\nMissed, Try Again."))
(and (not (curveOK (car ent)))
(princ "\nNo Angle, Try Again.")))
)
(setq pt (vlax-curve-getclosestpointto (car ent) (cadr ent))
ent (car ent))
(setq ang (angle '(0 0) (vlax-curve-getFirstDeriv ent (vlax-curve-getParamAtPoint ent pt))))
(print ang)
(princ)
)