Surveying Bearing/Distance LISP Routine

[rkmcswain]

Ok - I have to ask - why don't you want to just use the labeling commands in C3D?

[ccowgill]

you could try this, it puts the text on the annotation layer, and it gives you a couple more options. Option 3 sounds like what you want. It is supposed to drop the text at the midpoint of the object selected, rotated parallel (or tangent) to the object at that point.

(defun MakeLayer (lyrname acDoc / lyrobj)
      (vl-load-com)
      (if
    (not
      (vl-catch-all-error-p
        (setq lyrobj
           (vl-catch-all-apply
             'vla-add
             (list (vla-get-layers acDoc) lyrname)
           ) ;_ end of vl-catch-all-apply
        ) ;_ end of setq
      ) ;_ end of vl-catch-all-error-p
    ) ;_ end of not
     lyrobj
      ) ;_ end of if
    ) ;_ end of defun
    (defun c:lengthtext    (/         lengthmode     object
             objchk         listobj     vlobj
             MidPoint    Param     startpline
             endpline    vlobjlen1     angle1
             Ang         TH         vlobjang
             textobj1    textobj2     vlobjang1
             vlobjang2   lengthscale lyrobj
            )
      (if (not (tblsearch "Layer" "Annotation"))
    (if (setq lyrobj (MakeLayer "Annotation" acadDocument))
      (progn
        (vla-put-color lyrobj acgreen)
        (vla-put-plottable lyrobj :vlax-true)
        (vlax-release-object lyrobj)
      ) ;_ end of progn
      (setq errmsg "\nLayer Make failed for Annotation layer")
    ) ;_ end of if
      ) ;_ end of if
      
      (setq lengthmode
            (getint
              "\nSpecify Mode (1 = One Decimal, 2 = Two Decimals, 3 = Two Decimals with Bearing"
            ) ;_ end of getint
        lengthscale    (atoi (vl-string-left-trim
                ":"
                (vl-string-left-trim
                  "1234567890"
                  (getvar "cannoscale")
                ) ;_ end of vl-string-left-trim
                  ) ;_ end of vl-string-left-trim
            ) ;_ end of atoi
      ) ;_ end of setq
      (if (= lengthmode 3)
    (setq
      object
       (ssget
         (list
           (cons 0
             "ARC,LINE"
           ) ;_ end of cons
         ) ;_ end of list
       ) ;_ end of ssget
    ) ;_ end of setq
    (setq
      object
       (ssget
         (list
           (cons 0
             "POLYLINE,*CONTOUR,ARC,LINE,LWPOLYLINE,2DPOLYLINE"
           ) ;_ end of cons
         ) ;_ end of list
       ) ;_ end of ssget
    ) ;_ end of setq
      ) ;_ end of if
      (while (setq listobj (ssname object 0))
    (setq vlobj (vlax-ename->vla-object listobj))
    (if (/= (cdr (assoc 0 (entget listobj))) "ARC")
      (setq    vlobjlen1 (vla-get-length vlobj)
        objchk      1
      ) ;_ end of setq
      (setq    vlobjlen1 (vla-get-arclength vlobj)
        objchk      2
      ) ;_ end of setq
    ) ;_ end of if
    (setq MidPoint     (vlax-curve-getpointatdist
               vlObj
               (/ vlobjlen1 2)
             ) ;_ end of vlax-curve-getpointatdist
          Param     (vlax-curve-getParamAtPoint VlObj MidPoint)
          startpline (vlax-curve-getStartParam VlObj)
          endpline     (vlax-curve-getEndParam VlObj)
          angle1     (vlax-curve-getFirstDeriv
               VlObj
               (/ (- endpline startpline) 2)
             ) ;_ end of vlax-curve-getFirstDeriv
          TH     (* 0.08 lengthscale)
    ) ;_ end of setq
    (if (= objchk 1)
      (progn
        (if    (equal (car angle1) 0.0 0.01)
          (setq Ang (/ pi 2))
          (setq Ang (atan (/ (cadr angle1) (car angle1))))
        ) ;_ end of if
        (setq
          vlobjang    (angtos Ang 4 3)
          vlobjang1    (vl-string-left-trim "NS 0123456789" vlobjang)
          vlobjang2    (vl-string-right-trim
              "EW \"0123456789'"
              vlobjang
            ) ;_ end of vl-string-right-trim
          vlobjang2    (vl-string-right-trim "d" vlobjang2)
          vlobjang    (strcat vlobjang2 "%%" vlobjang1)
        ) ;_ end of setq
      ) ;_ end of progn
      (setq
        Ang          (- (/ (+ (vla-get-endangle vlobj)
                   (vla-get-startangle vlobj)
                ) ;_ end of +
                2
             ) ;_ end of /
             (/ pi 2)
              ) ;_ end of -
        vlobjang  (angtos Ang 4 3)
        vlobjang1 (vl-string-left-trim "NS 0123456789" vlobjang)
        vlobjang2 (vl-string-right-trim "EW \"0123456789'" vlobjang)
        vlobjang2 (vl-string-right-trim "d" vlobjang2)
        vlobjang  (strcat vlobjang2 "%%" vlobjang1)
      ) ;_ end of setq
    ) ;_ end of if
    (cond
      ((= lengthmode 1)
       (if (wcmatch (rtos vlobjlen1 2 1) "*`.*")
         (setq vlobjlen (strcat (rtos vlobjlen1 2 1) "'"))
         (setq vlobjlen (strcat (rtos vlobjlen1 2 1) ".0'"))
       ) ;_ end of if
       (setq textObj1 (vla-addtext
                acadModelSpace
                vlobjlen
                (vlax-3d-point Midpoint)
                TH
              )        ;end vla-addtext
       )                ;end setq
      )
      ((= lengthmode 2)
       (cond
         ((wcmatch (rtos vlobjlen1 2 2) "*`.##")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*`.#")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
          ) ;_ end of setq
         )
       ) ;_ end of cond
       (setq
         textObj1 (vla-addtext
            acadModelSpace
            vlobjlen
            (vlax-3d-point Midpoint)
            TH
              )            ;end vla-addtext
       )                ;end setq
      )
      ((= lengthmode 3)
       (cond
         ((wcmatch (rtos vlobjlen1 2 2) "*`.##")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*`.#")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
          ) ;_ end of setq
         )
       ) ;_ end of cond
       (setq
         textObj1 (vla-addtext
            acadModelSpace
            vlobjlen
            (vlax-3d-point Midpoint)
            TH
              )            ;end vla-addtext
         textobj2 (vla-addtext
            acadModelSpace
            vlobjang
            (vlax-3d-point Midpoint)
            TH
              ) ;_ end of vla-addtext
       )                ;end setq
      )
    ) ;_ end of cond
    (vla-put-color textobj1 256)    ;change color
    (vla-put-alignment textobj1 13)    ;change justification
    (vla-put-textalignmentpoint
      textobj1
      (vlax-3d-point Midpoint)
    ) ;_ end of vla-put-textalignmentpoint
                    ;change insetion point
    (vla-put-rotation textobj1 Ang)
                    ;change rotation
    (vla-put-layer textobj1 "Annotation")
    (if (/= textObj2 nil)
      (progn
        (vla-put-color textobj2 256)
        (vla-put-alignment textobj2 13)
        (vla-put-textalignmentpoint
          textobj2
          (vlax-3d-point
        (list
          (+ (car Midpoint) (* (sin ang) (* 0.16 lengthscale)))
          (- (cadr Midpoint) (* (cos ang) (* 0.16 lengthscale)))
          (caddr Midpoint)
        ) ;_ end of list
          ) ;_ end of vlax-3d-point
        ) ;_ end of vla-put-textalignmentpoint
        (vla-put-rotation textobj2 Ang)
        (vla-put-layer textobj2 "Annotation")
      ) ;_ end of progn
    ) ;_ end of if
    (ssdel listobj object)
      )                    ;end while
    )                    ;end defun

