Jump to content

Generate Bearings & Distances into table


oliver

Recommended Posts

  • Replies 75
  • Created
  • Last Reply

Top Posters In This Topic

  • Madruga_SP

    22

  • ymg3

    14

  • fixo

    9

  • alanjt

    8

Top Posters In This Topic

Posted Images

Generate Bearings & Distances into table

as shown in figure..

 

please help us

thank you.

 

:)

 

Try this one (quick and dirty though)


(vl-load-com)
(defun C:Bearings (/ *error* acsp ang atable cnt col dist item osm
     point_list pt row table_data tmp tmp_data)

  (defun *error*  (msg)
    (if (and msg
      (not
        (member msg
         '("console break" "Function cancelled" "quit / exit abort"))))
      (princ (strcat "\nError: " msg))
      )
    (if osm
      (setvar "osmode" osm))
    (princ)
    ) 

(setq osm (getvar "osmode"))
(setvar "osmode" 1)

(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  >> Specify point #"
     (itoa cnt)
     " by order (hit Enter to exit) >> ")))
  (setq point_list (cons pt point_list)
 cnt    (1+ cnt))
  )
(setq point_list (reverse point_list))

(setq cnt 0)
(while (<= cnt (- (length point_list) 2))
  (setq tmp  (list (strcat (itoa (1+ cnt)) " - " (itoa (+ cnt 2)))
         (nth cnt point_list)
         (nth (1+ cnt) point_list))
 tmp_data (cons tmp tmp_data)
 )
  (setq cnt (1+ cnt))
  )
(setq tmp      (list (strcat (itoa (length point_list)) " - 1")
       (last point_list)
       (car point_list))
      tmp_data (cons tmp tmp_data)
      )
(setq tmp_data (reverse tmp_data))
(foreach item  tmp_data
  (setq ang (angle (cadr item) (caddr item)))
  (setq ang (angtos ang 4 4))
  (setq dist (distance (cadr item) (caddr item)))
  (setq dist (strcat (rtos dist 2 2) " m."))
  (setq tmp (list (car item) ang dist))
  (setq table_data (cons tmp table_data))
  )
(setq table_data (reverse table_data))
(setq pt (getpoint "\n  >> Specify insertion point >> "))
(setq acsp (vla-get-block
      (vla-get-activelayout
        (vla-get-activedocument
   (vlax-get-acad-object))))
      )
(setq atable
       (vlax-invoke
  acsp
  'AddTable
  pt
  (+ 2 (length table_data))
  (length (car table_data))
  (* (getvar "textsize") 2.0)
  (* (getvar "textsize") 15))
      )
(vla-put-regeneratetablesuppressed atable :vlax-true)
(vla-settextheight atable actitlerow (getvar "textsize"))
(vla-settextheight atable acheaderrow (getvar "textsize"))
(vla-settextheight atable acdatarow (getvar "textsize"))
(vla-put-vertcellmargin atable (/ (getvar "textsize") 4.25))
(vla-settext atable 0 0 "TECHNICAL DESCRIPTIONS")
(vla-settext atable 1 0 "LINES")
(vla-settext atable 1 1 "BEARINGS")
(vla-settext atable 1 2 "DISTANCES")
(setq row 2)
(foreach item  table_data
  (setq col 0)
  (foreach x  item
    (vla-settext atable row col x)
    (vla-setcellalignment atable row col acMiddleCenter)
    (setq col (1+ col)))
  (setq row (1+ row))
  )

  (vla-put-regeneratetablesuppressed atable :vlax-false)

  (*error* nil)

  (princ)
)

 

~'J'~

Link to comment
Share on other sites

Try this one (quick and dirty though)


