Autolisp Challenge 2

[jayhay35365091]

I have a code that Pbejse wrote a couple weeks ago.
I've tweaked it a little to allow it to run on my wiring diagrams
The code breaks lines automatically if they cross and puts in an 1/8" fillet at each turn.
The code originally inserted a block at each turn and I cant seem to get rid of that without ruining the code.
Is there a way to delete this function?
Also for some reason the code doesn't break the correct line when multiple vertical lines are crossed. I always want it to break the vertical lines no matter the circumstance.


CODE:


(Defun c:wire (/ *error* GenericIistbox _breakpoints _class pt1 pt2 pt3 LWC ws pwd
scl nl cross int lay o2b
bp ang cm ort
)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(setvar 'cmdecho cm)
(setvar 'orthomode ort)
)

(defun LWPoly (p1 p2 lay wd)
(entmakex (list (cons 0 "LWPolyline")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 2)
(cons 8 lay)
(cons 43 wd)
(Cons 10 p1)
(cons 10 p2)
)
)
)
;_ end of defun
(defun GenericIistbox (lst Title / StrDIA intItem)
(setq StrDIA (load_dialog (findfile "GenericIistbox.dcl")))
(if (not (new_dialog "GenericIistbox" StrDIA))
(exit)
) ;_ end of if
(start_list "StrListS")
(mapcar 'add_list Lst)
(end_list)
(set_tile "Base" Title)
(action_tile "StrListS" "(setq el (get_tile $key))")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(EXIT)")
(start_dialog)
(unload_dialog StrDIA)
(nth (atoi el) lst)
) ;_ end of defun
(defun _breakpoints (ent int)
(setq ang (angle (setq 1p (vlax-curve-getstartpoint ent))
(setq 2p (vlax-curve-getEndpoint ent))
) ;_ end of angle
) ;_ end of setq
(list (setq px (polar int ang 0.125))
(polar int (+ ang pi) 0.125)
) ;_ end of list
) ;_ end of defun
(Defun _class (lay)
(vl-some '(lambda (a)
(if (vl-string-search (car a) lay)
a
)
)
'(("WIRE" 0.002 1.0)
("WIRE FIELD" 0.001 1.0)
)
)
)
(setq ort (getvar 'orthomode)
cm (getvar 'cmdecho))
(setvar 'orthomode 0) (setvar 'cmdecho 0)
(if (and
(setq bl (Cdr (assoc 2 (tblsearch "BLOCK" "arr2")))
) ;_ end of setq
(setq LWC (Genericiistbox
'("WIRE" "WIRE FIELD"
)
"WIRE TYPES"
)
) ;_ end of setq
(setq pt1 (getpoint "\nPick the first Point: "))
) ;_ end of and
(progn
(setq ws (_class LWC)) ;_ end of setq
(setq pwd (cadr ws)
scl (caddr ws)
) ;_ end of setq
(while (setq pt2 (getpoint pt1 "\nPick Next point:"))
(setq ang (angle pt1 pt2))
(setq cross (ssget "_F"
(list (polar pt1 (angle pt1 pt2) 0.03) pt2)
'((0 . "LINE,LWPolyline")
(8 . "WIRE,WIRE FIELD")
)
)
) ;_ end of ssget
(setq nl (LWPoly pt1 pt2 LWC pwd))
(entmakex (list (cons 0 "INSERT")
(cons 8 "GRA")
(cons 2 bl)
(cons 50 (setq ang (angle pt1 pt2)))
(cons 41 scl)
(cons 42 scl)
(cons 43 scl)
(cons 10 pt2)
) ;_ end of list
)
(if cross
(repeat (setq i (sslength cross))
(setq layr
(Strcase
(Cdr
(assoc 8 (entget
(setq e (ssname cross (setq i (1- i))))
) ;_ end of entget
) ;_ end of assoc
) ;_ end of Cdr
) ;_ end of Strcase
) ;_ end of setq
(setq exl (_Class layr))
(if (setq int (vlax-invoke
(vlax-ename->vla-object nl)
'Intersectwith
(vlax-ename->vla-object e)
acExtendNone
)
)
(progn

(setq o2b
(cond
((eq (Car ws) (car exl))
(if (or (equal ang (/ pi 2.0))
(equal ang (* pi 1.5)))
nl e))
((> (cadr ws) (cadr exl)) e)
((< (cadr ws) (cadr exl)) nl
)
)
)
(command "_break"
o2b
"_non"
(car (setq bp (_breakpoints o2b int)))
"_non"
(cadr bp)
)
)
)
)
)
(setq pt1 pt2)
)
)
)
(setvar "cmdecho" 1)
(command "-overkill" "all" "" "p" "y" "")
(setvar "qaflags" 5)
(setvar "filletrad" 0.125)
(ssget "X" '((8 . "WIRE*")))
(command "join" "P" "")
(setq
i 0
ss (ssget "x" '((8 . "WIRE*"))
)
)
(progn
(while (< i (sslength ss))
(setq x (ssname ss i))
(command "fillet" "P" x "")
(setq i (+ 1 i))
)
)
(setq pri (ssget "X" '((8 . "WIRE*"))))
(command "explode" pri "")
(setvar "qaflags" 0)
(setvar "cmdecho" 0)
(*error* "")
(princ)
)
(vl-load-com)

[bhull1985403354]

The entmake and the tblsearch are the portions that have to do with blocks as far as I can tell.
Pbe is a good guy, I'm sure he'd help you with the routine especially since he made it.
I'd try a PM if he doesn't reply to this thread

[pbejse]

Also for some reason the code doesn't break the correct line when multiple vertical lines are crossed. I always want it to break the vertical lines no matter the circumstance.


Yes thee is a way jayhay35365091, as before i need you to post a sample drawing for our reference.


Pbe is a good guy, I'm sure he'd help you with the routine especially since he made it.
I'd try a PM if he doesn't reply to this thread

Thank you for the kind words bhull . That is exactly what jayhay35365091 did. :lol:

[pbejse]

Modified the code to work with fillet, all is well as long as the new polylines doesn't cross an existing wire diagram [reason being the entities are polylines with more than one segment] also i noticed the OP set the orthomode to 0, does that mean there would be diagonal lines?

[jayhay35365091]

I've attached a sample of how the wires should look. You'll notice that the only work-around I had for the block was to insert it, then go into the block definition and delete all the contents. I've tried tweaking the code multiple times to remove the block but it always ruined the whole routine. I've also tried tweaking it so it will always break the vertical lines but again could never get it to work correctly. I had meant to change the orthomode back to 1 but I forgot about it. There will be no diagonal lines this time either. These drawing will be drawn with lines and not polylines. You'll notice at the end of the code there is a join function to create the fillet, then it explodes the polylines to create normal lines. If there is a way to just draw "lines" on the "LWpoly" function?

[pbejse]

Ok then, I'll have something for you later today...

Try this


(Defun c:wire (/ *error* _Line GenericIistbox _breakpoints
pt1 pt2 pt3 LWC ws pwd
scl nl cross int lay o2b
bp ang cm ort
)
pBe 02Dec2013 ;;;
;;; pBe ;;;
(defun *error* (msg)
(command "._undo" "_end")
(setvar 'cmdecho cm)
(setvar 'orthomode ort)
(setvar 'filletrad fr)
(setvar 'peditaccept pa)
(setvar 'qaflags qf)
(setvar 'osmode os)
) ;_ end_defun
(defun _Line (p1 p2 lay)
(entmakex (list (cons 0 "LINE")
(cons 8 lay)
(Cons 10 p1)
(cons 11 p2)
)
)
)
;_ end of defun
(defun GenericIistbox (lst Title / StrDIA intItem)
(setq StrDIA (load_dialog (findfile "GenericIistbox.dcl")))
(if (not (new_dialog "GenericIistbox" StrDIA))
(exit)
) ;_ end of if
(start_list "StrListS")
(mapcar 'add_list Lst)
(end_list)
(set_tile "Base" Title)
(action_tile "StrListS" "(setq el (get_tile $key))")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog StrDIA)
(nth (atoi el) lst)
) ;_ end of defun
(defun _breakpoints (ent int / _ang)
(setq _ang (angle (setq 1p (vlax-curve-getstartpoint ent))
(setq 2p (vlax-curve-getEndpoint ent))
) ;_ end of angle
) ;_ end of setq
(list (setq px (polar int _ang 0.125))
(polar int (+ _ang pi) 0.125)
) ;_ end of list
) ;_ end of defun
(setq ort(getvar 'orthomode)
cm (getvar 'cmdecho)
fr (getvar 'filletrad )
pa (getvar 'Peditaccept)
qf (getvar 'qaflags)
os (getvar 'osmode))

(setvar 'orthomode 1)
(setvar 'cmdecho 0)
(setvar 'filletrad 0.125)
(setvar 'peditaccept 1)
(setvar 'qaflags 1)
(setvar 'osmode 0)
(command "._undo" "_begin")
(if (and
(setq LWC (Genericiistbox
'("WIRE" "WIRE FIELD"
)
"WIRE TYPES"
)
) ;_ end of setq
(setq fss (ssadd) pt1 (getpoint "\nPick the first Point: "))
) ;_ end of and
(progn
(while (setq pt2 (getpoint pt1 "\nPick Next point:"))
(setq ang (angle pt1 pt2))
(setq cross (ssget "_F"
(list (polar pt1 (angle pt1 pt2) 0.03) pt2)
'((0 . "LINE")
(8 . "WIRE,WIRE FIELD")
)
)
) ;_ end of ssget
(setq nl (_Line pt1 pt2 LWC))
(ssadd nl fss)
(if cross
(repeat (setq i (sslength cross))
(setq e (ssname cross (setq i (1- i))))
(if (setq int (vlax-invoke
(vlax-ename->vla-object nl)
'Intersectwith
(vlax-ename->vla-object e)
acExtendNone
)
)
(progn
(setq o2b
(if (or (equal ang (/ pi 2.0))
(equal ang (* pi 1.5)))
nl e)
)
(command "_break" o2b "_non"
(car (setq bp (_breakpoints o2b int)))
"_non" (cadr bp)
)
(ssadd (entlast) fss)
)
)
)
)

(setq pt1 pt2)
)
(setq el (entlast) fss2 (ssadd))
(command "_pedit" "_m" fss "" "_j" 0.0 "")
(while (setq el (entnext el))
(setq fss2 (ssadd el fss2)))
(repeat (sslength fss2)
(setq e (ssname fss2 0))
(if (and (entget e)
(> (cdr (assoc 90 (entget e))) 2)
)
(progn
(command "_.fillet" "_P" e)
(command "_.explode" e "")
)
)
(ssdel e fss2)
)
)
)
(*error* "")
(princ)
)
(vl-load-com)

[jayhay35365091]

You have exceeded expectations once again Pbe. I had to throw in and extra explode command at the end, but after that FLAWLESS.
Ill be adding extra "wire types" as I go, which brings me to another tricky one.
Just something I've been thinking about for down the road but I want to somewhat automate my wire color tagging. Do you think there is a way to be able to click a line and the routine would get the line color and from that have some sort of database of colors. For example, if I click on a red wire I would want the routine to put text above the line saying "RD" for red. "BE" for blue, "GN" for green and so on. Just something that I've been thinking about and would want your opinion on.

[pbejse]

You have exceeded expectations once again Pbe. I had to throw in and extra explode command at the end, but after that FLAWLESS.

Glad I could help. :)



.....Do you think there is a way to be able to click a line and the routine would get the line color and from that have some sort of database of colors. For example, if I click on a red wire I would want the routine to put text above the line saying "RD" for red. "BE" for blue, "GN" for green and so on. .....


Sure, it sounds easy enough. Tell you what, start working on it then i'll give my input til you are satisfied with the result.

Cheers :beer:

[jayhay35365091]

I'm already shooting myself in the foot on this one. I'm initially just trying to pull the line color and put it into text but I keep getting an error. I don't have much knowledge in vla.


(Defun c:wrcl ()
(setq ent (entsel))
(setq cl (vla-get-color ent))
(setq pt1 (getpoint))
(command "text" "m" pt1 "0" cl)
(princ)
)
(vl-load-com)

[pbejse]

I'm already shooting myself in the foot on this one. I'm initially just trying to pull the line color and put it into text but I keep getting an error. I don't have much knowledge in vla.




(Defun c:wrcl ()
(setq ent (entsel)) ; <-- would suggest using ssget with entity type and layer filter

(setq cl (vla-get-color ent)) ; <--- error would occur because you are passing an ename type
; object instead of vla-oject required for vla-get-color function
; besides, the correct syntax should be (car ent) <-- the ename

(setq pt1 (getpoint)) ; <--- can be supressed if use you coordinates of selected line [angles/mid point of line]

(command "text" "m" pt1 "0" cl) ; <-- watch out for "text" command as number of prompt is dependent on current textstyle

(princ)
)
(vl-load-com)

Here's a modified code [patterned from your posted code]


(Defun c:wrcl (/ _ dxf inbex lines textheight ent p1 p2 ang)
(vl-load-com)
(defun _dxf (e dx)
(cdr (assoc dx (entget e)))
)
(if
(setq lines (ssget "_:S:E" '((0 . "LINE") (8 . "WIRE*"))))
(progn
(if (zerop
(cdr (assoc 40 (tblsearch "STYLE" (getvar 'textstyle))))
)
(setq textheight (getdist "\nEnter Text Height: "))
)
(setq ent (ssname lines 0))
(setq p1 (_dxf ent 10))
(setq p2 (_dxf ent 11))
(setq ipt
(polar p1 (setq ang (angle p1 p2)) (* (distance p1 p2) 0.5))
)
(setq ang (cvunit ang "radian" "degree"))
(command "_.text" "BC" "_non" ipt)
(if textheight
(command textheight ang)
(command ang)
)
(command "TEXT from database")
)
)
(princ)
)

I already have a code similar to your request, but as i see it, its more about you learning how to code jayhay. :)

HTH

[jayhay35365091]

I've pointed out the parts of the code that make sense to me. My questions are how would I implement the vla-get-color function to find the color of the line? Also how would the "database" be inserted into the code? You're right, it is about learning to code. I'm still fairly new to coding and want to learn as much as I can.




(Defun c:wrcl (/ _ dxf inbex lines textheight ent p1 p2 ang)
(vl-load-com)
(defun _dxf (e dx)
(cdr (assoc dx (entget e)))
)
(if
(setq lines (ssget "_:S:E" '((0 . "LINE") (8 . "WIRE*")))); <----selects line on any "wire" layer
(progn
(if (zerop
(cdr (assoc 40 (tblsearch "STYLE" (getvar 'textstyle)))); <-----if text style is set to "0" height ask for one
)
(setq textheight (getdist "\nEnter Text Height: "));
)
(setq ent (ssname lines 0))
(setq p1 (_dxf ent 10)); <-----sets pt1 as the first end point of the line
(setq p2 (_dxf ent 11)); <-----sets pt2 as the second end point of the line
(setq ipt
(polar p1 (setq ang (angle p1 p2)) (* (distance p1 p2) 0.5)); <-----sets the angle based on pt1 & pt2, sets base point as midpoint of line
)
(setq ang (cvunit ang "radian" "degree"))
(command "_.text" "BC" "_non" ipt); <------text, bottom center, based on "ipt"
(if textheight
(command textheight ang)
(command ang)
)
(command "TEXT from database")
)
)
(princ)
)

[pbejse]

You're right, it is about learning to code. I'm still fairly new to coding and want to learn as much as I can.



Good, I knew you'll see it my way.


(Defun c:wrcl (/ _ dxf inbex lines textheight ent p1 p2 ang)
(vl-load-com)
(defun _dxf (e dx)
(cdr (assoc dx (entget e)))
)
(if
(setq lines (ssget "_:S:E" '((0 . "LINE") (8 . "WIRE*"))))
(progn
(if (zerop
(cdr (assoc 40 (tblsearch "STYLE" (getvar 'textstyle))))
)
(setq textheight (getdist "\nEnter Text Height: "))
)
(setq ent (ssname lines 0))
(setq p1 (_dxf ent 10))
(setq p2 (_dxf ent 11))

;;; My questions are how would I implement the vla-get-color ;;;
;;; function to find the color of the line? ;;;

;;; You can use DXF 62 in place if the vl equivalent ;;;

(setq lyr (_dxf ent 8))
(setq color (if (setq c (_dxf ent 62)) ;<-- this will be true if entity color is not bylayer
c ;<-- If true assign value of c variable to color
(cdr (assoc 62 ;<-- otherwise use layer color
(tblsearch "LAYER" lyr
)
)
))
)

;;; Also how would the "database" be inserted into the code? ;;;

;;; Here you include the table for all possible color and its ;;;
;;; equivalent code string ;;;

(setq stringcode
(if (setq code (assoc color
'((1 . "RD") ;<-- This is the database
(2 . "YE") ;
(3 . "GN") ;
(4 . "CN") ;
(5 . "BE") ;
(6 . "MG") ;
(7 . "WT") ;
)
)
) (cdr code) ;<-- use the corresponding value for string
"N/A")) ;<-- if not found on the database use "N/A"

(setq ipt
(polar p1 (setq ang (angle p1 p2)) (* (distance p1 p2) 0.5))
)
(setq ang (cvunit ang "radian" "degree"))
(command "_.text" "BC" "_non" ipt)
(if textheight
(command textheight ang)
(command ang)
)
(command stringcode) ;< pass the value of stringcode variable here
)
)
(princ)
)

HTH

[jayhay35365091]

That is some cool stuff Pbe. My only question would be how to make the text not be dependent on which direction the "wire" is drawn? When I draw a wire from left to right it works perfect. When i draw from right to left the text comes out upsidedown. I have similar problems when drawing up to down vs down to up.

[pbejse]

That is some cool stuff Pbe. My only question would be how to make the text not be dependent on which direction the "wire" is drawn? When I draw a wire from left to right it works perfect. When i draw from right to left the text comes out upsidedown. I have similar problems when drawing up to down vs down to up.

Somehow i knew you are going to ask that :p
Look at this demo


(defun c:demo (/ p1 p2 ang)
(while (and
(setq p1 (getpoint "\nPick First point"))
(setq p2 (getpoint p1 "\nPick next point"))
(setq ang (angle p1 p2))
)
(print
(angtos (if (and
(> ang (/ pi 2))
(<= ang (* pi 1.5))
)
(+ ang pi)
ang
)
)
)
)
(princ)
)

HTH

[jayhay35365091]

This ended up being the final code


(Defun c:wrc (/ _ dxf inbex lines textheight ent p1 p2 ang)
(vl-load-com)
(defun _dxf (e dx)
(cdr (assoc dx (entget e)))
)
(if
(setq lines (ssget "_:S:E" '((0 . "LINE") (8 . "WIRE*"))))
(progn
(if (zerop
(cdr (assoc 40 (tblsearch "STYLE" (getvar 'textstyle))))
)
(setq textheight (getdist "\nEnter Text Height: "))
)
(setq ent (ssname lines 0))

;;; My questions are how would I implement the vla-get-color ;;;
;;; function to find the color of the line? ;;;

;;; You can use DXF 62 in place if the vl equivalent ;;;

(setq lyr (_dxf ent 8))
(setq color (if (setq c (_dxf ent 62)) ;<-- this will be true if entity color is not bylayer
c ;<-- If true assign value of c variable to color
(cdr (assoc 62 ;<-- otherwise use layer color
(tblsearch "LAYER" lyr
)
)
))
)

;;; Also how would the "database" be inserted into the code? ;;;

;;; Here you include the table for all possible color and its ;;;
;;; equivalent code string ;;;

(setq stringcode
(if (setq code (assoc color
'((5 . "BE") ;<-- This is the database
(252 . "BK") ;
(16 . "BK/RD") ;
(36 . "BN") ;
(3 . "GN") ;
(60 . "GN/YW") ;
(8 . "GY") ;
(30 . "OE") ;
(210 . "PK") ;
(1 . "RD") ;
(190 . "VT") ;
(7 . "WE") ;
(151 . "WE/BE") ;
(253 . "WE/BK") ;
(35 . "WE/BN") ;
(91 . "WE/GN") ;
(254 . "WE/GY") ;
(31 . "WE/OE") ;
(211 . "WE/PK") ;
(11 . "WE/RD") ;
(191 . "WE/VT") ;
(51 . "WE/YW") ;
(52 . "YW") ;
)
)
) (cdr code) ;<-- use the corresponding value for string
"N/A")) ;<-- if not found on the database use "N/A"


(setq p1 (_dxf ent 10))
(setq p2 (_dxf ent 11))
(setq ang (angle p1 p2))

(setq ang2 (print
(angtos (if (and
(> ang (/ pi 2))
(<= ang (* pi 1.5))
)
(+ ang pi)
ang
)
)))
(setq p3 (getpoint))
(setq ang (cvunit ang "radian" "degree"))
(command "_.text" "bc" "_non" p3)
(if textheight
(command textheight ang2)
(command ang2)
)
(command stringcode) ;< pass the value of stringcode variable here
)
)
(princ)
)

Thanks again Pbe, this routine is another life saver or typing saver.