[margaretl]

Ok - I have to ask - why don't you want to just use the labeling commands in C3D?

I agree, Why???

[xfirez]

you could try this, it puts the text on the annotation layer, and it gives you a couple more options. Option 3 sounds like what you want. It is supposed to drop the text at the midpoint of the object selected, rotated parallel (or tangent) to the object at that point.

(defun MakeLayer (lyrname acDoc / lyrobj)
      (vl-load-com)
      (if
    (not
      (vl-catch-all-error-p
        (setq lyrobj
           (vl-catch-all-apply
             'vla-add
             (list (vla-get-layers acDoc) lyrname)
           ) ;_ end of vl-catch-all-apply
        ) ;_ end of setq
      ) ;_ end of vl-catch-all-error-p
    ) ;_ end of not
     lyrobj
      ) ;_ end of if
    ) ;_ end of defun
    (defun c:lengthtext    (/         lengthmode     object
             objchk         listobj     vlobj
             MidPoint    Param     startpline
             endpline    vlobjlen1     angle1
             Ang         TH         vlobjang
             textobj1    textobj2     vlobjang1
             vlobjang2   lengthscale lyrobj
            )
      (if (not (tblsearch "Layer" "Annotation"))
    (if (setq lyrobj (MakeLayer "Annotation" acadDocument))
      (progn
        (vla-put-color lyrobj acgreen)
        (vla-put-plottable lyrobj :vlax-true)
        (vlax-release-object lyrobj)
      ) ;_ end of progn
      (setq errmsg "\nLayer Make failed for Annotation layer")
    ) ;_ end of if
      ) ;_ end of if
      
      (setq lengthmode
            (getint
              "\nSpecify Mode (1 = One Decimal, 2 = Two Decimals, 3 = Two Decimals with Bearing"
            ) ;_ end of getint
        lengthscale    (atoi (vl-string-left-trim
                ":"
                (vl-string-left-trim
                  "1234567890"
                  (getvar "cannoscale")
                ) ;_ end of vl-string-left-trim
                  ) ;_ end of vl-string-left-trim
            ) ;_ end of atoi
      ) ;_ end of setq
      (if (= lengthmode 3)
    (setq
      object
       (ssget
         (list
           (cons 0
             "ARC,LINE"
           ) ;_ end of cons
         ) ;_ end of list
       ) ;_ end of ssget
    ) ;_ end of setq
    (setq
      object
       (ssget
         (list
           (cons 0
             "POLYLINE,*CONTOUR,ARC,LINE,LWPOLYLINE,2DPOLYLINE"
           ) ;_ end of cons
         ) ;_ end of list
       ) ;_ end of ssget
    ) ;_ end of setq
      ) ;_ end of if
      (while (setq listobj (ssname object 0))
    (setq vlobj (vlax-ename->vla-object listobj))
    (if (/= (cdr (assoc 0 (entget listobj))) "ARC")
      (setq    vlobjlen1 (vla-get-length vlobj)
        objchk      1
      ) ;_ end of setq
      (setq    vlobjlen1 (vla-get-arclength vlobj)
        objchk      2
      ) ;_ end of setq
    ) ;_ end of if
    (setq MidPoint     (vlax-curve-getpointatdist
               vlObj
               (/ vlobjlen1 2)
             ) ;_ end of vlax-curve-getpointatdist
          Param     (vlax-curve-getParamAtPoint VlObj MidPoint)
          startpline (vlax-curve-getStartParam VlObj)
          endpline     (vlax-curve-getEndParam VlObj)
          angle1     (vlax-curve-getFirstDeriv
               VlObj
               (/ (- endpline startpline) 2)
             ) ;_ end of vlax-curve-getFirstDeriv
          TH     (* 0.08 lengthscale)
    ) ;_ end of setq
    (if (= objchk 1)
      (progn
        (if    (equal (car angle1) 0.0 0.01)
          (setq Ang (/ pi 2))
          (setq Ang (atan (/ (cadr angle1) (car angle1))))
        ) ;_ end of if
        (setq
          vlobjang    (angtos Ang 4 3)
          vlobjang1    (vl-string-left-trim "NS 0123456789" vlobjang)
          vlobjang2    (vl-string-right-trim
              "EW \"0123456789'"
              vlobjang
            ) ;_ end of vl-string-right-trim
          vlobjang2    (vl-string-right-trim "d" vlobjang2)
          vlobjang    (strcat vlobjang2 "%%" vlobjang1)
        ) ;_ end of setq
      ) ;_ end of progn
      (setq
        Ang          (- (/ (+ (vla-get-endangle vlobj)
                   (vla-get-startangle vlobj)
                ) ;_ end of +
                2
             ) ;_ end of /
             (/ pi 2)
              ) ;_ end of -
        vlobjang  (angtos Ang 4 3)
        vlobjang1 (vl-string-left-trim "NS 0123456789" vlobjang)
        vlobjang2 (vl-string-right-trim "EW \"0123456789'" vlobjang)
        vlobjang2 (vl-string-right-trim "d" vlobjang2)
        vlobjang  (strcat vlobjang2 "%%" vlobjang1)
      ) ;_ end of setq
    ) ;_ end of if
    (cond
      ((= lengthmode 1)
       (if (wcmatch (rtos vlobjlen1 2 1) "*`.*")
         (setq vlobjlen (strcat (rtos vlobjlen1 2 1) "'"))
         (setq vlobjlen (strcat (rtos vlobjlen1 2 1) ".0'"))
       ) ;_ end of if
       (setq textObj1 (vla-addtext
                acadModelSpace
                vlobjlen
                (vlax-3d-point Midpoint)
                TH
              )        ;end vla-addtext
       )                ;end setq
      )
      ((= lengthmode 2)
       (cond
         ((wcmatch (rtos vlobjlen1 2 2) "*`.##")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*`.#")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
          ) ;_ end of setq
         )
       ) ;_ end of cond
       (setq
         textObj1 (vla-addtext
            acadModelSpace
            vlobjlen
            (vlax-3d-point Midpoint)
            TH
              )            ;end vla-addtext
       )                ;end setq
      )
      ((= lengthmode 3)
       (cond
         ((wcmatch (rtos vlobjlen1 2 2) "*`.##")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*`.#")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) "0'")
          ) ;_ end of setq
         )
         ((wcmatch (rtos vlobjlen1 2 2) "*")
          (setq vlobjlen (strcat (rtos vlobjlen1 2 2) ".00'")
          ) ;_ end of setq
         )
       ) ;_ end of cond
       (setq
         textObj1 (vla-addtext
            acadModelSpace
            vlobjlen
            (vlax-3d-point Midpoint)
            TH
              )            ;end vla-addtext
         textobj2 (vla-addtext
            acadModelSpace
            vlobjang
            (vlax-3d-point Midpoint)
            TH
              ) ;_ end of vla-addtext
       )                ;end setq
      )
    ) ;_ end of cond
    (vla-put-color textobj1 256)    ;change color
    (vla-put-alignment textobj1 13)    ;change justification
    (vla-put-textalignmentpoint
      textobj1
      (vlax-3d-point Midpoint)
    ) ;_ end of vla-put-textalignmentpoint
                    ;change insetion point
    (vla-put-rotation textobj1 Ang)
                    ;change rotation
    (vla-put-layer textobj1 "Annotation")
    (if (/= textObj2 nil)
      (progn
        (vla-put-color textobj2 256)
        (vla-put-alignment textobj2 13)
        (vla-put-textalignmentpoint
          textobj2
          (vlax-3d-point
        (list
          (+ (car Midpoint) (* (sin ang) (* 0.16 lengthscale)))
          (- (cadr Midpoint) (* (cos ang) (* 0.16 lengthscale)))
          (caddr Midpoint)
        ) ;_ end of list
          ) ;_ end of vlax-3d-point
        ) ;_ end of vla-put-textalignmentpoint
        (vla-put-rotation textobj2 Ang)
        (vla-put-layer textobj2 "Annotation")
      ) ;_ end of progn
    ) ;_ end of if
    (ssdel listobj object)
      )                    ;end while
    )                    ;end defun