(vl-load-com)
(defun C:Bearings (/ *error* acsp ang atable cnt col dist item osm
     point_list pt row table_data tmp tmp_data)

  (defun *error*  (msg)
    (if (and msg
      (not
        (member msg
         '("console break" "Function cancelled" "quit / exit abort"))))
      (princ (strcat "\nError: " msg))
      )
    (if osm
      (setvar "osmode" osm))
    (princ)
    ) 

(setq osm (getvar "osmode"))
(setvar "osmode" 1)

(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  >> Specify point #"
     (itoa cnt)
     " by order (hit Enter to exit) >> ")))
  (setq point_list (cons pt point_list)
 cnt    (1+ cnt))
  )
(setq point_list (reverse point_list))

(setq cnt 0)
(while (<= cnt (- (length point_list) 2))
  (setq tmp  (list (strcat (itoa (1+ cnt)) " - " (itoa (+ cnt 2)))
         (nth cnt point_list)
         (nth (1+ cnt) point_list))
 tmp_data (cons tmp tmp_data)
 )
  (setq cnt (1+ cnt))
  )
(setq tmp      (list (strcat (itoa (length point_list)) " - 1")
       (last point_list)
       (car point_list))
      tmp_data (cons tmp tmp_data)
      )
(setq tmp_data (reverse tmp_data))
(foreach item  tmp_data
  (setq ang (angle (cadr item) (caddr item)))
  (setq ang (angtos ang 4 4))
  (setq dist (distance (cadr item) (caddr item)))
  (setq dist (strcat (rtos dist 2 2) " m."))
  (setq tmp (list (car item) ang dist))
  (setq table_data (cons tmp table_data))
  )
(setq table_data (reverse table_data))
(setq pt (getpoint "\n  >> Specify insertion point >> "))
(setq acsp (vla-get-block
      (vla-get-activelayout
        (vla-get-activedocument
   (vlax-get-acad-object))))
      )
(setq atable
       (vlax-invoke
  acsp
  'AddTable
  pt
  (+ 2 (length table_data))
  (length (car table_data))
  (* (getvar "textsize") 2.0)
  (* (getvar "textsize") 15))
      )
(vla-put-regeneratetablesuppressed atable :vlax-true)
(vla-settextheight atable actitlerow (getvar "textsize"))
(vla-settextheight atable acheaderrow (getvar "textsize"))
(vla-settextheight atable acdatarow (getvar "textsize"))
(vla-put-vertcellmargin atable (/ (getvar "textsize") 4.25))
(vla-settext atable 0 0 "TECHNICAL DESCRIPTIONS")
(vla-settext atable 1 0 "LINES")
(vla-settext atable 1 1 "BEARINGS")
(vla-settext atable 1 2 "DISTANCES")
(setq row 2)
(foreach item  table_data
  (setq col 0)
  (foreach x  item
    (vla-settext atable row col x)
    (vla-setcellalignment atable row col acMiddleCenter)
    (setq col (1+ col)))
  (setq row (1+ row))
  )

  (vla-put-regeneratetablesuppressed atable :vlax-false)

  (*error* nil)

  (princ)
)

 

~'J'~

 

This is great !!! why does Acad insist on putting the "d" in the bearing angle instead of chr alt 248 (degree symbol) ?

Is there a way to program the degree symbol ? into the bearing instead of "d" ?

If not, one can always edit the table line by line...

Thanks for super program for those who do not have civil add on.

S

Link to comment
Share on other sites

Substitute

 

(setq ang (angtos ang 4 4))

 

for

 

(setq ang (vl-string-subst "°" "d" (angtos ang 4 4)))

 

will give you the degrees symbol

 

SF

Link to comment
Share on other sites

Substitute

 

(setq ang (angtos ang 4 4))

 

for

 

(setq ang (vl-string-subst "°" "d" (angtos ang 4 4)))

 

will give you the degrees symbol

 

SF

 

Thanks, it's much easier that I've thought :)

 

~'J'~

Link to comment
Share on other sites

I have modified it some more, so that the end result is easier to read.

If minutes and/or seconds are under 10 then a zero has been added to the bearing string.

hope that's useful

SF

 

 

