Need help getting LiSP from R12 working in Acad2007

April 1, 2009

Where I work, we have LISP file that was used in Autocad R12..

It's used to name a closed polyline, and insert text within that polyline.

I'm trying to use it in AutoCAD 2007, but can't seem to make it work. I keep getting "lentityp nil" error towards the end...

Here's the code:

;===========================================================
;AL_NAMER.LSP
;Program BY: Chris Thompson
;
;Description: This program oversees the placement of a text
;        description on a 2-D Polyline pattern. 
;
;          The Program prompts for:
;            Entity        - The entity the text
;                       will attach to.
;            Piece Code     - a 3 ltr code
;            Module Code     - a 2 ltr code
;            Direction Code     - a 1 ltr code
;            Material Code     - a 1 ltr code
;            Description     - a ?? ltr code        
;
;
;============================================================


(defun C:NAMER()

(princ "\n Select an Entity to Name:")
(setq ASet (entsel))
(princ "\n")
(setq ESList (entget(car ASet)))

(setq TYPE1 (cdr(assoc 0 ESList)))
(if (= TYPE1 "LWPOLYLINE") 
 (progn

; Get The Area

  (Command "_.Area" "_E" ASet)
  (setq Bset (getvar "Area"))
  (setq Ftg (/ Bset 144))
  (setq Ftg (+ Ftg 0.005))
  (setq AreaText1 (rtos Ftg 2))

; Find The Decimal Place
  (setq AreaText2 (substr AreaText1 2 1))
  (if (= AreaText2 ".")
     (setq AreaText2 (substr AreaText1 1 4))
     (setq AreaText2 (substr AreaText1 1 5))
  )
  (setq AreaText2 (strcat AreaText2 " "))


;Get the Text For all the Text Sections
;Also Makes sure that input is valid

  (PieceCode)
  (ModuleCode)
  (DirectionCode)
  (MaterialCode)
  (DescriptionCode)

;Put the Text Line Together
  (setq TextLine (strcat PieceText  ModuleText))
  (setq TextLine (strcat TextLine  DirectionText))
  (setq TextLine (strcat TextLine  MaterialText))
  (setq TextLine (strcat TextLine  AreaText2))
  (setq TextLine (strcat TextLine  DescriptionText))
  (setq TextLine (strcase TextLine))

;Find the Text Start Point
;Then Place the Text
  (TextStart)
  (PlaceText)

 )
 (princ "\n Selection Not A PolyLine")
)

(princ)
)
;============================================================


(defun TextStart()
; Get Point Between First and Last  Points Picked ?

(setq BSet (entget(entnext(cdr(assoc -1 ESList)))))
(setq FirstPoint (cdr (assoc 10 BSet)))

(while (/=(cdr(assoc 0 Bset)) "SEQEND")
 (setq PrevPoint LastPoint)
 (setq LastPoint (cdr (assoc 10 BSet)))
 (setq Bset(entget(entnext(cdr(assoc -1 BSet)))))
)

(setq X1 (car FirstPoint))
(setq Y1 (cadr FirstPoint))

(if (AND (= (car FirstPoint) (car LastPoint))(= (cadr FirstPoint) (cadr LastPoint)))
 (progn
  (setq X2 (car PrevPoint))
  (setq Y2 (cadr PrevPoint))

 )
 (progn
  (setq X2 (car LastPoint))
  (setq Y2 (cadr LastPoint))
 )
)


(setq X (- X2 X1))
(setq Y (- Y2 Y1))

(setq X (/ X 2))
(setq Y (/ Y 2))

(setq X (+ X X1))
(setq Y (+ Y Y1))

(setq Position (list X Y 0))

)
;============================================================

(defun PlaceText()
; Place The Text
 
(setq CrntLyr (getvar "clayer"))

(princ "\n")
(princ CrntLyr)

(command "layer" "s" "NAME" "")
(command "Text" Position ".5" "0" TextLine)
(command "layer" "s" CrntLyr "")


)

;============================================================

(defun PieceCode()
; Get The Piece Text
  
  (setq PieceText "")
  (while (= (substr PieceText 3 1) "")
   (setq PieceText (getstring "\n Input Piece Code:"))
  )
  (setq PieceText (substr PieceText 1 3))
  (setq PieceText (strcat PieceText " "))
)

;============================================================

(defun ModuleCode()
; Get The Module Text
  (setq TheEnd 0)
  (setq ModuleText "")
  (while (= TheEnd 0)
   (setq ModuleText (getstring "\n Input Module Code:"))
   (setq ModuleText (strcase ModuleText))
   (if (= ModuleText "BK") (setq TheEnd 1)) 
   (if (= ModuleText "DK") (setq TheEnd 1)) 
   (if (= ModuleText "SC") (setq TheEnd 1)) 
   (if (= ModuleText "BC") (setq TheEnd 1)) 
   (if (= ModuleText "AR") (setq TheEnd 1)) 
   (if (= ModuleText "AC") (setq TheEnd 1)) 
   (if (= TheEnd 0 ) (alert "          NOT A VALID INPUT \nValid Inputs: BK DK SC BC AR AC")) 
  )
  (setq ModuleText (substr ModuleText 1 2))
  (setq ModuleText (strcat ModuleText " "))

)

;============================================================

(defun DirectionCode()
; Get The Direction Text

  (setq TheEnd 0)
  (setq DirectionText "")
  (while (= TheEnd 0)
   (setq DirectionText (getstring "\n Input Direction Code:"))
   (setq DirectionText (strcase DirectionText))
   (if (= DirectionText "R") (setq TheEnd 1)) 
   (if (= DirectionText "L") (setq TheEnd 1)) 
   (if (= DirectionText "S") (setq TheEnd 1)) 
   (if (= TheEnd 0 ) (alert "NOT A VALID INPUT \n  Valid Inputs: R L S")) 
  )
  (setq DirectionText (substr DirectionText 1 1))
  (setq DirectionText (strcat DirectionText " "))

)
;============================================================