i got some error?

Command: appload
lengthtext.lsp successfully loaded.


Command:
Command:
Command: lengthtext
*Cancel*

Command:
Command:
Command: bad argument type: VLA-OBJECT nil
Command: lengthtext
*Cancel*
bad argument type: VLA-OBJECT nil

oliver

[ccowgill]

i got some error?

Command: appload
lengthtext.lsp successfully loaded.


Command:
Command:
Command: lengthtext
*Cancel*

Command:
Command:
Command: bad argument type: VLA-OBJECT nil
Command: lengthtext
*Cancel*
bad argument type: VLA-OBJECT nil

oliver

what version of AutoCAD are you running, if it is prior to 08, the cannotationscale sysvar does not exist. Also, you may need to add the following to the program and the local variables as well:

(vl-load-com)
    (setq acadObject (vlax-get-acad-object)) ;get Autocad object
    (setq acadDocument (vla-get-ActiveDocument acadObject))
 ;get the Activedocument object
    (setq DwgProps (vla-get-SummaryInfo acadDocument))
 ;get custom drawing properties
    (setq acadModelSpace (vla-get-modelspace acadDocument))
 ;get the modelspace block
    (setq acadPaperSpace (vla-get-paperspace acadDocument))
 ;get the paperspace block
    (setq acadversion (getvar "acadver"))

[xfirez]

i'm using acad2004?

[ccowgill]

make the change in red:

(setq lengthmode
            (getint
              "\nSpecify Mode (1 = One Decimal, 2 = Two Decimals, 3 = Two Decimals with Bearing"
            ) ;_ end of getint
        lengthscale    (getint "\nInput scale of drawing:\n")
      ) ;_ end of setq

the scale you would input for instance would be: if the scale will be 1/40, input 40, 1/100, input 100, etc.

[jsnt1109]

try this ..if u can modify it better pls let me know.thanks
hope can help.
http://www.cadtutor.net/forum/showthread.php?t=20991

[GreyHippo]

Here's my program, it works by picking two points and labeling the bearing and distance between them. If you need help with it email me boesiii at yahoo dot com

I also have another one that labels each individual line in a polyline but its back at the office.

[SuperD]

I also found that routine and it is just not user friendly. With the old LISP that I had, all you had to do was type in the routine and select the line in which you were interested in. I have searched for similar routines and have not found any that are as efficient. Thanks for your help though. If anybody knows of anything, please help!!!

Here's a simple but efficient routine on found on the net that was developed in 1990. I had to make some minor changes to it so that it would work in 2008 but I will not accept credit for it. I love how sweet and efficient it is with various options for displaying the data.