Welcome,
Guest
. Please
login
or
register
.
1 Hour
1 Day
1 Week
1 Month
Forever
Login with username, password and session length
News:
Home
Help
Login
Register
TheSwamp
»
Code Red
»
AutoLISP (Vanilla / Visual)
»
Topic:
Help with slope lisp
« previous
next »
Print
Pages: [
1
] |
Go Down
Author
Topic: Help with slope lisp (Read 1534 times)
0 Members and 1 Guest are viewing this topic.
pedroantonio
Guest
Help with slope lisp
«
on:
August 07, 2017, 04:51:50 AM »
Hi .I am using a slope lisp ,but i want to do same changes
This lisp give you two options
1) to select 2 points and then pick a point to insert the slope text
2)select a line and then pic a point to insert the slope text
The changes i want to do is
1) Automatically insert the slope text in the midle of the line (over the line)
2) Correct the angle of the text. I want to align the text with the line
Code - Auto/Visual Lisp:
[Select]
(
defun
c:TanLineanot
(
/
doc spc
*error*
TH:UnDo
TH:StartUnDo p1 p2 p3 scl ht
tan2 TL
-
Line TH:UnDo
)
;;; Authour : Hasan Asos -> Modified by Tharwat
(
vl-load-com
)
(
COMMAND
"_layer"
"_m"
"_slope"
"_c"
"140"
""
""
)
(
command
"-style"
"_TanLine"
"wgsimpl.shx"
"_annotative"
"_yes"
"_no"
1.75
1.0
0.0
"_no"
"_no"
""
""
)
(
and
(
setq
doc
(
cond
(
doc
)
(
(
vla-get-ActiveDocument
(
vlax-get-Acad-Object
)
)
)
)
)
(
setq
spc
(
if
(
zerop
(
vla-get-activespace
doc
)
)
(
if
(
=
(
vla-get-mspace
doc
)
:vlax-true
)
(
vla-get-modelspace
doc
)
(
vla-get-paperspace
doc
)
)
(
vla-get-modelspace
doc
)
)
)
)
(
defun
*error*
(
msg
)
(
and
TH:UnDo
(
vla-EndUndoMark
doc
)
)
(
or
(
wcmatch
(
strcase
msg
)
"*BREAK,*CANCEL*,*EXIT*"
)
(
princ
(
strcat
"
\n
** Error: "
msg
" **"
)
)
)
(
princ
)
)
(
setq
TH:StartUnDo
(
vla-StartUndoMark
doc
)
)
(
initget
"Line Points"
)
(
if
(
eq
(
setq
TL
-
sel
(
getkword
(
strcat
"
\n
Specify line or point [Line/Points]: "
"< Line >"
)
)
)
"Points"
)
(
progn
(
setq
p1
(
getpoint
"
\n
Specify 1 point : "
)
)
(
setq
p2
(
getpoint
p1
"
\n
Specify 2 point : "
)
)
(
setq
p3
(
getpoint
"
\n
Specify the insert point : "
)
)
(
setq
tan2
(
/
(
-
(
cadr
p2
)
(
cadr
p1
)
)
(
-
(
car
p2
)
(
car
p1
)
)
)
)
(
entmake
(
list
(
cons
0
"LINE"
)
(
cons
10
(
trans
p1
1
0
)
)
(
cons
11
(
trans
p2
1
0
)
)
)
)
(
vla-AddText
spc
(
strcat
(
rtos
(
abs
(
*
tan2
100
)
)
2
2
)
"%"
)
(
vlax-3d-point
(
trans
p3
1
0
)
)
(
/
(
getvar
'TEXTSIZE
)
(
getvar
'cannoscalevalue
)
)
)
)
(
progn
(
prompt
"
\n
Select line: "
)
(
setq
TL
-
Line
(
ssget
'
(
(
0
.
"LINE"
)
)
)
)
(
setq
e
(
ssname
TL
-
Line
0
)
)
(
setq
p1
(
cdr
(
assoc
10
(
entget
e
)
)
)
)
(
setq
p2
(
cdr
(
assoc
11
(
entget
e
)
)
)
)
(
setq
p3
(
getpoint
"
\n
Specify the insert point : "
)
)
(
setq
tan2
(
/
(
-
(
cadr
p2
)
(
cadr
p1
)
)
(
-
(
car
p2
)
(
car
p1
)
)
)
)
(
vla-AddText
spc
(
strcat
(
rtos
(
abs
(
*
tan2
100
)
)
2
2
)
"%"
)
(
vlax-3d-point
(
trans
p3
1
0
)
)
1.75
)
)
)
(
setq
TH:UnDo
(
vla-EndUndoMark
Doc
)
)
(
princ
"
\n
"
)
(
princ
)
)
Thanks
Logged
HasanCAD
Swamp Rat
Posts: 1422
Re: Help with slope lisp
«
Reply #1 on:
August 08, 2017, 07:43:29 AM »
Give this a try
Code - Auto/Visual Lisp:
[Select]
(
defun
c:TanLineanot
(
/
doc spc
*error*
TH:UnDo TH:StartUnDo
p1 p2 p3 scl ht
tan2 TL
-
Line TH:UnDo ang doc
e ff myline objstyle p12dist
p1x p1y p2x p2y r
-
ang
styles th:undo tl
-
sel txt
)
;;; Authour : Hasan Asos -> Modified by Tharwat
;; Readable - Lee Mac
;; Returns an angle corrected for text readability.
(
defun
LM:readable
(
a
)
(
(
lambda
(
a
)
(
if
(
and
(
<
(
*
pi
0.5
)
a
)
(
<=
a
(
*
pi
1.5
)
)
)
(
LM:readable
(
+
a pi
)
)
a
)
)
(
rem
(
+
a pi pi
)
(
+
pi pi
)
)
)
)
(
defun
*error*
(
msg
)
(
and
TH:UnDo
(
vla-EndUndoMark
doc
)
)
(
or
(
wcmatch
(
strcase
msg
)
"*BREAK,*CANCEL*,*EXIT*"
)
(
princ
(
strcat
"
\n
** Error: "
msg
" **"
)
)
)
(
princ
)
)
(
vl-load-com
)
(
foreach
args '
(
(
"_SLOPE"
140
"Continuous"
0.15
t
0
"SLOPE VALUE"
)
)
(
apply
'lyrmk args
)
)
;(command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
(
and
(
setq
doc
(
cond
(
doc
)
(
(
vla-get-ActiveDocument
(
vlax-get-Acad-Object
)
)
)
)
)
(
setq
spc
(
if
(
zerop
(
vla-get-activespace
doc
)
)
(
if
(
=
(
vla-get-mspace
doc
)
:vlax-true
)
(
vla-get-modelspace
doc
)
(
vla-get-paperspace
doc
)
)
(
vla-get-modelspace
doc
)
)
)
)
(
setq
styles
(
vla-get-textstyles
doc
)
)
(
setq
objStyle
(
vla-add
styles
"_TanLine"
)
)
(
setq
ff
"c:
\\
Windows
\\
fonts
\\
swisscbo.ttf"
)
(
vla-put-fontfile
objStyle ff
)
(
vla-put-activetextstyle
doc objStyle
)
(
setq
TH:StartUnDo
(
vla-StartUndoMark
doc
)
)
(
initget
"Line Points"
)
(
if
(
eq
(
setq
TL
-
sel
(
getkword
(
strcat
"
\n
Specify line or point [Line/Points]: "
"< Line >"
)
)
)
"Points"
)
(
progn
(
setq
p1
(
getpoint
"
\n
Specify 1 point : "
)
)
(
setq
p2
(
getpoint
p1
"
\n
Specify 2 point : "
)
)
(
setq
p12dist
(
distance
p1 p2
)
)
(
setq
ang
(
angle
p1 p2
)
)
(
setq
R
-
ang
(
LM:readable ang
)
)
(
setq
p3
(
polar
p1 R
-
ang
(
/
p12dist
2.0
)
)
)
(
setq
tan2
(
/
(
-
(
cadr
p2
)
(
cadr
p1
)
)
(
-
(
car
p2
)
(
car
p1
)
)
)
)
(
setq
myline
(
vla-addline
spc
(
vlax-3d-point
(
trans
p1
1
0
)
)
(
vlax-3d-point
(
trans
p2
1
0
)
)
)
)
(
vla-put-layer
myline
"_SLOPE"
)
(
setq
txt
(
vla-AddText
spc
(
strcat
(
rtos
(
abs
(
*
tan2
100
)
)
2
2
)
"%"
)
(
vlax-3d-point
(
trans
p3
1
0
)
)
(
/
(
getvar
'TEXTSIZE
)
(
getvar
'cannoscalevalue
)
)
)
)
(
vla-put-rotation
txt R
-
ang
)
)
(
progn
(
prompt
"
\n
Select line: "
)
(
setq
TL
-
Line
(
ssget
'
(
(
0
.
"LINE"
)
)
)
)
(
setq
e
(
ssname
TL
-
Line
0
)
)
(
setq
p1
(
cdr
(
assoc
10
(
entget
e
)
)
)
)
(
setq
p2
(
cdr
(
assoc
11
(
entget
e
)
)
)
)
(
setq
p1
(
trans
p1
1
0
)
p2
(
trans
p2
1
0
)
p1X
(
min
(
nth
0
p1
)
(
nth
0
p2
)
)
p1Y
(
min
(
nth
1
p1
)
(
nth
1
p2
)
)
p2X
(
max
(
nth
0
p1
)
(
nth
0
p2
)
)
p2Y
(
max
(
nth
1
p1
)
(
nth
1
p2
)
)
)
(
setq
p1
(
list
p1X p1Y
0
)
p2
(
list
p2X p2Y
0
)
)
(
setq
p12dist
(
distance
p1 p2
)
)
(
setq
ang
(
angle
p1 p2
)
)
(
setq
R
-
ang
(
LM:readable ang
)
)
(
setq
p3
(
polar
p1 R
-
ang
(
/
p12dist
2.0
)
)
)
(
setq
tan2
(
/
(
-
(
cadr
p2
)
(
cadr
p1
)
)
(
-
(
car
p2
)
(
car
p1
)
)
)
)
(
setq
txt
(
vla-AddText
spc
(
strcat
(
rtos
(
abs
(
*
tan2
100
)
)
2
2
)
"%"
)
(
vlax-3d-point
(
trans
p3
1
0
)
)
(
/
(
getvar
'TEXTSIZE
)
(
getvar
'cannoscalevalue
)
)
)
)
(
vla-put-rotation
txt R
-
ang
)
(
vla-put-textstyle
txt
"_TanLine"
)
)
)
(
setq
TH:UnDo
(
vla-EndUndoMark
Doc
)
)
(
princ
"
\n
"
)
(
princ
)
)
Logged
Sorry for my English.
Donate to Theswamp
www.sergiwa.com
pedroantonio
Guest
Re: Help with slope lisp
«
Reply #2 on:
August 08, 2017, 09:24:26 AM »
hi HasanCAD.I try your code but gives me this error
Quote
** Error: no function definition: nil **
Logged
HasanCAD
Swamp Rat
Posts: 1422
Re: Help with slope lisp
«
Reply #3 on:
August 08, 2017, 10:32:10 AM »
There was missing subroutine
Try this
Code - Auto/Visual Lisp:
[Select]
(
defun
c:TanLineanot
(
/
doc spc
*error*
TH:UnDo TH:StartUnDo
p1 p2 p3 scl ht
tan2 TL
-
Line TH:UnDo ang doc
e ff myline objstyle p12dist
p1x p1y p2x p2y r
-
ang
styles th:undo tl
-
sel txt
)
;;; Authour : Hasan Asos -> Modified by Tharwat
;; Readable - Lee Mac
;; Returns an angle corrected for text readability.
(
defun
LM:readable
(
a
)
(
(
lambda
(
a
)
(
if
(
and
(
<
(
*
pi
0.5
)
a
)
(
<=
a
(
*
pi
1.5
)
)
)
(
LM:readable
(
+
a pi
)
)
a
)
)
(
rem
(
+
a pi pi
)
(
+
pi pi
)
)
)
)
(
defun
*error*
(
msg
)
(
and
TH:UnDo
(
vla-EndUndoMark
doc
)
)
(
or
(
wcmatch
(
strcase
msg
)
"*BREAK,*CANCEL*,*EXIT*"
)
(
princ
(
strcat
"
\n
** Error: "
msg
" **"
)
)
)
(
princ
)
)
(
defun
lTload
(
lTyp
)
(
vl-load-com
)
(
if
(
not
(
tblsearch
"LTYPE"
lTyp
)
)
(
vla
-
load
(
vla-get-Linetypes
(
vla-get-ActiveDocument
(
vlax-get-acad-object
)
)
)
lTyp
(
if
(
=
(
getvar
"MEASUREMENT"
)
0
)
"acad.lin"
"acadiso.lin"
)
)
)
)
(
defun
lyrmk
(
Nme Col lTyp lWgt Plt trns dsc
/
lay lyrs cmd
)
;lee mac
;http://www.cadtutor.net/forum/showthread.php?36882-Check-create-layer-issue-in-Lisp&p=243520&viewfull=1#post243520
(
vl-load-com
)
(
setq
cmd
(
getvar
'cmdecho
)
)
(
setvar
'cmdecho
0
)
(
if
(
not
(
tblsearch
"LAYER"
Nme
)
)
(
progn
(
setq
lyrs
(
vla-get-layers
(
vla-get-ActiveDocument
(
vlax-get-acad-object
)
)
)
)
(
setq
lay
(
vla-add
lyrs Nme
)
)
;(mdfy)
(
setq
entVL
(
vlax
-
ename
->
vla-object
(
tblobjname
"LAYER"
Nme
)
)
)
(
and
Col
(
vla-put-Color
entVL Col
)
)
(
and
lTyp
(
lTload lTyp
)
(
vla-put-Linetype
entVL lTyp
)
)
; (and lWgt (vla-put-LineWeight entVL (eval (read (strcat "acLnWt" lWgt)))))
(
and
lWgt
(
vl-cmdf
"_.-layer"
"_LWeight"
lWgt Nme
""
)
)
(
and
(
not
Plt
)
(
vla-put-Plottable
entVL
:vlax-false
)
)
(
and
(
setq
LyrDs
(
vlax-put-property
entVL 'Description dsc
)
)
)
(
vl-cmdf
"_.-layer"
"_TR"
trns Nme
""
)
)
(
progn
;(mdfy)
(
setq
entVL
(
vlax
-
ename
->
vla-object
(
tblobjname
"LAYER"
Nme
)
)
)
(
and
Col
(
vla-put-Color
entVL Col
)
)
(
and
lTyp
(
lTload lTyp
)
(
vla-put-Linetype
entVL lTyp
)
)
; (and lWgt (vla-put-LineWeight entVL (eval (read (strcat "acLnWt" lWgt)))))
(
and
lWgt
(
vl-cmdf
"_.-layer"
"_LWeight"
lWgt Nme
""
)
)
(
and
(
not
Plt
)
(
vla-put-Plottable
entVL
:vlax-false
)
)
(
and
(
setq
LyrDs
(
vlax-put-property
entVL 'Description dsc
)
)
)
(
vl-cmdf
"_.-layer"
"_TR"
trns Nme
""
)
)
)
(
setvar
'cmdecho cmd
)
)
(
vl-load-com
)
(
foreach
args '
(
(
"_SLOPE"
140
"Continuous"
0.15
t
0
"SLOPE VALUE"
)
)
(
apply
'lyrmk args
)
)
(
and
(
setq
doc
(
cond
(
doc
)
(
(
vla-get-ActiveDocument
(
vlax-get-Acad-Object
)
)
)
)
)
(
setq
spc
(
if
(
zerop
(
vla-get-activespace
doc
)
)
(
if
(
=
(
vla-get-mspace
doc
)
:vlax-true
)
(
vla-get-modelspace
doc
)
(
vla-get-paperspace
doc
)
)
(
vla-get-modelspace
doc
)
)
)
)
(
setq
styles
(
vla-get-textstyles
doc
)
)
(
setq
objStyle
(
vla-add
styles
"_TanLine"
)
)
(
setq
ff
"c:
\\
Windows
\\
fonts
\\
swisscbo.ttf"
)
(
vla-put-fontfile
objStyle ff
)
(
vla-put-activetextstyle
doc objStyle
)
(
setq
TH:StartUnDo
(
vla-StartUndoMark
doc
)
)
(
initget
"Line Points"
)
(
if
(
eq
(
setq
TL
-
sel
(
getkword
(
strcat
"
\n
Specify line or point [Line/Points]: "
"< Line >"
)
)
)
"Points"
)
(
progn
(
setq
p1
(
getpoint
"
\n
Specify 1 point : "
)
)
(
setq
p2
(
getpoint
p1
"
\n
Specify 2 point : "
)
)
(
setq
p12dist
(
distance
p1 p2
)
)
(
setq
ang
(
angle
p1 p2
)
)
(
setq
R
-
ang
(
LM:readable ang
)
)
(
setq
p3
(
polar
p1 R
-
ang
(
/
p12dist
2.0
)
)
)
(
setq
tan2
(
/
(
-
(
cadr
p2
)
(
cadr
p1
)
)
(
-
(
car
p2
)
(
car
p1
)
)
)
)
(
setq
myline
(
vla-addline
spc
(
vlax-3d-point
(
trans
p1
1
0
)
)
(
vlax-3d-point
(
trans
p2
1
0
)
)
)
)
(
vla-put-layer
myline
"_SLOPE"
)
(
setq
txt
(
vla-AddText
spc
(
strcat
(
rtos
(
abs
(
*
tan2
100
)
)
2
2
)
"%"
)
(
vlax-3d-point
(
trans
p3
1
0
)
)
(
/
(
getvar
'TEXTSIZE
)
(
getvar
'cannoscalevalue
)
)
)
)
(
vla-put-rotation
txt R
-
ang
)
)
(
progn
(
prompt
"
\n
Select line: "
)
(
setq
TL
-
Line
(
ssget
'
(
(
0
.
"LINE"
)
)
)
)
(
setq
e
(
ssname
TL
-
Line
0
)
)
(
setq
p1
(
cdr
(
assoc
10
(
entget
e
)
)
)
)
(
setq
p2
(
cdr
(
assoc
11
(
entget
e
)
)
)
)
(
setq
p1
(
trans
p1
1
0
)
p2
(
trans
p2
1
0
)
p1X
(
min
(
nth
0
p1
)
(
nth
0
p2
)
)
p1Y
(
min
(
nth
1
p1
)
(
nth
1
p2
)
)
p2X
(
max
(
nth
0
p1
)
(
nth
0
p2
)
)
p2Y
(
max
(
nth
1
p1
)
(
nth
1
p2
)
)
)
(
setq
p1
(
list
p1X p1Y
0
)
p2
(
list
p2X p2Y
0
)
)
(
setq
p12dist
(
distance
p1 p2
)
)
(
setq
ang
(
angle
p1 p2
)
)
(
setq
R
-
ang
(
LM:readable ang
)
)
(
setq
p3
(
polar
p1 R
-
ang
(
/
p12dist
2.0
)
)
)
(
setq
tan2
(
/
(
-
(
cadr
p2
)
(
cadr
p1
)
)
(
-
(
car
p2
)
(
car
p1
)
)
)
)
(
setq
txt
(
vla-AddText
spc
(
strcat
(
rtos
(
abs
(
*
tan2
100
)
)
2
2
)
"%"
)
(
vlax-3d-point
(
trans
p3
1
0
)
)
(
/
(
getvar
'TEXTSIZE
)
(
getvar
'cannoscalevalue
)
)
)
)
(
vla-put-rotation
txt R
-
ang
)
(
vla-put-textstyle
txt
"_TanLine"
)
)
)
(
setq
TH:UnDo
(
vla-EndUndoMark
Doc
)
)
(
princ
"
\n
"
)
(
princ
)
)
Logged
Sorry for my English.
Donate to Theswamp
www.sergiwa.com
Print
Pages: [
1
] |
Go Up
« previous
next »
TheSwamp
»
Code Red
»
AutoLISP (Vanilla / Visual)
»
Topic:
Help with slope lisp