(defun MaterialCode()
; Get The Material Text

  (setq TheEnd 0)
  (setq MaterialText "")
  (while (= TheEnd 0)
   (setq MaterialText (getstring "\n Input Material Code:"))
   (setq MaterialText (strcase MaterialText))
   (if (= MaterialText "L") (setq TheEnd 1)) 
   (if (= MaterialText "S") (setq TheEnd 1)) 
   (if (= MaterialText "P") (setq TheEnd 1)) 
   (if (= MaterialText "D") (setq TheEnd 1))
   (if (= MaterialText "Q") (setq TheEnd 1))
   (if (= MaterialText "E") (setq TheEnd 1))  
   (if (= TheEnd 0 ) (alert " NOT A VALID INPUT \nValid Inputs:  L B S P")) 
  )
  (setq MaterialText (substr MaterialText 1 1))
  (setq MaterialText (strcat MaterialText " "))

)
;============================================================

(defun DescriptionCode()
; Get The Description Text

  (setq DescriptionText "")
  (while (= (substr DescriptionText 1 1) "")
   (setq DescriptionText (getstring 1 "\n Input Description:"))
  )
  (setq DescriptionText (substr DescriptionText 1 20))

)

Can anyone help?

April 1, 2009

Just quickly looking at it, I think the creator meant it for use with POLYLINES and not LWPOLYLINES - as it contains "entnext" to get the vertices.

I could probably re-write it for use with LWPOLYLINES, but haven't the time at present

Lee

April 1, 2009

Just quickly looking at it, I think the creator meant it for use with POLYLINES and not LWPOLYLINES - as it contains "entnext" to get the vertices.

I could probably re-write it for use with LWPOLYLINES, but haven't the time at present

Lee

Hmmm.

What would it take to work with LWPOLYLINES?

April 1, 2009

Hmmm.

What would it take to work with LWPOLYLINES?

I think the whole LISP needs a bit of re-writing tbh, there is not much in the way of error trapping - and the LISP seems a bit unstable.

Will see what I can do

April 2, 2009

OK, give this a shot - wasn't sure exactly what you wanted, but if you need anything modified, let me know