(vl-load-com)
(defun C:Bearings (/ *error* acsp ang atable cnt col dist item osm
                     point_list pt row table_data tmp tmp_data
             degreeloc minuteloc secondloc AngString)

  (defun *error*  (msg)
    (if (and msg
      (not
        (member msg
         '("console break" "Function cancelled" "quit / exit abort"))))
      (princ (strcat "\nError: " msg))
      )
    (if osm
      (setvar "osmode" osm))
    (princ)
    ) 

(setq osm (getvar "osmode"))
(setvar "osmode" 1)

(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  >> Specify point #"
     (itoa cnt)
     " by order (hit Enter to exit) >> ")))
  (setq point_list (cons pt point_list)
 cnt    (1+ cnt))
  )
(setq point_list (reverse point_list))

(setq cnt 0)
(while (<= cnt (- (length point_list) 2))
  (setq tmp  (list (strcat (itoa (1+ cnt)) " - " (itoa (+ cnt 2)))
         (nth cnt point_list)
         (nth (1+ cnt) point_list))
 tmp_data (cons tmp tmp_data)
 )
  (setq cnt (1+ cnt))
  )
(setq tmp      (list (strcat (itoa (length point_list)) " - 1")
       (last point_list)
       (car point_list))
      tmp_data (cons tmp tmp_data)
      )
(setq tmp_data (reverse tmp_data))
  
(foreach item  tmp_data
(setq ang (angtos(angle (cadr item) (caddr item))4 4)
      degreeloc (vl-string-position (ascii "d") ang);location of "d"
      minuteloc (vl-string-position (ascii "'") ang);location of '
      secondloc (vl-string-position (ascii "\"") ang);location of "
);setq
(if (= (- minuteloc degreeloc) 2)
(setq ang (vl-string-subst "d0" "d" ang));add 0 for seconds under 10
);if
(if (= (- secondloc minuteloc) 2)
(setq ang (vl-string-subst "'0" "'" ang));add 0 for minutes under 10
);if
(setq AngString (vl-string-subst "°" "d" ang);Substitute degree symbol
      dist (distance (cadr item) (caddr item))
      dist (strcat (rtos dist 2 2) " m.")
      tmp (list (car item) AngString dist)
      table_data (cons tmp table_data)
);setq
);foreach
  
(setq
       table_data (reverse table_data)
       pt (getpoint "\n  >> Specify insertion point >> ")
       acsp (vla-get-block
            (vla-get-activelayout
            (vla-get-activedocument
            (vlax-get-acad-object))))
      
      atable (vlax-invoke acsp 'AddTable pt
             (+ 2 (length table_data))
             (length (car table_data))
             (* (getvar "textsize") 2.0)
             (* (getvar "textsize") 15))   
);setq
(vla-put-regeneratetablesuppressed atable :vlax-true)
(vla-settextheight atable actitlerow (getvar "textsize"))
(vla-settextheight atable acheaderrow (getvar "textsize"))
(vla-settextheight atable acdatarow (getvar "textsize"))
(vla-put-vertcellmargin atable (/ (getvar "textsize") 4.25))
(vla-settext atable 0 0 "TECHNICAL DESCRIPTIONS")
(vla-settext atable 1 0 "LINES")
(vla-settext atable 1 1 "BEARINGS")
(vla-settext atable 1 2 "DISTANCES")
(setq row 2)
(foreach item  table_data
  (setq col 0)
  (foreach x  item
    (vla-settext atable row col x)
    (vla-setcellalignment atable row col acMiddleCenter)
    (setq col (1+ col)))
  (setq row (1+ row))
  )

  (vla-put-regeneratetablesuppressed atable :vlax-false)

  (*error* nil)

  (princ)
)

Link to comment
Share on other sites

I have modified it some more, so that the end result is easier to read.

If minutes and/or seconds are under 10 then a zero has been added to the bearing string.

hope that's useful

SF

 

 

