I would like to ask a question about automatizing polyline drawing. Here I have a FUNC and I want to add more specific commands. What I mean: I want the polyline to be assigned to a chosen layer automatically and i also want to set the line type to my custom line type. Thanks for the answers.
Here is my code:
You can get the newly created polyline with the entlast function and change its properties with _chprop command.
(defun c:nyomvodal (/ pt lst)
;; create a new layer
(command "_layer" "_new" "nyomvodal" "_color" 3 "nyomvodal" "")
;; get points form user
(while (setq pt (getpoint "\nPick point: "))
(setq lst (cons pt lst))
)
(if (< 2 (length lst))
(progn
;; create the polyline
(command "_pline")
(foreach p (reverse lst)
(command "_non" p)
)
(command "")
(command "_chprop" (entlast) "" "_layer" "nyomvodal" "_ltype" "axes" "")
)
)
(princ)
)
But, typically, we save current values of the OSMODE, CLAYER and CELTYPE system variables, set new values, draw the polyline, and restore the previous values.
(defun c:nyomvodal (/ osmode clayer celtype)
;; save the current osmode, clayer and celtype
(setq osmode (getvar "osmode"))
(setq clayer (getvar "clayer"))
(setq celtype (getvar "celtype"))
;; create a new layer and make it current
(command "_layer" "_make" "nyomvodal" "_color" 3 "nyomvodal" "")
;; set the current osmode and line type
(setvar "osmode" 0)
(setvar "celtype" "AXES")
;; use vla-catch-all-apply to avoid exiting code if user cancels
(vl-catch-all-apply
'(lambda (/ pt lst)
;; get points form user
(while (setq pt (getpoint "\nPick point: "))
(setq lst (cons pt lst))
)
(if (< 2 (length lst))
(progn
;; create the polyline
(command "_pline")
(foreach p (reverse lst)
(command p)
)
(command "")
)
)
)
)
;; restore the previous system variables values
(setvar "osmode" osmode)
(setvar "clayer" clayer)
(setvar "celtype" celtype)
(princ)
)
Related
I have to write the function that determines the number and values of block attributes in AutoLisp.
I have function which count the atributes:
(defun c:Test (/ s ss)
(if (and (princ "\n Select FIRST Attributed Block :")
(setq s (ssget "_+.:S:E" '((0 . "INSERT") (66 . 1))))
(princ "\n Select the SECOND Attributed Block :")
(setq ss (ssget "_+.:S:E" '((0 . "INSERT") (66 . 1))))
)
(mapcar
'length
(mapcar
'(lambda (a)
(mapcar
'(lambda (x) (vla-get-textstring x))
(vlax-invoke (vlax-ename->vla-object a) 'getattributes)
)
)
(list (ssname s 0) (ssname ss 0))
)
)
)
)**
A function that returns the values of attributes:
(defun c:Test (/ ss n e x)
(while (progn (princ "\n Select single attributed block :")
(setq ss (ssget "_+.:S" '((0 . "INSERT") (66 . 1))))
)
(setq n (entnext (ssname ss 0)))
(while (not (eq (cdr (assoc 0 (setq e (entget n)))) "SEQEND" ))
(if (eq (cdr (assoc 0 e)) "ATTRIB")
(print (cdr (assoc 1 e)))
)
(setq n (entnext n))
)
)
(princ)
)
Could you help me to combine this to functions into one?
Here is a lisp program that will loop over all blocks from a user selection set and:
1.) print block name
2.) print the association list of AttributeTag.AttributeValue
3.) print the list of AttributeTags
4.) print the list of AttributeValues
5.) print the number of AttributeValues
I also attached what the command line output should look like.
Lisp command line output
;;www.cadwiki.net
(defun c:test (/ SSINPUT)
(setq ssInput (ssget (list '(0 . "insert"))))
(PRINT-BLOCK-ATTRIBUTE-INFO ssInput)
(princ)
)
(defun PRINT-BLOCK-ATTRIBUTE-INFO (ssInput / ATTRIBUTETAGS ATTRIBUTETAGSTOVALUES ATTRIBUTEVALUES BLOCKENTITY BLOCKVLAOBJECT I NUMBEROFBLOCKATTRIBUTES
)
(setq i 0)
(if (= ssInput nil)
(progn
(princ "ssInput was nothing, exiting.")
(exit)
)
)
(princ (strcat "\nItems in selection set: " (itoa (sslength ssInput))))
(while (< i (sslength ssInput))
(setq blockEntity (ssname ssInput i))
(setq blockVlaObject (vlax-ename->vla-object blockEntity))
(setq attributeTagsToValues (GET-BLOCK-ATTRIBUTE-NAME-TO-VALUE-ASSOC blockEntity))
(princ (strcat "\nBlock name: " (vla-get-name blockVlaObject)))
(princ "\nBlock attributes tag to values association list: ")
(princ attributeTagsToValues)
(setq attributeTags (GET-NTHS-FROM-LISTS 0 attributeTagsToValues nil))
(princ "\nBlock attribute tags list: ")
(princ attributeTags)
(setq attributeValues (GET-LAST-ITEM-FROM-EACH-LIST attributeTagsToValues))
(princ "\nBlock attributes values list: ")
(princ attributeValues)
(princ "\nNumber of block attributes: ")
(setq numberOfBlockAttributes (itoa (length attributeValues)))
(princ numberOfBlockAttributes)
(setq i (+ i 1))
)
)
(defun GET-NTHS-FROM-LISTS (N LSTs removeDuplicates / CT LST2 LST IT)
(setq LST2 nil)
(foreach LST LSTs
(setq IT (nth N LST))
(if removeDuplicates
(if (not (member IT LST2))
(setq LST2 (append LST2 (list IT)))
)
(setq LST2 (append LST2 (list IT)))
)
)
LST2
)
(defun GET-LAST-ITEM-FROM-EACH-LIST (LSTs / CDRs FAIL LST)
(setq CDRs nil
FAIL nil
)
(if (not (= (type LSTs) 'LIST))
(setq FAIL "not a list")
)
(if (not FAIL)
(foreach LST LSTs
(setq FAIL (cond
((not (= (type LST) 'LIST)) "non-list member")
((not (cdr LST)) "no CDR")
(T nil)
)
)
(if (not FAIL)
(setq CDRs (append CDRs (list (cdr LST))))
)
)
)
CDRs
)
(defun GET-BLOCK-ATTRIBUTE-NAME-TO-VALUE-ASSOC (entity / COUNTER COUNTER2 COUNTERMAX COUNTERMAX2 DXFCODE0 DXFCODE2 DXFCODE66 DXFCODE8 DXFCODECODE-1 ENTITIESTORETURN ENTITYDXFCODES *ERROR* RETURNLIST
SUPPLIEDTRUENAME TRUENAME ATTRIBUTETAG ATTRIBUTEVALUE DXFCODE-1 ENTITYNAMEFORDRILLING SUBLIST TAGSANDVALUES THECALLINGFUNCTIONSNAME
)
(setq counter 0) ;initialize counter to 0 for while loop
(if ;if
(/= entity nil) ;entity is not nil
(progn ;progn wrap
(setq entityDxfCodes (entget entity)) ;set the varaible entityDxfCodes to the list of entities from the en varaible
;; you can use the method here to find any value from a dxfCodecode
(setq dxfCode-1 (cdr (assoc -1 entityDxfCodes))) ;set dxfCode-1 to the second element of the item that has -1 as it's first element, this is the entity name
(setq dxfCode0 (cdr (assoc 0 entityDxfCodes))) ;set dxfCode0 to the element of the item that has 0 as it's first element, this is the entity type
(setq dxfCode2 (cdr (assoc 2 entityDxfCodes))) ;set dxfCode8 to the second element of the item that has 8 as it's first element, this is the name, or block name
(setq dxfCode8 (cdr (assoc 8 entityDxfCodes))) ;set dxfCode8 to the second element of the item that has 8 as it's first element, this is the layer
(setq dxfCode66 (cdr (assoc 66 entityDxfCodes))) ;set dxfCode66 to the second element of the item that has 66 as it's first element, this is the attribute flag
(setq entityNameForDrilling entity)
(if ;if start
(= dxfCode66 1) ;entity attribute flag is 1
(progn ;progn wrap
(while (/= dxfCode0 "SEQEND") ;while loop to drill to each sub entity in a block
(setq attributeTag (cdr (assoc 2 entityDxfCodes))) ;set attributeTag to the second element of the second Dxf code (assoc 2) of the entityDxfCodes variable
(setq attributeValue (cdr (assoc 1 entityDxfCodes))) ;set attributeValue to the second element of the first Dxf code (assoc 1) of the entityDxfCodes variable
(if
(/= attributeValue nil)
(progn
(setq sublist (cons attributeTag attributeValue))
(setq tagsAndValues (cons sublist TagsAndValues))
)
)
(setq entityNameForDrilling (entnext entityNameForDrilling))
(setq entityDxfCodes (entget entityNameForDrilling))
(setq dxfCode0 (cdr (assoc 0 entityDxfCodes)))
)
) ;progn wrap end
) ;if end
) ;progn wrap end
) ;if end
(setq returnList tagsAndValues)
)
I have this AutoLisp code and I want to ask 2 questins about it:
1. how can I make the polyline visible during drawing it(or while selecting the points)?
2. how can I change the color of the polyline but not the layer?
Many many thanks if i get an answer.
(defun c:nyomvodal (/ osmode clayer celtype)
;; save the current osmode, clayer and celtype
(setq osmode (getvar "osmode"))
(setq clayer (getvar "clayer"))
(setq celtype (getvar "celtype"))
;; create a new layer and make it current
(command "_layer" "_make" "nyomvodal" "_color" 3 "nyomvodal" "")
;; set the current osmode and line type
(setvar "osmode" 0)
(setvar "celtype" "16-os cso")
;; use vla-catch-all-apply to avoid exiting code if user cancels
(vl-catch-all-apply
'(lambda (/ pt lst)
;; get points form user
(while (setq pt (getpoint "\nPick point: "))
(setq lst (cons pt lst))
)
(if (< 2 (length lst))
(progn
;; create the polyline
(command "_pline")
(foreach p (reverse lst)
(command p)
)
(command "")
)
)
)
)
;; restore the previous system variables values
(setvar "osmode" osmode)
(setvar "clayer" clayer)
(setvar "celtype" celtype)
(princ)
)
The easiest would be just run command PLINE and wait until user will end.
Color You can change by system variable CECOLOR.
To restore defaults by system variables You can use error catching (in case when user click Esc ), when user ends with [enter] [space] You will restore defaults by call (*error*) function
(defun c:nyomvodal (/ osmode clayer celtype
*error* ) (defun *error* ( msg / )
(if (not (null msg ) ) (progn (princ "\nname:*error*: " ) (princ msg ) (princ "\n") ) )
(setvar "osmode" osmode)
(setvar "clayer" clayer)
(setvar "celtype" celtype)
(setvar 'CECOLOR cecolor)
)
;; save the current osmode, clayer and celtype
(setq osmode (getvar "osmode"))
(setq clayer (getvar "clayer"))
(setq celtype (getvar "celtype"))
(setq cecolor (getvar "CECOLOR"))
;; create a new layer and make it current
(command "_layer" "_make" "nyomvodal" "_color" 3 "nyomvodal" "")
;; set the current osmode and line type
(setvar "osmode" 0)
(setvar "CECOLOR" "1")
;(setvar "celtype" "16-os cso")
(command "_pline" pause)
(*error* nil) ; to restore default color, layer ...
(princ)
)
My intent is to create some lines having two texts each with short info (made as a group), and letting the reactor assigned to the line making sure that:
When copied, the handles of each entity will get updated with the info of the others and
In case I stretch the line using the end grip, the line reactor will update the length of the line as stored xdata and updating the text value that corresponds to the length.
So far and with the valuable help of this forum I was able to make it with the copy part of the story. When I try to incorporate the 'modified' option in the reactor, it does not work. Below is the code I use.
The first function assigns the reactor to the line during its creation through an other function, not shown here. The rest are callbacks and so on. Any suggestions appreciated.
In continuation to this question:
How to update xdata information of an entity when it is copied
(defun assign_LLreactor (LL_ename LL_Length LL_Size / LL_ename LL_hLength LL_hSize)
(if (= 'vlr-object-reactor (type lineReactor))
(vlr-owner-add lineReactor (vlax-ename->vla-object LL_ename))
(vlr-set-notification
(setq lineReactor
(vlr-object-reactor (list (vlax-ename->vla-object LL_ename)) "Line Reactor"
'(
(:vlr-modified . LL_callback_mod)
(:vlr-copied . LL_callback)
)
)
)
'active-document-only
)
)
(makeagroup (ssadd (handent LL_Length) (ssadd (handent LL_Size) (ssadd LL_ename (ssadd)))))
)
(defun LL_callback (notifierobj reactorobj paramls)
(if (/= 0 (car paramls))
(progn
(setq LL_owner (append LL_owner (list (car paramls))))
(vlr-command-reactor "LL_copied_re"
'(
(:vlr-commandended . LL_copyended)
(:vlr-commandcancelled . LL_copycancelled)
(:vlr-commandfailed . LL_copycancelled)
)
)
)
)
)
(defun LL_callback_mod (owner reactorobj paramls)
(setq LL_owner (append LL_owner (list owner)))
(vlr-command-reactor "LL_modified_re"
'(
(:vlr-commandended . LL_modifiedended)
(:vlr-commandcancelled . LL_modifiedcancelled)
(:vlr-commandfailed . LL_modifiedcancelled)
)
)
)
(defun LL_copyended ( reactor params / enametxt txt1 txt2 hSize hLength groupedentities txthandles grtxtdata)
(vlr-remove reactor)
(if
(and
(setq LL_ent (car LL_owner))
(setq LL_enx (entget LL_ent '("LL_U")))
(= (cdr (assoc 0 LL_enx)) "LINE")
(setq LL_3data (assoc -3 LL_enx))
)
(progn
(foreach n (setq groupedentities (_groupedenames LL_ent))
(if (= (cdr (assoc 0 (setq grtxtdata (entget n '("LL_U"))))) "TEXT")
(progn
(setq txthandles (append txthandles (list (cdr (assoc 5 grtxtdata)))))
(entmod (subst (list -3 (list "LL_U" (cons 1005 (cdr (assoc 5 LL_enx))))) (assoc -3 grtxtdata) grtxtdata))
)
)
)
(setq txthandles (vl-sort txthandles (function (lambda (a b) (< a b)))))
(entmod (subst (list -3 (list "LL_U" (cons 1005 (cadr txthandles)) (cons 1005 (car txthandles)))) (assoc -3 LL_enx) LL_enx))
)
)
(if (and LL_enx (= 'vlr-object-reactor (type lineReactor)))
(vlr-owner-add lineReactor (vlax-ename->vla-object LL_ent))
)
(setq LL_owner (cdr LL_owner))
(princ)
)
(defun LL_modifiedended ( reactor params / LL_ent LL_enx llpt10 llpt11 LL_3data LL_3data_n)
(if
(and
(setq LL_ent (car LL_owner))
(setq LL_enx (entget LL_ent '("Pdata")))
(= (cdr (assoc 0 LL_enx)) "LINE")
(setq LL_3data (assoc -3 LL_enx))
)
(progn
(if (= 'vlr-object-reactor (type lineReactor))
(vlr-remove lineReactor)
)
(setq llpt10 (cdr (assoc 10 LL_enx)))
(setq llpt11 (cdr (assoc 11 LL_enx)))
(setq LL_3data_n (list -3 (subst (cons 1000 (rtos (distance llpt10 llpt11) 2 3)) (nth 2 (cadr LL_3data)) (cadr LL_3data))))
(ht_ss (ssadd (cdr (assoc -1 (entmod (subst LL_3data_n (assoc -3 LL_enx) LL_enx)))) (ssadd)))
(if (= 'vlr-object-reactor (type lineReactor))
(vlr-add lineReactor)
)
)
)
(princ)
)
(defun LL_copycancelled ( reactor params )
(vlr-remove reactor)
(setq LL_owner nil)
(princ)
)
(defun LL_modifiedcancelled ( reactor params )
(vlr-remove reactor)
(setq LL_owner nil)
(princ)
)
I expect the object reactor works well for both 'modified' and 'copied' action for lines being either stretched or copied with updated xdata and texts.
So I managed to solve the issue by utilizing a separate list for the owners of the specific reactor type (e.g. 'copied' or 'modified'). So 'LL_owner' list became two, 'LL_copy_owner' and 'LL_mod_owner'. Now it works fine (until further notice :).
I am currently attempting to run a polyline between two blocks (first_block, second_block) that runs along another polyline, at the end of the action an insert function is called that populates an annotation block (cable_name_tag) with the details of the start and end block.
This polyline will transect other blocks and often needs to run in paralell with an underlying polyline (cable_ducting) so the user will need to option to select an appropriate part of the polyline to drop the annotation, as space is sometimes limited.
I have noted that if I comment out the second_block and provide a harcoded value the ssget function works without issue, so I am reasonably sure the issue is with either the syntax or the handling of the first_block and second_block in that code.
(defun c:cable ()
(vl-load-com)
(setvar "clayer" "cable layer")
(setvar "celtype" "bylayer")
(setvar "osmode" 515)
(command "_.pline"
(getpoint))
(while (> (getvar ' cmdactive) 0)
(command pause)
(princ "\npress enter to finish:"))
(setq elst
(entsel "\nselect cable segment: "))
(setq ename
(car elst))
(setq pt
(cadr elst))
(setq annopt pt)
(setq pt
(vlax-curve-getclosestpointto ename pt))
(setq param
(vlax-curve-getparamatpoint ename pt))
(setq preparam
(fix param))
(setq postparam
(1+ preparam))
(list (setq pt1
(vlax-curve-getpointatparam ename preparam))
(setq pt2
(vlax-curve-getpointatparam ename postparam)))
(setq cable
(entlast))
(setq cable_start
(vlax-curve-getstartparam cable))
(setq cable_start_point
(vlax-curve-getstartpoint cable))
(setq cable_end_point
(vlax-curve-getendpoint cable))
(setq cable_end
(angtos (angle '(0 0)
(vlax-curve-getfirstderiv cable 0.0))))
(setq first_block
(ssget "_c" cable_start_point cable_end_point
(list (cons 0 "insert")
(cons 2 "first_block"))))
(setq second_block
(ssget "_c" cable_start_point cable_end_point
(list (cons 0 "insert")
(cons 2 "second_block"))))
(setq end_cable
(ssname second_block 0))
(setq start_cable
(ssname first_block 0))
(setq $end_cable
(vla-get-textstring
(cadr (vlax-safearray->list
(variant-value
(vla-getattributes
(vlax-ename->vla-object end_cable)))))))
(setq $start_cable
(vla-get-textstring
(cadr (vlax-safearray->list
(variant-value
(vla-getattributes
(vlax-ename->vla-object start_cable)))))))
(setq cable_name
(vlax-curve-getendparam cable))
(command ; insert cable param
"-insert"
"cable_name_tag"
annopt
"1"
"1"
cable_angle
cable_name
$start_cable
$end_cable
"144"
cable_length))
I am stuck in a corner on this one, and would appreciate any help, advice or pointers anyone can offer.
Thank you all for your time.
Why not just use (entlast) to get the entity that was just created?
Does someone know how to setup ELIM in emacs?
There is no information about adding accounts etc.
when I run
/add-account
here comes a message
setq: Symbol's function definition is
void: garak-read-protocol
Thank you
This was fixed in commit d3c2f467ebf606fbe6406b2aac783aa68aa91019, which may not have made it into a release yet. You can try checking out from the git repo, or just monkeypatch in this definition:
(defun garak-read-protocol (proc)
(let ((available (mapcar 'car (elim-protocol-alist proc))))
(completing-read "protocol: " available nil t) ))
Privet, Dmitry!
(Ununtu 9.04, GNU Emacs 23.2.1 (i686-pc-linux-gnu, GTK+ Version 2.16.1) of 2010-06-21 on jonesbook)
Ya ustanovil ego tak:
1) u menia uge bil ustanovlen libpurple + pidgin (ver. 2.5.5, some old)
2) git clone elim source from github into dir ~/.emacs.d/elim and make it. OK. "elim-client" is here
3) Add link in .emacs to dir ~/.emacs.d/elim/elisp, e.g.
(add-to-list 'load-path "~/.emacs.d/elim/elisp")
(load-library "garak")
4) Optional. (emacs must compiled with --dbus). Install todochiku.el and put
(require 'todochiku)
Then, M-x garak
command
/add-account
work without such message: "Symbol definition is void: garak-read-protocol"
See garak.el
(add-account . garak-account-update )
...
(add-account . garak-cmd-add-account )
(defun garak-cmd-add-account (args)
(let (items user proto pass options elim errval)
(setq items (split-string args)
user (car items)
proto (cadr items)
items (cddr items))
(setq elim garak-elim-process)
(when (= (length proto) 0) (setq proto (garak-read-protocol elim)))
(when (= (length user ) 0) (setq user (garak-read-username elim proto)))
(when (and (car items) (not (string-match "=" (car items))))
(setq pass (car items) items (cdr items)))
(when (= (length pass ) 0) (setq pass (garak-read-password elim proto)))
;; options not supported yet:
;;(mapcar
;; (lambda (O) (setq options (nconc options (split-string "=" O)))) items)
;; (message "(elim-add-account PROC %S %S %S %S)" user proto pass nil)
(elim-add-account elim user proto pass options)
(format "/add-account %s" args) ))
(defun garak-account-update (proc name id status args)
"This function handles updating the garak ui when the state of one of your
accounts changes. Typically this is as a result of elim-account-status-changed
elim-connection-state or elim-connection-progress, but any call can be handled as long as an \"account-uid\" entry is present in the ARGS alist."
(let (buffer auid where-widget point end icon-name
icon conn kids node tag proto iname alt atag aname)
(setq buffer (elim-fetch-process-data proc :blist-buffer)
auid (elim-avalue "account-uid" args)
status nil)
;; update any account conversation buffers with _our_ new status
(garak-update-account-conversations proc auid)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; proceed to updating the blist ui buffer
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq where-widget (garak-ui-find-node auid :account))
;; set the conn or status data (whichever is appropriate)
(cond ((eq name 'elim-account-status-changed) (setq status args))
((eq name 'elim-connection-state ) (setq conn args))
((eq name 'elim-connection-progress ) (setq conn args)))
;; fetch any data we did not receive:
(when (not conn ) (setq conn (elim-account-connection proc auid)))
(when (not status) (setq status (elim-account-status proc auid)))
;; pick the most suitable status icon
(if (eq name 'elim-exit)
(setq icon-name ":offline")
(setq icon-name (garak-account-list-choose-icon conn status)))
;;(message "CHOSE ICON: %S" icon-name)
;; widget not found or removing an account => refresh the parent node.
;; otherwise => update node icon
(if (or (eq 'remove-account name) (not where-widget))
;; refreshing parent node:
(when (setq where-widget (garak-ui-find-node :accounts :garak-type)
point (car where-widget))
(setq node (widget-at point)
kids (garak-tree-widget-apply node :expander))
(garak-tree-widget-set node :args kids)
(when (garak-tree-widget-get node :open)
(widget-apply node :action)
(widget-apply node :action)))
;; updating node icon:
(setq point (car where-widget)
end (next-single-char-property-change point 'display)
tag (elim-avalue icon-name garak-icon-tags)
adata (elim-account-data proc auid)
proto (elim-avalue :proto adata)
aname (elim-avalue :name adata)
iname (format ":%s" proto)
atag (or (elim-avalue iname garak-icon-tags) " ?? ")
alt (format "[%-4s]%s%s" atag tag aname)
icon (tree-widget-find-image icon-name))
(let ((inhibit-read-only t) old)
(setq widget (widget-at point)
old (widget-get widget :tag))
(if (eq (cdr where-widget) 'menu-choice)
(widget-put widget :tag alt)
(widget-put widget :tag tag))
(if (and icon (tree-widget-use-image-p))
(put-text-property point end 'display icon) ;; widgets w images
(when tag
(setq end (+ (length old) point))
(save-excursion
(goto-char point)
(setq old (make-string (length old) ?.))
(when (search-forward-regexp old end t)
(if (eq (cdr where-widget) 'menu-choice)
(replace-match alt nil t)
(replace-match tag nil t))) )) )) )) )))
In these functions there are many calls (setq ...) and i don't know - where to search problem.
Your should give more information about error. Commands stack, for example.