;;;    =============  Namer.lsp =============
;;;
;;;  FUNCTION:
;;;  Will label a Curve with Piece Code,
;;;  Module, Direction, Material, and Description
;;;
;;;  PLATFORMS:
;;;  No Restrictions, only tested on ACAD 2004
;;;
;;;  CURVE COMPATABILITY:
;;;  Arcs, Circles, Ellipses, *Polylines,
;;;  Regions & Splines.
;;;
;;;  AUTHOR:
;;;  Copyright (c) 04.2009 Lee McDonnell
;;;   (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION:
;;;  1.0  02.04.09
;;;
;;;    ======================================

(defun c:namer (/ *error* ptxt detxt cEnt cObj Area motxt dtxt mtxt tStr
         tBox tWid tHgt ClsPt btPt tpPt pt1 pt2 pt3 pt4 tAngl tObj)
 (vl-load-com)

 (defun *error* (msg)
   (redraw)
   (if tObj (entdel tObj))
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 (setq vlst '("CLAYER" "OSMODE" "CMDECHO")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(0 0))

 (if (not (tblsearch "LAYER" "NAME"))
   (command "_-layer" "_M" "NAME" "_C" "2" "NAME" ""))

 (or mo:def (setq mo:def "BK"))
 (or d:def (setq d:def "R"))
 (or m:def (setq m:def "L"))
 (setq ptxt "" detxt "")

 (if (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
          '("ARC" "CIRCLE" "ELLIPSE" "*POLYLINE" "REGION" "SPLINE")))
   (progn
     (setq cObj (vlax-ename->vla-object cEnt)
       Area (rtos (vla-get-area cObj) 2 0))
     (while (= ptxt "")
   (setq ptxt (getstring "\nInput Piece Code: ")))
     (setq ptxt (substr ptxt 1 3))
     (while (not (member motxt '("BK" "DK" "SC" "BC" "AR" "AC")))
   (setq motxt (strcase
             (getstring
           (strcat "\nInput Module [bK/DK/SC/BC/AR/AC] <" mo:def ">: "))))
   (or (and (eq motxt "") (setq motxt mo:def)) (setq mo:def motxt)))
     (while (not (member dtxt '("R" "L" "S")))
   (setq dtxt (strcase
            (getstring
              (strcat "\nInput Direction [R/L/S] <" d:def ">: "))))
   (or (and (eq dtxt "") (setq dtxt d:def)) (setq d:def dtxt)))
     (while (not (member mtxt '("L" "S" "P" "D" "Q" "E")))
   (setq mtxt (strcase
            (getstring
              (strcat "\nInput Material [L/S/P/D/Q/E] <" m:def ">: "))))
   (or (and (eq mtxt "") (setq mtxt m:def)) (setq m:def mtxt)))
     (while (= detxt "")
   (setq detxt (getstring t "\nInput Description: ")))
     (setq detxt (substr detxt 1 20)
       tStr (strcat ptxt (chr 45) motxt (chr 45) dtxt (chr 45)
            mtxt (chr 45) Area (chr 45) detxt)
       tBox (textbox (list (cons 1 tStr)))
       tWid (- (caadr tBox) (caar tBox))
       tHgt (- (cadadr tBox) (cadar tBox)))
     (while (= 5 (car (setq grdat (grread t 1))))
   (redraw)
   (if (= 'list (type (setq sPt (cadr grdat))))
     (progn
       (setq ClsPt (vlax-curve-getClosestPointto cObj sPt)
         cAngl (angle ClsPt sPt)
         btPt (polar ClsPt cAngl (/ (getvar "TEXTSIZE") 2.0))
         tpPt (polar ClsPt cAngl (+ (/ (getvar "TEXTSIZE") 2.0) tHgt))
         midPt (polar btPt cAngl (/ (distance btPt tpPt) 2.0))
         pt1 (polar btPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt2 (polar btPt (- cAngl (/ pi 2)) (/ tWid 2.0))
         pt3 (polar tpPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt4 (polar tpPt (- cAngl (/ pi 2)) (/ tWid 2.0)))
       (grvecs (list 51 pt1 pt2 51 pt2 pt4 51 pt1 pt3 51 pt3 pt4)))))
     (setq tAngl (- cAngl (/ pi 2)))
     (if (and (> tAngl 0) (<= tAngl (/ pi 2)))
   nil
   (setq tAngl (+ tAngl pi)))
     (setq tObj (Make_Text midPt tStr tAngl)))
   (princ "\n<!> Object is not a Curve <!>"))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

 (defun Make_Text  (pt val rot)
 (entmake (list '(0 . "TEXT")
        '(8 . "NAME")
        (cons 10 pt)
        (cons 40 (getvar "TEXTSIZE"))
        (cons 1 val)
        (cons 50 rot)
        '(7 . "STANDARD")
        '(71 . 0)
        '(72 . 1)
        '(73 . 2)
        (cons 11 pt))))

 (princ "\n** Namer.lsp Successfully Loaded, Type \"namer\" to invoke **")
 (princ)

April 2, 2009

Thanks for your work man.

I tried it, and it stopped saying the object was not a curve. Here's the copy and paste where it stopped:

** Namer.lsp Successfully Loaded, Type "namer" to invoke **
Command:
Command: pn PEDIT Select polyline or [Multiple]:
Object selected is not a polyline
Do you want to turn it into one? <Y>

Enter an option [Close/Join/Width/Edit vertex/Fit/Spline/Decurve/Ltype 
gen/Undo]: j
Select objects: Specify opposite corner: 24 found

Select objects:

23 segments added to polyline

Enter an option [Open/Join/Width/Edit vertex/Fit/Spline/Decurve/Ltype 
gen/Undo]: x
Command: rr REGEN Regenerating model.

Command: n
Select Curve to Label:
<!> Object is not a Curve <!>

One thing I noticed, is that you set it to check that it's a polyline. All the parts will always be polylines, that we're trying to do. I don't really think you need the check and make polyline thing.

Any ideas why it stopped?

April 2, 2009

My apologies dude - stupid mistake of mine

;;;    =============  Namer.lsp =============
;;;
;;;  FUNCTION:
;;;  Will label a Curve with Piece Code,
;;;  Module, Direction, Material, and Description
;;;
;;;  PLATFORMS:
;;;  No Restrictions, only tested on ACAD 2004
;;;
;;;  CURVE COMPATABILITY:
;;;  Arcs, Circles, Ellipses, *Polylines,
;;;  Regions & Splines.
;;;
;;;  AUTHOR:
;;;  Copyright (c) 04.2009 Lee McDonnell
;;;   (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION:
;;;  1.0  02.04.09
;;;
;;;    ======================================

(defun c:namer (/ *error* ptxt detxt cEnt cObj Area motxt dtxt mtxt tStr
         tBox tWid tHgt ClsPt btPt tpPt pt1 pt2 pt3 pt4 tAngl tObj)
 (vl-load-com)

 (defun *error* (msg)
   (redraw)
   (if tObj (entdel tObj))
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 (setq vlst '("CLAYER" "OSMODE" "CMDECHO")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(0 0))

 (if (not (tblsearch "LAYER" "NAME"))
   (command "_-layer" "_M" "NAME" "_C" "2" "NAME" ""))

 (or mo:def (setq mo:def "BK"))
 (or d:def (setq d:def "R"))
 (or m:def (setq m:def "L"))
 (setq ptxt "" detxt "")

 (if (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
          '("ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE" "POLYLINE" "REGION" "SPLINE")))
   (progn
     (setq cObj (vlax-ename->vla-object cEnt)
       Area (rtos (vla-get-area cObj) 2 0))
     (while (= ptxt "")
   (setq ptxt (getstring "\nInput Piece Code: ")))
     (setq ptxt (substr ptxt 1 3))
     (while (not (member motxt '("BK" "DK" "SC" "BC" "AR" "AC")))
   (setq motxt (strcase
             (getstring
           (strcat "\nInput Module [bK/DK/SC/BC/AR/AC] <" mo:def ">: "))))
   (or (and (eq motxt "") (setq motxt mo:def)) (setq mo:def motxt)))
     (while (not (member dtxt '("R" "L" "S")))
   (setq dtxt (strcase
            (getstring
              (strcat "\nInput Direction [R/L/S] <" d:def ">: "))))
   (or (and (eq dtxt "") (setq dtxt d:def)) (setq d:def dtxt)))
     (while (not (member mtxt '("L" "S" "P" "D" "Q" "E")))
   (setq mtxt (strcase
            (getstring
              (strcat "\nInput Material [L/S/P/D/Q/E] <" m:def ">: "))))
   (or (and (eq mtxt "") (setq mtxt m:def)) (setq m:def mtxt)))
     (while (= detxt "")
   (setq detxt (getstring t "\nInput Description: ")))
     (setq detxt (substr detxt 1 20)
       tStr (strcat ptxt (chr 45) motxt (chr 45) dtxt (chr 45)
            mtxt (chr 45) Area (chr 45) detxt)
       tBox (textbox (list (cons 1 tStr)))
       tWid (- (caadr tBox) (caar tBox))
       tHgt (- (cadadr tBox) (cadar tBox)))
     (while (= 5 (car (setq grdat (grread t 1))))
   (redraw)
   (if (= 'list (type (setq sPt (cadr grdat))))
     (progn
       (setq ClsPt (vlax-curve-getClosestPointto cObj sPt)
         cAngl (angle ClsPt sPt)
         btPt (polar ClsPt cAngl (/ (getvar "TEXTSIZE") 2.0))
         tpPt (polar ClsPt cAngl (+ (/ (getvar "TEXTSIZE") 2.0) tHgt))
         midPt (polar btPt cAngl (/ (distance btPt tpPt) 2.0))
         pt1 (polar btPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt2 (polar btPt (- cAngl (/ pi 2)) (/ tWid 2.0))
         pt3 (polar tpPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt4 (polar tpPt (- cAngl (/ pi 2)) (/ tWid 2.0)))
       (grvecs (list 51 pt1 pt2 51 pt2 pt4 51 pt1 pt3 51 pt3 pt4)))))
     (setq tAngl (- cAngl (/ pi 2)))
     (if (and (> tAngl 0) (<= tAngl (/ pi 2)))
   nil
   (setq tAngl (+ tAngl pi)))
     (setq tObj (Make_Text midPt tStr tAngl)))
   (princ "\n<!> Object is not a Curve <!>"))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

 (defun Make_Text  (pt val rot)
 (entmake (list '(0 . "TEXT")
        '(8 . "NAME")
        (cons 10 pt)
        (cons 40 (getvar "TEXTSIZE"))
        (cons 1 val)
        (cons 50 rot)
        '(7 . "STANDARD")
        '(71 . 0)
        '(72 . 1)
        '(73 . 2)
        (cons 11 pt))))

 (princ "\n** Namer.lsp Successfully Loaded, Type \"namer\" to invoke **")
 (princ)

April 3, 2009

Wow!

That works great. That's awesome.

Only had a question about a few things:

1. Can we put the text together without using any hyphens?

2. Can we make is so that instead of sq inches, it puts sq footage on the text line?

3. Can we make it so that it's just regular text rather than mtext?

Thanks so much for your work! It's really going to help out a lot. I tried to look at the code for what you did to modify it for the things I need, but it's lost on me. LOL. I know very very little about LISP code. In the past, I've been able to get some things to work in newer versions of CAD, but I'm no expert at it.

April 3, 2009

Wow!

That works great. That's awesome.

Thanks

1. Can we put the text together without using any hyphens?

Sorted in new version - spaces are now used.

2. Can we make is so that instead of sq inches, it puts sq footage on the text line?

Sorted, area is adjusted for sqft.

3. Can we make it so that it's just regular text rather than mtext?

The text that is created should be single-line DTEXT, not MTEXT

New Version:

;;;    =============  Namer.lsp =============
;;;
;;;  FUNCTION:
;;;  Will label a Curve with Piece Code,
;;;  Module, Direction, Material, and Description
;;;
;;;  PLATFORMS:
;;;  No Restrictions, only tested on ACAD 2004
;;;
;;;  CURVE COMPATABILITY:
;;;  Arcs, Circles, Ellipses, *Polylines,
;;;  Regions & Splines.
;;;
;;;  AUTHOR:
;;;  Copyright (c) 04.2009 Lee McDonnell
;;;   (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION:
;;;  1.0  02.04.09
;;;  2.0  03.04.09
;;;
;;;    ======================================

(defun c:namer (/ *error* ptxt detxt cEnt cObj Area motxt dtxt mtxt tStr
         tBox tWid tHgt ClsPt btPt tpPt pt1 pt2 pt3 pt4 tAngl tObj)
 (vl-load-com)

 (defun *error* (msg)
   (redraw)
   (if tObj (entdel tObj))
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 (setq vlst '("CLAYER" "OSMODE" "CMDECHO")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(0 0))

 (if (not (tblsearch "LAYER" "NAME"))
   (command "_-layer" "_M" "NAME" "_C" "2" "NAME" ""))

 (or mo:def (setq mo:def "BK"))
 (or d:def (setq d:def "R"))
 (or m:def (setq m:def "L"))
 (setq ptxt "" detxt "")

 (if (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
          '("ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE" "POLYLINE" "REGION" "SPLINE")))
   (progn
     (setq cObj (vlax-ename->vla-object cEnt)
       Area (rtos (/ (vla-get-area cObj) 144.0) 2 0))
     (while (= ptxt "")
   (setq ptxt (getstring "\nInput Piece Code: ")))
     (setq ptxt (substr ptxt 1 3))
     (while (not (member motxt '("BK" "DK" "SC" "BC" "AR" "AC")))
   (setq motxt (strcase
             (getstring
           (strcat "\nInput Module [bK/DK/SC/BC/AR/AC] <" mo:def ">: "))))
   (or (and (eq motxt "") (setq motxt mo:def)) (setq mo:def motxt)))
     (while (not (member dtxt '("R" "L" "S")))
   (setq dtxt (strcase
            (getstring
              (strcat "\nInput Direction [R/L/S] <" d:def ">: "))))
   (or (and (eq dtxt "") (setq dtxt d:def)) (setq d:def dtxt)))
     (while (not (member mtxt '("L" "S" "P" "D" "Q" "E")))
   (setq mtxt (strcase
            (getstring
              (strcat "\nInput Material [L/S/P/D/Q/E] <" m:def ">: "))))
   (or (and (eq mtxt "") (setq mtxt m:def)) (setq m:def mtxt)))
     (while (= detxt "")
   (setq detxt (getstring t "\nInput Description: ")))
     (setq detxt (substr detxt 1 20)
       tStr (strcat ptxt (chr 32) motxt (chr 32) dtxt (chr 32)
            mtxt (chr 32) Area (chr 32) detxt)
       tBox (textbox (list (cons 1 tStr)))
       tWid (- (caadr tBox) (caar tBox))
       tHgt (- (cadadr tBox) (cadar tBox)))
     (prompt "\nPlace Text... ")
     (while (= 5 (car (setq grdat (grread t 1))))
   (redraw)
   (if (= 'list (type (setq sPt (cadr grdat))))
     (progn
       (setq ClsPt (vlax-curve-getClosestPointto cObj sPt)
         cAngl (angle ClsPt sPt)
         btPt (polar ClsPt cAngl (/ (getvar "TEXTSIZE") 2.0))
         tpPt (polar ClsPt cAngl (+ (/ (getvar "TEXTSIZE") 2.0) tHgt))
         midPt (polar btPt cAngl (/ (distance btPt tpPt) 2.0))
         pt1 (polar btPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt2 (polar btPt (- cAngl (/ pi 2)) (/ tWid 2.0))
         pt3 (polar tpPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt4 (polar tpPt (- cAngl (/ pi 2)) (/ tWid 2.0)))
       (grvecs (list 51 pt1 pt2 51 pt2 pt4 51 pt1 pt3 51 pt3 pt4)))))
     (setq tAngl (- cAngl (/ pi 2)))
     (if (and (> tAngl 0) (<= tAngl (/ pi 2)))
   nil
   (setq tAngl (+ tAngl pi)))
     (setq tObj (Make_Text midPt tStr tAngl)))
   (princ "\n<!> Object is not a Curve <!>"))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

 (defun Make_Text  (pt val rot)
 (entmake (list '(0 . "TEXT")
        '(8 . "NAME")
        (cons 10 pt)
        (cons 40 (getvar "TEXTSIZE"))
        (cons 1 val)
        (cons 50 rot)
        '(7 . "STANDARD")
        '(71 . 0)
        '(72 . 1)
        '(73 . 2)
        (cons 11 pt))))

 (princ "\n** Namer.lsp Successfully Loaded, Type \"namer\" to invoke **")
 (princ)

April 3, 2009

Man you're quick!

Everything works great!

I had a brainfart on the mtext thing. It is in fact already what I need!

I hate to impose, but is there any way we can make it so the sq ftg is always two places after the decimal, even if it's a whole number? For example, 1 would be 1.00? Is that hard to do? Or something I could change myself?

April 3, 2009

Holy smokes, Lee.

That's what I would call overhauling and old LISP. Very nice.

Edit: Not to be a spelling Nazi, but it's 'compatIbility", not 'compatAbility'

April 3, 2009

I hate to impose, but is there any way we can make it so the sq ftg is always two places after the decimal, even if it's a whole number? For example, 1 would be 1.00? Is that hard to do? Or something I could change myself?

Not a problem at all - I shall include an *adjustment menu* for your benefit

April 3, 2009

Edit: Not to be a spelling Nazi, but it's 'compatIbility", not 'compatAbility'

Haha, if anything I am much of a spelling Nazi myself - can't believe I didn't look that up before I posted it

April 3, 2009

Ok, Please find adjustment menu at the top

;;;    =============  Namer.lsp =============
;;;
;;;  FUNCTION:
;;;  Will label a Curve with Piece Code,
;;;  Module, Direction, Material, and Description
;;;
;;;  PLATFORMS:
;;;  No Restrictions, only tested on ACAD 2004
;;;
;;;  CURVE COMPATIBILITY:
;;;  Arcs, Circles, Ellipses, *Polylines,
;;;  Regions & Splines.
;;;
;;;  AUTHOR:
;;;  Copyright (c) 04.2009 Lee McDonnell
;;;   (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION:
;;;  1.0  02.04.09
;;;  2.0  03.04.09
;;;  3.0  03.04.09
;;;
;;;    ======================================

(defun c:namer (/ *error* APrec VCol tStyl ptxt detxt
         cEnt cObj Area motxt dtxt mtxt tStr
         tBox tWid tHgt ClsPt btPt tpPt pt1
         pt2 pt3 pt4 tAngl tObj)

 (vl-load-com)


 ;; ===== Adjustments =====

 (setq APrec 2)   ; Area Precision, integer >= 0

 (setq VCol 3)    ; Vector Colour, integer (0-255)

 (setq tStyl "STANDARD")  ; TextStyle, if non-existent, Standard.

 ; ========================

 ; === Error Prevention ===

 (or (and (eq 'INT (type APrec)) (>= APrec 0)) (setq APrec 2))
 (or (and (eq 'INT (type VCol)) (<= 0 VCol 255)) (setq VCol 3))
 (or (tblsearch "STYLE" tStyl) (setq tStyl "STANDARD"))

 (defun *error* (msg)
   (redraw)
   (if tObj (entdel tObj))
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 ; ========================

 (setq vlst '("CLAYER" "OSMODE" "CMDECHO")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(0 0))

 (if (not (tblsearch "LAYER" "NAME"))
   (command "_-layer" "_M" "NAME" "_C" "2" "NAME" ""))

 (or mo:def (setq mo:def "BK"))
 (or d:def (setq d:def "R"))
 (or m:def (setq m:def "L"))
 (setq ptxt "" detxt "")

 (if (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
          '("ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE" "POLYLINE" "REGION" "SPLINE")))
   (progn
     (setq cObj (vlax-ename->vla-object cEnt)
       Area (rtos (/ (vla-get-area cObj) 144.0) 2 APrec))
     (while (= ptxt "")
   (setq ptxt (getstring "\nInput Piece Code: ")))
     (setq ptxt (substr ptxt 1 3))
     (while (not (member motxt '("BK" "DK" "SC" "BC" "AR" "AC")))
   (setq motxt (strcase
             (getstring
           (strcat "\nInput Module [bK/DK/SC/BC/AR/AC] <" mo:def ">: "))))
   (or (and (eq motxt "") (setq motxt mo:def)) (setq mo:def motxt)))
     (while (not (member dtxt '("R" "L" "S")))
   (setq dtxt (strcase
            (getstring
              (strcat "\nInput Direction [R/L/S] <" d:def ">: "))))
   (or (and (eq dtxt "") (setq dtxt d:def)) (setq d:def dtxt)))
     (while (not (member mtxt '("L" "S" "P" "D" "Q" "E")))
   (setq mtxt (strcase
            (getstring
              (strcat "\nInput Material [L/S/P/D/Q/E] <" m:def ">: "))))
   (or (and (eq mtxt "") (setq mtxt m:def)) (setq m:def mtxt)))
     (while (= detxt "")
   (setq detxt (getstring t "\nInput Description: ")))
     (setq detxt (substr detxt 1 20)
       tStr (strcat ptxt (chr 32) motxt (chr 32) dtxt (chr 32)
            mtxt (chr 32) Area (chr 32) detxt)
       tBox (textbox (list (cons 1 tStr)))
       tWid (- (caadr tBox) (caar tBox))
       tHgt (- (cadadr tBox) (cadar tBox)))
     (prompt "\nPlace Text... ")
     (while (= 5 (car (setq grdat (grread t 1))))
   (redraw)
   (if (= 'list (type (setq sPt (cadr grdat))))
     (progn
       (setq ClsPt (vlax-curve-getClosestPointto cObj sPt)
         cAngl (angle ClsPt sPt)
         btPt (polar ClsPt cAngl (/ (getvar "TEXTSIZE") 2.0))
         tpPt (polar ClsPt cAngl (+ (/ (getvar "TEXTSIZE") 2.0) tHgt))
         midPt (polar btPt cAngl (/ (distance btPt tpPt) 2.0))
         pt1 (polar btPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt2 (polar btPt (- cAngl (/ pi 2)) (/ tWid 2.0))
         pt3 (polar tpPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt4 (polar tpPt (- cAngl (/ pi 2)) (/ tWid 2.0)))
       (grvecs (list VCol pt1 pt2 VCol pt2 pt4 VCol pt1 pt3 VCol pt3 pt4)))))
     (setq tAngl (- cAngl (/ pi 2)))
     (if (and (> tAngl 0) (<= tAngl (/ pi 2)))
   nil
   (setq tAngl (+ tAngl pi)))
     (setq tObj (Make_Text midPt tStr tAngl)))
   (princ "\n<!> Object is not a Curve <!>"))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

 (defun Make_Text  (pt val rot)
 (entmake (list '(0 . "TEXT")
        '(8 . "NAME")
        (cons 10 pt)
        (cons 40 (getvar "TEXTSIZE"))
        (cons 1 val)
        (cons 50 rot)
        (cons 7 tStyl)
        '(71 . 0)
        '(72 . 1)
        '(73 . 2)
        (cons 11 pt))))

 (princ "\n** Namer.lsp Successfully Loaded, Type \"namer\" to invoke **")
 (princ)

April 3, 2009

You, sir, are awesome!

Works perfectly, and thanks for the adjustment menu.

Is there anyway to control the text size? What I'm seeing right now through my testing, it's dependent upon where you place the text. I'd prefer it to be a single size. How can I adjust that in the code?

April 3, 2009

You, sir, are awesome!

Works perfectly, and thanks for the adjustment menu.

Thanks I've had fun making this one tbh

Is there anyway to control the text size? What I'm seeing right now through my testing, it's dependent upon where you place the text. I'd prefer it to be a single size. How can I adjust that in the code?

The textsize is retrieved from the "TEXTSIZE" variable, which will be dependent on your text style. But I shall add a manual override for you

April 3, 2009

Try this:

;;;    =============  Namer.lsp =============
;;;
;;;  FUNCTION:
;;;  Will label a Curve with Piece Code,
;;;  Module, Direction, Material, and Description
;;;
;;;  PLATFORMS:
;;;  No Restrictions, only tested on ACAD 2004
;;;
;;;  CURVE COMPATIBILITY:
;;;  Arcs, Circles, Ellipses, *Polylines,
;;;  Regions & Splines.
;;;
;;;  AUTHOR:
;;;  Copyright (c) 04.2009 Lee McDonnell
;;;   (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION:
;;;  1.0  02.04.09
;;;  2.0  03.04.09
;;;  3.0  03.04.09
;;;
;;;    ======================================

(defun c:namer (/ *error* APrec VCol tStyl tSze ptxt
         detxt cEnt cObj Area motxt dtxt mtxt
         tStr tBox tWid tHgt ClsPt btPt tpPt
         pt1 pt2 pt3 pt4 tAngl tObj)

 (vl-load-com)


 ;; ===== Adjustments =====

 (setq APrec 2)   ; Area Precision, integer >= 0

 (setq VCol 3)    ; Vector Colour, integer (0-255)

 (setq tStyl "STANDARD")  ; TextStyle, if non-existent, Standard.

 (setq tSze 2.5)  ; TextSize, real > 0, if nil, will be Textstyle dependent.

 ; ========================

 ; === Error Prevention ===

 (or (and (eq 'INT (type APrec)) (>= APrec 0)) (setq APrec 2))
 (or (and (eq 'INT (type VCol)) (<= 0 VCol 255)) (setq VCol 3))
 (or (tblsearch "STYLE" tStyl) (setq tStyl "STANDARD"))
 (or (and tSze (> tSze 0)) (setq tSze (getvar "TEXTSIZE")))

 (defun *error* (msg)
   (redraw)
   (if tObj (entdel tObj))
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 ; ========================

 (setq vlst '("CLAYER" "OSMODE" "CMDECHO")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(0 0))

 (if (not (tblsearch "LAYER" "NAME"))
   (command "_-layer" "_M" "NAME" "_C" "2" "NAME" ""))

 (or mo:def (setq mo:def "BK"))
 (or d:def (setq d:def "R"))
 (or m:def (setq m:def "L"))
 (setq ptxt "" detxt "")

 (if (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
          '("ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE" "POLYLINE" "REGION" "SPLINE")))
   (progn
     (setq cObj (vlax-ename->vla-object cEnt)
       Area (rtos (/ (vla-get-area cObj) 144.0) 2 APrec))
     (while (= ptxt "")
   (setq ptxt (getstring "\nInput Piece Code: ")))
     (setq ptxt (substr ptxt 1 3))
     (while (not (member motxt '("BK" "DK" "SC" "BC" "AR" "AC")))
   (setq motxt (strcase
             (getstring
           (strcat "\nInput Module [bK/DK/SC/BC/AR/AC] <" mo:def ">: "))))
   (or (and (eq motxt "") (setq motxt mo:def)) (setq mo:def motxt)))
     (while (not (member dtxt '("R" "L" "S")))
   (setq dtxt (strcase
            (getstring
              (strcat "\nInput Direction [R/L/S] <" d:def ">: "))))
   (or (and (eq dtxt "") (setq dtxt d:def)) (setq d:def dtxt)))
     (while (not (member mtxt '("L" "S" "P" "D" "Q" "E")))
   (setq mtxt (strcase
            (getstring
              (strcat "\nInput Material [L/S/P/D/Q/E] <" m:def ">: "))))
   (or (and (eq mtxt "") (setq mtxt m:def)) (setq m:def mtxt)))
     (while (= detxt "")
   (setq detxt (getstring t "\nInput Description: ")))
     (setq detxt (substr detxt 1 20)
       tStr (strcat ptxt (chr 32) motxt (chr 32) dtxt (chr 32)
            mtxt (chr 32) Area (chr 32) detxt)
       tBox (textbox (list (cons 1 tStr)))
       tWid (- (caadr tBox) (caar tBox))
       tHgt (- (cadadr tBox) (cadar tBox)))
     (prompt "\nPlace Text... ")
     (while (= 5 (car (setq grdat (grread t 1))))
   (redraw)
   (if (= 'list (type (setq sPt (cadr grdat))))
     (progn
       (setq ClsPt (vlax-curve-getClosestPointto cObj sPt)
         cAngl (angle ClsPt sPt)
         btPt (polar ClsPt cAngl (/ (getvar "TEXTSIZE") 2.0))
         tpPt (polar ClsPt cAngl (+ (/ (getvar "TEXTSIZE") 2.0) tHgt))
         midPt (polar btPt cAngl (/ (distance btPt tpPt) 2.0))
         pt1 (polar btPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt2 (polar btPt (- cAngl (/ pi 2)) (/ tWid 2.0))
         pt3 (polar tpPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt4 (polar tpPt (- cAngl (/ pi 2)) (/ tWid 2.0)))
       (grvecs (list VCol pt1 pt2 VCol pt2 pt4 VCol pt1 pt3 VCol pt3 pt4)))))
     (setq tAngl (- cAngl (/ pi 2)))
     (if (and (> tAngl 0) (<= tAngl (/ pi 2)))
   nil
   (setq tAngl (+ tAngl pi)))
     (setq tObj (Make_Text midPt tStr tAngl)))
   (princ "\n<!> Object is not a Curve <!>"))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

 (defun Make_Text  (pt val rot)
 (entmake (list '(0 . "TEXT")
        '(8 . "NAME")
        (cons 10 pt)
        (cons 40 tSze)
        (cons 1 val)
        (cons 50 rot)
        (cons 7 tStyl)
        '(71 . 0)
        '(72 . 1)
        '(73 . 2)
        (cons 11 pt))))

 (princ "\n** Namer.lsp Successfully Loaded, Type \"namer\" to invoke **")
 (princ)

April 3, 2009

Perfect Lee!

I really appreciate all your hard work!

This will save us a ton of time, and I definitely couldn't have done it on my own!

April 3, 2009

Actually, this is better (more options )

;;;    =============  Namer.lsp =============
;;;
;;;  FUNCTION:
;;;  Will label a Curve with Piece Code,
;;;  Module, Direction, Material, and Description
;;;
;;;  PLATFORMS:
;;;  No Restrictions, only tested on ACAD 2004
;;;
;;;  CURVE COMPATIBILITY:
;;;  Arcs, Circles, Ellipses, *Polylines,
;;;  Regions & Splines.
;;;
;;;  AUTHOR:
;;;  Copyright (c) 04.2009 Lee McDonnell
;;;   (contact Lee Mac, CADTutor.net)
;;;
;;;  VERSION:
;;;  1.0  02.04.09
;;;  2.0  03.04.09
;;;  3.0  03.04.09
;;;
;;;    ======================================

(defun c:namer (/ *error* APrec VCol tStyl tSze tLay
         tCol ptxt detxt cEnt cObj Area motxt
         dtxt mtxt tStr tBox tWid tHgt ClsPt
         btPt tpPt pt1 pt2 pt3 pt4 tAngl tObj)

 (vl-load-com)


 ;; ===== Adjustments =====

 (setq APrec 2)   ; Area Precision, integer >= 0

 (setq VCol 3)    ; Vector Colour, integer (0-255)

 (setq tStyl "STANDARD")  ; TextStyle, if non-existent, Standard.

 (setq tSze 2.5)  ; TextSize, real > 0, if nil, will be Textstyle dependent.

 (setq tLay "NAME")  ; Layer for Text, layer will be created if non-existent

 (setq tCol 255)  ; Text Colour, (255 = ByLayer)

 ; ========================

 ; === Error Prevention ===

 (or (and (eq 'INT (type APrec)) (>= APrec 0)) (setq APrec 2))
 (or (and (eq 'INT (type VCol)) (<= 0 VCol 255)) (setq VCol 3))
 (or (tblsearch "STYLE" tStyl) (setq tStyl "STANDARD"))
 (or (and tSze (> tSze 0)) (setq tSze (getvar "TEXTSIZE")))
 (or tLay (setq tLay "NAME"))
 (or (and (eq 'INT (type tCol)) (<= 0 tCol 255)) (setq tCol 255))

 (defun *error* (msg)
   (redraw)
   (if tObj (entdel tObj))
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " (strcase msg))))
   (princ))

 ; ========================

 (setq vlst '("CLAYER" "OSMODE" "CMDECHO")
   ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(0 0))

 (if (not (tblsearch "LAYER" tLay))
   (command "_-layer" "_M" tLay "_C" "2" tLay ""))

 (or mo:def (setq mo:def "BK"))
 (or d:def (setq d:def "R"))
 (or m:def (setq m:def "L"))
 (setq ptxt "" detxt "")

 (if (and (setq cEnt (car (entsel "\nSelect Curve to Label: ")))
      (member (cdr (assoc 0 (entget cEnt)))
          '("ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE" "POLYLINE" "REGION" "SPLINE")))
   (progn
     (setq cObj (vlax-ename->vla-object cEnt)
       Area (rtos (/ (vla-get-area cObj) 144.0) 2 APrec))
     (while (= ptxt "")
   (setq ptxt (getstring "\nInput Piece Code: ")))
     (setq ptxt (substr ptxt 1 3))
     (while (not (member motxt '("BK" "DK" "SC" "BC" "AR" "AC")))
   (setq motxt (strcase
             (getstring
           (strcat "\nInput Module [bK/DK/SC/BC/AR/AC] <" mo:def ">: "))))
   (or (and (eq motxt "") (setq motxt mo:def)) (setq mo:def motxt)))
     (while (not (member dtxt '("R" "L" "S")))
   (setq dtxt (strcase
            (getstring
              (strcat "\nInput Direction [R/L/S] <" d:def ">: "))))
   (or (and (eq dtxt "") (setq dtxt d:def)) (setq d:def dtxt)))
     (while (not (member mtxt '("L" "S" "P" "D" "Q" "E")))
   (setq mtxt (strcase
            (getstring
              (strcat "\nInput Material [L/S/P/D/Q/E] <" m:def ">: "))))
   (or (and (eq mtxt "") (setq mtxt m:def)) (setq m:def mtxt)))
     (while (= detxt "")
   (setq detxt (getstring t "\nInput Description: ")))
     (setq detxt (substr detxt 1 20)
       tStr (strcat ptxt (chr 32) motxt (chr 32) dtxt (chr 32)
            mtxt (chr 32) Area (chr 32) detxt)
       tBox (textbox (list (cons 1 tStr)))
       tWid (- (caadr tBox) (caar tBox))
       tHgt (- (cadadr tBox) (cadar tBox)))
     (prompt "\nPlace Text... ")
     (while (= 5 (car (setq grdat (grread t 1))))
   (redraw)
   (if (= 'list (type (setq sPt (cadr grdat))))
     (progn
       (setq ClsPt (vlax-curve-getClosestPointto cObj sPt)
         cAngl (angle ClsPt sPt)
         btPt (polar ClsPt cAngl (/ (getvar "TEXTSIZE") 2.0))
         tpPt (polar ClsPt cAngl (+ (/ (getvar "TEXTSIZE") 2.0) tHgt))
         midPt (polar btPt cAngl (/ (distance btPt tpPt) 2.0))
         pt1 (polar btPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt2 (polar btPt (- cAngl (/ pi 2)) (/ tWid 2.0))
         pt3 (polar tpPt (+ cAngl (/ pi 2)) (/ tWid 2.0))
         pt4 (polar tpPt (- cAngl (/ pi 2)) (/ tWid 2.0)))
       (grvecs (list VCol pt1 pt2 VCol pt2 pt4 VCol pt1 pt3 VCol pt3 pt4)))))
     (setq tAngl (- cAngl (/ pi 2)))
     (if (and (> tAngl 0) (<= tAngl (/ pi 2)))
   nil
   (setq tAngl (+ tAngl pi)))
     (setq tObj (Make_Text midPt tStr tAngl)))
   (princ "\n<!> Object is not a Curve <!>"))
 (mapcar 'setvar vlst ovar)
 (redraw)
 (princ))

 (defun Make_Text  (pt val rot)
 (entmake (list '(0 . "TEXT")
        (cons 8 tLay)
        (cons 10 pt)
        (cons 40 tSze)
        (cons 1 val)
        (cons 50 rot)
        (cons 7 tStyl)
        (cons 62 tCol)
        '(71 . 0)
        '(72 . 1)
        '(73 . 2)
        (cons 11 pt))))

 (princ "\n** Namer.lsp Successfully Loaded, Type \"namer\" to invoke **")
 (princ)

April 3, 2009

Wow! That's awesome Lee!

I can't thank you enough man! This is pure greatness!

Need help getting LiSP from R12 working in Acad2007

Recommended Posts

x3ro

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

uddfl

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

x3ro

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity