[编程交流] 将地块/多边形数据生成到t

(if
     (and (select Text)                                ; "Ldx_Data"                        entsel / ssget with filter
          (Pick Start point))                                ; To determine Point nos 1         getpoint
             (progn
             (while  (Pick Next point [ Start point ])        ;                                getpoijnt
             (distance SP NP)                                ; Value for distance                distance
             (angle SP NP)                                ; Value for Bearing                angle
             (convert distance to string)                ; For table                         rtos / strcat
             (convert angle to string)                        ; For table                         angtos
      (replace "d" with "%%d")                        ; vl-string-subst
             (pass the values to a list)                ; cons / list
             )
          (Pick Insertion point for table)                ;                                getpoint 
(Insert Attribute Block for Lot Title)                        ; Native insert command / Attreq
       [Values: from (select Text) ]                        ; cdr / assoc / entget
(Insert Attribute Block for LINE/BEARING/DISTANCE)        ; Native insert command / Attreq / polar
       [Values: from (convert distance to string)         ; variable
              (convert angle to string) ]        ; variable
       )
     )
     

(vl-load-com)
(defun C:TD (/ *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)
    )
 (command "layer" "m" "Technical Description" "") 
 (command "layer" "c" "7" "Technical Description" "") 
 (command "color" "bylayer")
 (initget 1) 
(setq osm (getvar "osmode"))
(setvar "osmode" 1)
(setq cnt 1)
(while (setq pt (getpoint
    (strcat "\n  Specify Corner #"
     (itoa cnt)
     " (hit Enter after the last corner) >> ")))
  (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 2))
  (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 of Technical Descriptions"))
(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)
)