Jump to content

Lisp to increment letters with prefix or suffix

asdfgh

By asdfgh
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

  • Replies 54
  • Created
  • Last Reply

Top Posters In This Topic

  • aridzv

    15

  • Steven P

    13

  • Tharwat

    11

  • BIGAL

    7

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Tharwat
Tharwat

Yup you are right, here is the revised one to increment down on Y direction. (defun c:Test (/ int sel ent get lst fun str tmp ltr pre key opr) ;;--------------------------------------------------

BIGAL
BIGAL

There is nice functions by Gile that increments, say the BA BB BC etc. so could read an existing string and get a start number. Then say a pick pick pick sequence.   ; Alpha2Number - Converts

Tharwat
Tharwat

Give this a try and let me know if it is the one you are after. (defun c:Test (/ int sel ent get lst fun str tmp ltr pre key ) ;;----------------------------------------------------;; ;; Author

Posted Images

aridzv Community Regular

aridzv

Posted
Posted (edited)
4 hours ago, Steven P said:

My Mistake, Edited above

 

Hi @Steven P.

I did that correction (actually before posting my previos post...) 

(LM:vl-setattributevalue ( blk "ORDER" (nth 2 blk) ))

Still getting the error message...

Edited by aridzv
maahee Explorer

maahee

Posted
Posted (edited)

Thank sir

Edited by maahee
Steven P Grand Master

Steven P

Posted
Posted
14 hours ago, aridzv said:

Hi @Steven P.

I did that correction (actually before posting my previos post...)


(LM:vl-setattributevalue ( blk "ORDER" (nth 2 blk) ))

Still getting the error message...

 

 

Spent 10 minutes seeing what I missed - should be this line instead:

 

(LM:vl-setattributevalue bobj "Order" (rtos (nth 2 blk)) )

 

  • Thanks 1
aridzv Community Regular

aridzv

Posted
Posted

@Steven P

one more question - 

the lisp set put's the numbers from top right to lower left.

is it possible to change it so it will go from lower left to top right?

 

thanks,

aridzv.

Steven P Grand Master

Steven P

Posted
Posted

Without testing I reckon there will be something in his code like vl-sort, look to see if there is an operator like < or > and swap it to the other one. That might work

aridzv Community Regular

aridzv

Posted
Posted (edited)

well, I celebrated too soon...

the Lisp does not take *U blocks (dynamic blocks) by their block name But by the *U name ,

and it causes lisp to see identical blocks as different and give them a different number - I've attached an example drawing.

dose anyone have an idea how to solve this?

 

thaks,

aridzv.

 

Drawing2.dwg

Edited by aridzv
wrong sample file
BIGAL Grand Master

BIGAL

Posted
Posted (edited)

Ok very easy a block can have 2 names, the BLOCK Name and an Effective Name, so for the *u123 block you can get its effective name.

  

(setq obj (vlax-ename->vla-object (car  (entsel "Pick block"))))
(vla-get-name obj)
"*U21"  so its a dynamic block
(vla-get-effectivename obj)

Ok now the problem you have possibly copied from another dwg so understand in the other dwg it should reveal true block name.

 

This is another dwg I looked at can see result. 

(setq obj (vlax-ename->vla-object (car  (entsel "Pick block"))))
Pick block#<VLA-OBJECT IAcadBlockReference 0000000061FF4420>
(vla-get-name obj)
"*U308"
(vla-get-effectivename obj)
"TAWINDOW"

Ok so you get the blocks then test does it have a effective name if so get that name.

 

Will look for an example. 

(vlax-property-available-p obj "Effectivename")

Returns True if exists.

Edited by BIGAL
aridzv Community Regular

aridzv

Posted
Posted

@BIGAL

I tried to use your example this way:

1. convert the entity to VLAX object.

2. get the effctive name.

 

here is the relevant code from the point of selecting the blocks and up to the point of assigning the name to a varaible: 

(setq ss (ssget '((0 . "INSERT"))))

(if (= ss nil)
(alert "No blocks selected ")
(progn
(setq lst '())
(repeat (setq x (sslength ss))
 (setq ent (entget (ssname ss (setq x (1- x)))))
 (setq bname (cdr (assoc 2 ent)))
 (setq obj2 (vlax-ename->vla-object ent))
 (setq bname2 (vlax-property-available-p ent "Effectivename"))
 (princ bname2)

 

this is the error I'm getting: 

; ----- Error around expression -----
; (AL-ENAME2OBJ ENAME)
; in file : 
; C:\Users\USER\AppData\Roaming\Bricsys\BricsCAD\Lsp\Blocks_Numbering_By_Type4.lsp

 

and here is full code - see how many attempts I did: 

(defun c:Blocks_Numbering_By_Type4 ( / ss ent bname lst lst2 x y val val2 pointmin pointmax bobj mp bname2 obj2)
(vl-load-com)
(setvar 'textstyle "standard")
(prompt "select blocks")
(setq ss (ssget '((0 . "INSERT"))))

(if (= ss nil)
(alert "No blocks selected ")
(progn
(setq lst '())
(repeat (setq x (sslength ss))
 (setq ent (entget (ssname ss (setq x (1- x)))))
 (setq bname (cdr (assoc 2 ent)))
 (setq obj2 (vlax-ename->vla-object ent))
 (setq bname2 (vlax-property-available-p ent "Effectivename"))
 (princ bname2)
 ;;(setq bname2 (vla-get-effectivename (vlax-ename->vla-object (cdr (assoc - 1 ent)))))
 
 ;;(setq obj2 (vlax-ename->vla-object ent))
;; (setq bname2 (vla-get-effectivename obj2))
 ;;(setq bname2 (getpropertyvalue obj2 "EffectiveName~Native"))

;;  (princ bname)
 (setq ent (cdr (assoc -1 ent)))
 (setq lst (cons (list bname ent) lst))
)
(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))
                                             
(setq lst2 '())
(setq x 0 y 1)
(repeat (length lst)
(if (= (car (nth x lst)) (car (nth (1+ x) lst)))
  (setq lst2 (cons (list (car (nth x lst)) (cadr (nth x lst)) y) lst2))
  (progn 
  (setq lst2 (cons (list (car (nth x lst))(cadr (nth x lst)) y) lst2))
  (setq y (1+ y))
  )
)
(setq x (1+ x))
)
  
(foreach blk lst2
  (setq ent (cadr blk))
  (princ ent)
  (setq bobj (vlax-ename->vla-object ent))
  (princ bobj)
  ;;(vla-GetBoundingBox bobj 'minpoint 'maxpoint)
  ;;(setq pointmin (vlax-safearray->list minpoint))
  ;;(setq pointmax (vlax-safearray->list maxpoint))
  ;;(setq mp (mapcar '* (mapcar '+ pointmin pointmax) '(0.5 0.5)))
  ;;(command "text" mp 1.0 0.0 (nth 2 blk))
  (LM:vl-setattributevalue bobj "ORDER" (rtos (nth 2 blk)) )
)
                                             
)
)
(princ)


)

(defun LM:vl-setattributevalue ( blk tag val )
    (setq tag (strcase tag))
    (vl-some
       '(lambda ( att )
            (if (= tag (strcase (vla-get-tagstring att)))
                (progn (vla-put-textstring att val) val)
            )
        )
        (vlax-invoke blk 'getattributes)
    )
)

 

regards,

aridzv.

aridzv Community Regular

aridzv

Posted
Posted (edited)

@BIGAL

see the attched final lisp file.

note this: 

 (setq obj2 (vlax-ename->vla-object ent_n))
 (setq bname (getpropertyvalue ent_n "EffectiveName~Native"))

 

bricscad.

Blocks_Numbering_By_Type6.lsp

Edited by aridzv
aridzv Community Regular

aridzv

Posted
Posted (edited)

Hi.

after solving the effective name ordeal the lisp works brilliantly.

there is one issue that I'm trying to solve:

the lisp sort the blocks list by their alphabetical order (block-A will get the first number and block-b will get the next).

I'm trying to get the numbering according to the blocks order in the drawing - first selected first number.

I need the numbering from left to right or right to left - just that the nubering will be according to the blocks location in the drawing and not their alphabetical order.

 

I tried to first remove duplicates from the list and then number the blocks according to their location in the list but failed.

 

here is the code I started to write with the duplicates removle function: 

(defun c:Blocks_Numbering_By_Type1 ( / ss ent ent_n bname lst lst2 x y val val2 pointmin pointmax bobj mp layname layobj)
(vl-load-com)

  (foreach layname '("BC_SUBTRACT" "Handle" "Wasers_Nuts_Gaskets"); add as many as you like
    (if (setq layobj (tblobjname "layer" layname)); it exists
      (vla-put-LayerOn (vlax-ename->vla-object layobj) 0); then -- turn it Off
    ); if
  ); foreach
  (princ)

;;(setvar 'textstyle "standard")
(prompt "select blocks")
(setq ss (ssget '((0 . "INSERT"))))

(if (= ss nil)
(alert "No blocks selected ")
(progn
(setq lst '())
      (repeat (setq x (sslength ss))
        (setq ent_n (ssname ss (setq x (1- x)))
              ent (entget ent_n)
        );;close setq    

       (setq bname (getpropertyvalue ent_n "EffectiveName~Native"))
       (setq ent (cdr (assoc -1 ent)))
       (setq lst (cons (list bname ent) lst))
      );;close repeat

;;(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))
(setq lst (remove_dups lst))
(princ lst)
                                            
(setq lst2 '())
(setq x 0 y 1)

(repeat (length lst)
   (if (= (car (nth x lst)) (car (nth (1+ x) lst)))
     (setq lst2 (cons (list (car (nth x lst)) (cadr (nth x lst)) y) lst2))
      (progn 
       (setq lst2 (cons (list (car (nth x lst))(cadr (nth x lst)) y) lst2))
       (setq y (1+ y))
      );;close progn
   );;close if
  (setq x (1+ x))
);;close repeat

(foreach blk lst2
  (setq ent (cadr blk))
  (setq bobj (vlax-ename->vla-object ent))
  ;;(vla-GetBoundingBox bobj 'minpoint 'maxpoint)
  ;;(setq pointmin (vlax-safearray->list minpoint))
  ;;(setq pointmax (vlax-safearray->list maxpoint))
  ;;(setq mp (mapcar '* (mapcar '+ pointmin pointmax) '(0.5 0.5)))
  ;;(command "text" mp 1.0 0.0 (nth 2 blk))
  (LM:vl-setattributevalue bobj "ORDER" (rtos (nth 2 blk) 2 0) )
);;close foreach
                                             
);;close progn from top
);;close if from top
(princ)

                                                 (foreach layname '("BC_SUBTRACT" "Handle" "Wasers_Nuts_Gaskets"); add as many as you like
    (if (setq layobj (tblobjname "layer" layname)); it exists    
      (vla-put-LayerOn (vlax-ename->vla-object layobj) 1); then -- turn it back on
    ); if
  ); foreach
  (princ)

)



(defun remove_dups  (lst / out)
  (while lst
    (setq out (cons (car lst) out))
    (setq lst (vl-remove (car lst) (cdr lst))))
  (reverse out))


(defun remove_doubles  (lst)
  (if lst
    (cons (car lst) (remove_doubles (vl-remove (car lst) lst)))))

(defun LM:vl-setattributevalue ( blk tag val )
    (setq tag (strcase tag))
    (vl-some
       '(lambda ( att )
            (if (= tag (strcase (vla-get-tagstring att)))
                (progn (vla-put-textstring att val) val)
            )
        )
        (vlax-invoke blk 'getattributes)
    )
)

 

I also attched a sample drawing here.

thanks,

aridzv.

Drawing2.dwg

Edited by aridzv
maahee Explorer

maahee

Posted
Posted (edited)

 Tan, Acos, asin function  

(setq vertpt-1 (polar vertpt-f  (+ (* pi 1.5) (angle p1 p2)) 0.04))

(setq fwpt-3 (polar fwpt  (+ (* pi 0.5) (angle p1 p2)) 0.04))

(setq vertpt-2 (polar vertpt-1 (+ (angle vertpt-f fwpt) (Acos (/ 0.04 (distance vertpt-f fwpt))) ( * pi 1.5)) 0.04))

(setq fwpt-3 (polar fwpt-3 (+ (angle vertpt-f fwpt) (Acos (/ 0.04 (distance vertpt-f fwpt))) ( * pi 0.5)) 0.04))

(command "line" vertpt-1 fwpt-4 fwpt-3 vertpt-2 "c")

Showing error: no function definition: Acos

 

I calculate angle between hypotenuse and adjacent side 90 degree triangle 

Edited by maahee
BIGAL Grand Master

BIGAL

Posted
Posted

To maahee you need to start a new post I think, not add to this one. Admin will fix. Also more information "Not working" is not enough.

maahee Explorer

maahee

Posted
Posted (edited)
8 hours ago, BIGAL said:

To maahee you need to start a new post I think, not add to this one. Admin will fix. Also more information "Not working" is not enough.

Ok sir thanks for guiding me

Edited by maahee

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...