(vl-load-com)
(defun C:Bearings (/ *error* acsp ang atable cnt col dist item osm
                     point_list pt row table_data tmp tmp_data
             degreeloc minuteloc secondloc AngString)

  (defun *error*  (msg)
    (if (and msg
      (not
        (member msg
         '("console break" "Function cancelled" "quit / exit abort"))))
      (princ (strcat "\nError: " msg))
      )
    (if osm
      (setvar "osmode" osm))
    (princ)
    ) 

(setq osm (getvar "osmode"))
(setvar "osmode" 1)

(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  >> Specify point #"
     (itoa cnt)
     " by order (hit Enter to exit) >> ")))
  (setq point_list (cons pt point_list)
 cnt    (1+ cnt))
  )
(setq point_list (reverse point_list))

(setq cnt 0)
(while (<= cnt (- (length point_list) 2))
  (setq tmp  (list (strcat (itoa (1+ cnt)) " - " (itoa (+ cnt 2)))
         (nth cnt point_list)
         (nth (1+ cnt) point_list))
 tmp_data (cons tmp tmp_data)
 )
  (setq cnt (1+ cnt))
  )
(setq tmp      (list (strcat (itoa (length point_list)) " - 1")
       (last point_list)
       (car point_list))
      tmp_data (cons tmp tmp_data)
      )
(setq tmp_data (reverse tmp_data))
  
(foreach item  tmp_data
(setq ang (angtos(angle (cadr item) (caddr item))4 4)
      degreeloc (vl-string-position (ascii "d") ang);location of "d"
      minuteloc (vl-string-position (ascii "'") ang);location of '
      secondloc (vl-string-position (ascii "\"") ang);location of "
);setq
(if (= (- minuteloc degreeloc) 2)
(setq ang (vl-string-subst "d0" "d" ang));add 0 for seconds under 10
);if
(if (= (- secondloc minuteloc) 2)
(setq ang (vl-string-subst "'0" "'" ang));add 0 for minutes under 10
);if
(setq AngString (vl-string-subst "°" "d" ang);Substitute degree symbol
      dist (distance (cadr item) (caddr item))
      dist (strcat (rtos dist 2 2) " m.")
      tmp (list (car item) AngString dist)
      table_data (cons tmp table_data)
);setq
);foreach
  
(setq
       table_data (reverse table_data)
       pt (getpoint "\n  >> Specify insertion point >> ")
       acsp (vla-get-block
            (vla-get-activelayout
            (vla-get-activedocument
            (vlax-get-acad-object))))
      
      atable (vlax-invoke acsp 'AddTable pt
             (+ 2 (length table_data))
             (length (car table_data))
             (* (getvar "textsize") 2.0)
             (* (getvar "textsize") 15))   
);setq
(vla-put-regeneratetablesuppressed atable :vlax-true)
(vla-settextheight atable actitlerow (getvar "textsize"))
(vla-settextheight atable acheaderrow (getvar "textsize"))
(vla-settextheight atable acdatarow (getvar "textsize"))
(vla-put-vertcellmargin atable (/ (getvar "textsize") 4.25))
(vla-settext atable 0 0 "TECHNICAL DESCRIPTIONS")
(vla-settext atable 1 0 "LINES")
(vla-settext atable 1 1 "BEARINGS")
(vla-settext atable 1 2 "DISTANCES")
(setq row 2)
(foreach item  table_data
  (setq col 0)
  (foreach x  item
    (vla-settext atable row col x)
    (vla-setcellalignment atable row col acMiddleCenter)
    (setq col (1+ col)))
  (setq row (1+ row))
  )

  (vla-put-regeneratetablesuppressed atable :vlax-false)

  (*error* nil)

  (princ)
)

thank you so much..

 

:shock:

Link to comment
Share on other sites

I have modified it some more, so that the end result is easier to read.

If minutes and/or seconds are under 10 then a zero has been added to the bearing string.

hope that's useful

SF

 

 

(vl-load-com)
(defun C:Bearings (/ *error* acsp ang atable cnt col dist item osm
                     point_list pt row table_data tmp tmp_data
             degreeloc minuteloc secondloc AngString)

  (defun *error*  (msg)
    (if (and msg
      (not
        (member msg
         '("console break" "Function cancelled" "quit / exit abort"))))
      (princ (strcat "\nError: " msg))
      )
    (if osm
      (setvar "osmode" osm))
    (princ)
    ) 

(setq osm (getvar "osmode"))
(setvar "osmode" 1)

(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  >> Specify point #"
     (itoa cnt)
     " by order (hit Enter to exit) >> ")))
  (setq point_list (cons pt point_list)
 cnt    (1+ cnt))
  )
(setq point_list (reverse point_list))

(setq cnt 0)
(while (<= cnt (- (length point_list) 2))
  (setq tmp  (list (strcat (itoa (1+ cnt)) " - " (itoa (+ cnt 2)))
         (nth cnt point_list)
         (nth (1+ cnt) point_list))
 tmp_data (cons tmp tmp_data)
 )
  (setq cnt (1+ cnt))
  )
(setq tmp      (list (strcat (itoa (length point_list)) " - 1")
       (last point_list)
       (car point_list))
      tmp_data (cons tmp tmp_data)
      )
(setq tmp_data (reverse tmp_data))
  
(foreach item  tmp_data
(setq ang (angtos(angle (cadr item) (caddr item))4 4)
      degreeloc (vl-string-position (ascii "d") ang);location of "d"
      minuteloc (vl-string-position (ascii "'") ang);location of '
      secondloc (vl-string-position (ascii "\"") ang);location of "
);setq
(if (= (- minuteloc degreeloc) 2)
(setq ang (vl-string-subst "d0" "d" ang));add 0 for seconds under 10
);if
(if (= (- secondloc minuteloc) 2)
(setq ang (vl-string-subst "'0" "'" ang));add 0 for minutes under 10
);if
(setq AngString (vl-string-subst "°" "d" ang);Substitute degree symbol
      dist (distance (cadr item) (caddr item))
      dist (strcat (rtos dist 2 2) " m.")
      tmp (list (car item) AngString dist)
      table_data (cons tmp table_data)
);setq
);foreach
  
(setq
       table_data (reverse table_data)
       pt (getpoint "\n  >> Specify insertion point >> ")
       acsp (vla-get-block
            (vla-get-activelayout
            (vla-get-activedocument
            (vlax-get-acad-object))))
      
      atable (vlax-invoke acsp 'AddTable pt
             (+ 2 (length table_data))
             (length (car table_data))
             (* (getvar "textsize") 2.0)
             (* (getvar "textsize") 15))   
);setq
(vla-put-regeneratetablesuppressed atable :vlax-true)
(vla-settextheight atable actitlerow (getvar "textsize"))
(vla-settextheight atable acheaderrow (getvar "textsize"))
(vla-settextheight atable acdatarow (getvar "textsize"))
(vla-put-vertcellmargin atable (/ (getvar "textsize") 4.25))
(vla-settext atable 0 0 "TECHNICAL DESCRIPTIONS")
(vla-settext atable 1 0 "LINES")
(vla-settext atable 1 1 "BEARINGS")
(vla-settext atable 1 2 "DISTANCES")
(setq row 2)
(foreach item  table_data
  (setq col 0)
  (foreach x  item
    (vla-settext atable row col x)
    (vla-setcellalignment atable row col acMiddleCenter)
    (setq col (1+ col)))
  (setq row (1+ row))
  )

  (vla-put-regeneratetablesuppressed atable :vlax-false)

  (*error* nil)

  (princ)
)

once again thank you..another little favor could you please modified this lisp.."remove the seconds" as shown in the figure in my first post.

thanks and "HAPPY FATHER'S DAY"

 

:)

Link to comment
Share on other sites

I'll say it once more then keep my mouth shut: You can do this very thing from core LDD and/or C3D and it's a lot easier.

Link to comment
Share on other sites

Try this - without seconds

check out angtos function

you can adjust the the two numbers at the end of this line

for a different format.

 

 
(setq ang (angtos(angle (cadr item) (caddr item))4 2);precision 2 - ;minutes only

 

updated code-

 

 
(vl-load-com)
(defun C:Bearings (/ *error* acsp ang atable cnt col dist item osm
                     point_list pt row table_data tmp tmp_data
             degreeloc minuteloc secondloc AngString)

  (defun *error*  (msg)
    (if (and msg
      (not
        (member msg
         '("console break" "Function cancelled" "quit / exit abort"))))
      (princ (strcat "\nError: " msg))
      )
    (if osm
      (setvar "osmode" osm))
    (princ)
    ) 

(setq osm (getvar "osmode"))
(setvar "osmode" 1)

(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  >> Specify point #"
     (itoa cnt)
     " by order (hit Enter to exit) >> ")))
  (setq point_list (cons pt point_list)
 cnt    (1+ cnt))
  )
(setq point_list (reverse point_list))

(setq cnt 0)
(while (<= cnt (- (length point_list) 2))
  (setq tmp  (list (strcat (itoa (1+ cnt)) " - " (itoa (+ cnt 2)))
         (nth cnt point_list)
         (nth (1+ cnt) point_list))
 tmp_data (cons tmp tmp_data)
 )
  (setq cnt (1+ cnt))
  )
(setq tmp      (list (strcat (itoa (length point_list)) " - 1")
       (last point_list)
       (car point_list))
      tmp_data (cons tmp tmp_data)
      )
(setq tmp_data (reverse tmp_data))
  
(foreach item  tmp_data
(setq ang (angtos(angle (cadr item) (caddr item))4 2);precision 2 - minutes only
      degreeloc (vl-string-position (ascii "d") ang);location of "d"
      minuteloc (vl-string-position (ascii "'") ang);location of '
;;;       secondloc (vl-string-position (ascii "\"") ang);location of "
);setq
(if (= (- minuteloc degreeloc) 2)
(setq ang (vl-string-subst "d0" "d" ang));add 0 for seconds under 10
);if
;;; (if (= (- secondloc minuteloc) 2)
;;; (setq ang (vl-string-subst "'0" "'" ang));add 0 for minutes under 10
;;; );if
(setq AngString (vl-string-subst "°" "d" ang);Substitute degree symbol
      dist (distance (cadr item) (caddr item))
      dist (strcat (rtos dist 2 2) " m.")
      tmp (list (car item) AngString dist)
      table_data (cons tmp table_data)
);setq
);foreach
  
(setq
       table_data (reverse table_data)
       pt (getpoint "\n  >> Specify insertion point >> ")
       acsp (vla-get-block
            (vla-get-activelayout
            (vla-get-activedocument
            (vlax-get-acad-object))))
      
      atable (vlax-invoke acsp 'AddTable pt
             (+ 2 (length table_data))
             (length (car table_data))
             (* (getvar "textsize") 2.0)
             (* (getvar "textsize") 15))   
);setq
(vla-put-regeneratetablesuppressed atable :vlax-true)
(vla-settextheight atable actitlerow (getvar "textsize"))
(vla-settextheight atable acheaderrow (getvar "textsize"))
(vla-settextheight atable acdatarow (getvar "textsize"))
(vla-put-vertcellmargin atable (/ (getvar "textsize") 4.25))
(vla-settext atable 0 0 "TECHNICAL DESCRIPTIONS")
(vla-settext atable 1 0 "LINES")
(vla-settext atable 1 1 "BEARINGS")
(vla-settext atable 1 2 "DISTANCES")
(setq row 2)
(foreach item  table_data
  (setq col 0)
  (foreach x  item
    (vla-settext atable row col x)
    (vla-setcellalignment atable row col acMiddleCenter)
    (setq col (1+ col)))
  (setq row (1+ row))
  )

  (vla-put-regeneratetablesuppressed atable :vlax-false)

  (*error* nil)

  (princ)
)

Link to comment
Share on other sites

I'll say it once more then keep my mouth shut: You can do this very thing from core LDD and/or C3D and it's a lot easier.

 

But Alan not all of us have LDD and/or C3D.

Most of us just have plain vanilla Autocad icon9.gif

Link to comment
Share on other sites

But Alan not all of us have LDD and/or C3D.

Most of us just have plain vanilla Autocad icon9.gif

True, but the OP (oliver) has LDD.

 

Does LDD/C3D cost a lot more than Vanilla CAD? Just curious

Much much more. All the addon version of cad are a lot more expensive. I think C3D is around $6000.

Link to comment
Share on other sites

I think vanilla is around $3000.

They're all AutoCAD, just with lots of extras.

Your close, More like $3,995 US dollars just for vanilla.

Link to comment
Share on other sites

Your close, More like $3,995 US dollars just for vanilla.

Ahh, OK. The last time I worked anywhere that used Vanilla AutoCAD, I was 18 and it was r2000.

Link to comment
Share on other sites

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.


×
×
  • Create New...