更新a。lsp帮助乐筑天下 - Powered by Discuz! Archiver

mnyrac 发表于 2022-7-6 00:07:07

非常感谢。。。代码对我来说是新的，我想了解更多关于它和如何使用它。

alanjt 发表于 2022-7-6 00:11:40

我决定找点乐子。我不处理表（c3d有更好的动态表），所以我从那个花边抢走了。

(defun c:Bearings (/ *error* _draw _angle _fix _dist cmd dzn ucs first lst pt finalList tablePoint
               row tsize table)
;; Point connections to Table with bearings and distances
;; Alan J. Thompson, 2013.05.29

(vl-load-com)

(defun *error* (msg)
(redraw)
(and ucs (vl-cmdf "_.UCS" "_P"))
(and cmd (setvar 'CMDECHO cmd))
(and dzn (setvar 'DIMZIN dzn))
(and *AcadDoc* (vla-endundomark *AcadDoc*))
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
(progn (vl-bt) (princ (strcat "\nError: " msg)))
)
)

(defun _draw (lst)
(redraw)
(mapcar (function (lambda (a b) (grdraw a b 3 1))) (cons (last lst) lst) lst)
)

(defun _angle (p1 p2 / a)
(setq a (angtos (angle p1 p2) 4 4))

(cond ((cdr (assoc a '(("N" . "NORTH") ("S" . "SOUTH") ("E" . "EAST") ("W" . "WEST")))))
      ((_fix a))
)
)

(defun _fix (s / i l a)
(setq s (vl-string-subst "°" "d" s))
(foreach v '(" " "°" "'" "\"" " ")
(setq a (substr s 1 (setq i (vl-string-search v s))))
(if (and (member v '("°" "'" "\"")) (eq (strlen a) 1))
   (setq a (strcat "0" a))
)
(setq l (cons a l)
      s (substr s (+ i 2))
)
)
(apply 'strcat
      (apply 'append
            (mapcar (function (lambda (a b) (list a b)))
                     (reverse (cons s l))
                     '(" " "°" "'" "\" " "" "")
            )
      )
)
)

(defun _dist (p1 p2) (strcat (rtos (distance p1 p2) 2 2) "'"))

(vla-startundomark
(cond (*AcadDoc*)
      ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
)
)

(setq dzn (getvar 'DIMZIN))
(setvar 'DIMZIN 0)

(if (zerop (getvar 'WORLDUCS))
(progn (setq cmd (getvar 'CMDECHO))
      (setvar 'CMDECHO 0)
      (vl-cmdf "_.UCS" "")
)
)

(redraw)

(initget 4)
(setq *Bearings:Count*
   (cond ((getint (strcat "\nSpecify starting number <"
                           (itoa (cond (*Bearings:Count*)
                                       ((setq *Bearings:Count* 1))
                                 )
                           )
                           ">: "
                  )
            )
         )
         (*Bearings:Count*)
   )
)

(setq first (itoa *Bearings:Count*))

(if (car (setq lst (list (getpoint
                        (strcat "\nSpecify point for number " (itoa *Bearings:Count*) ": ")
                     )
               )
      )
)
(progn
(while
   (setq pt (getpoint (car lst)
                     (strcat "\nSpecify point for number "
                              (itoa (1+ *Bearings:Count*))
                              ": "
                     )
            )
   )

   (_draw (setq lst (cons pt lst)))

   (setq finalList (cons (list (strcat (itoa *Bearings:Count*)
                                       " - "
                                       (itoa (setq *Bearings:Count* (1+ *Bearings:Count*)))
                                 )
                                 (_angle (cadr lst) (car lst))
                                 (_dist (cadr lst) (car lst))
                           )
                           finalList
                     )
   )
)

(if (and finalList (setq tablePoint (getpoint "\nSpecify insertion point for table: ")))
   (progn

      (if (> (length finalList) 1)
      (setq finalList (cons (list (strcat (itoa *Bearings:Count*) " - " first)
                                    (_angle (car lst) (last lst))
                                    (_dist (car lst) (last lst))
                              )
                              finalList
                        )
      )
      )

      (setq finalList (reverse finalList))

      (setq row 1
            tsize (getvar 'TEXTSIZE)
            table (vlax-invoke
                  (vlax-get-property
                     *AcadDoc*
                     (if (eq (getvar 'CVPORT) 1)
                        'PaperSpace
                        'ModelSpace
                     )
                  )
                  'AddTable
                  tablePoint
                  (+ (length finalList) 2)
                  3
                  (* tsize 2.)
                  (* tsize 15.)
                  )
      )

      (vla-put-regeneratetablesuppressed table :vlax-true)
      (vla-settextheight table actitlerow tsize)
      (vla-settextheight table acheaderrow tsize)
      (vla-settextheight table acdatarow tsize)
      (vla-put-vertcellmargin table (/ tsize 4.25))
      (vla-settext table 0 0 "COURSE TABLE")
      (vla-settext table 1 0 "COURSE")
      (vla-settext table 1 1 "BEARING")
      (vla-settext table 1 2 "DISTANCE")

      (foreach item finalList
      (setq row (1+ row))
      (foreach n '(0 1 2)
         (vla-settext table row n (nth n item))
         (vla-setcellalignment table row n acMiddleCenter)
      )
      )

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

(*error* nil)
(princ)
)

mnyrac 发表于 2022-7-6 00:15:31

很好，那比另一个好得多。唯一的问题是，它仍在接近这个数字：

1000-1001
1001-1002
1002-1003
1003-1000

你们可能知道如何在睡梦中写这些东西。。。

alanjt 发表于 2022-7-6 00:17:12

放屁。我一定错过了，你不想让它关上。午饭后我会发些东西。我得吃饭了！

alanjt 发表于 2022-7-6 00:20:06

呃，只花了一秒钟。。。

(defun c:Bearings (/ *error* _draw _angle _fix _dist cmd dzn ucs first lst pt finalList tablePoint
               row tsize table)
;; Point connections to Table with bearings and distances
;; Alan J. Thompson, 2013.05.29

(vl-load-com)

(defun *error* (msg)
(redraw)
(and ucs (vl-cmdf "_.UCS" "_P"))
(and cmd (setvar 'CMDECHO cmd))
(and dzn (setvar 'DIMZIN dzn))
(and *AcadDoc* (vla-endundomark *AcadDoc*))
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
(progn (vl-bt) (princ (strcat "\nError: " msg)))
)
)

(defun _draw (lst)
(redraw)
(mapcar (function (lambda (a b) (grdraw a b 3 1))) lst (cdr lst))
)

(defun _angle (p1 p2 / a)
(setq a (angtos (angle p1 p2) 4 4))

(cond ((cdr (assoc a '(("N" . "NORTH") ("S" . "SOUTH") ("E" . "EAST") ("W" . "WEST")))))
      ((_fix a))
)
)

(defun _fix (s / i l a)
(setq s (vl-string-subst "°" "d" s))
(foreach v '(" " "°" "'" "\"" " ")
(setq a (substr s 1 (setq i (vl-string-search v s))))
(if (and (member v '("°" "'" "\"")) (eq (strlen a) 1))
   (setq a (strcat "0" a))
)
(setq l (cons a l)
      s (substr s (+ i 2))
)
)
(apply 'strcat
      (apply 'append
            (mapcar (function (lambda (a b) (list a b)))
                     (reverse (cons s l))
                     '(" " "°" "'" "\" " "" "")
            )
      )
)
)

(defun _dist (p1 p2) (strcat (rtos (distance p1 p2) 2 2) "'"))

(vla-startundomark
(cond (*AcadDoc*)
      ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
)
)

(setq dzn (getvar 'DIMZIN))
(setvar 'DIMZIN 0)

(if (zerop (getvar 'WORLDUCS))
(progn (setq cmd (getvar 'CMDECHO))
      (setvar 'CMDECHO 0)
      (vl-cmdf "_.UCS" "")
)
)

(redraw)

(initget 4)
(setq *Bearings:Count*
   (cond ((getint (strcat "\nSpecify starting number <"
                           (itoa (cond (*Bearings:Count*)
                                       ((setq *Bearings:Count* 1))
                                 )
                           )
                           ">: "
                  )
            )
         )
         (*Bearings:Count*)
   )
)

(setq first (itoa *Bearings:Count*))

(if (car (setq lst (list (getpoint
                        (strcat "\nSpecify point for number " (itoa *Bearings:Count*) ": ")
                     )
               )
      )
)
(progn
(while
   (setq pt (getpoint (car lst)
                     (strcat "\nSpecify point for number "
                              (itoa (1+ *Bearings:Count*))
                              ": "
                     )
            )
   )

   (_draw (setq lst (cons pt lst)))

   (setq finalList (cons (list (strcat (itoa *Bearings:Count*)
                                       " - "
                                       (itoa (setq *Bearings:Count* (1+ *Bearings:Count*)))
                                 )
                                 (_angle (cadr lst) (car lst))
                                 (_dist (cadr lst) (car lst))
                           )
                           finalList
                     )
   )
)

(if (and finalList (setq tablePoint (getpoint "\nSpecify insertion point for table: ")))
   (progn
      (setq finalList (reverse finalList)
            row    1
            tsize (getvar 'TEXTSIZE)
            table (vlax-invoke
                        (vlax-get-property
                        *AcadDoc*
                        (if (eq (getvar 'CVPORT) 1)
                           'PaperSpace
                           'ModelSpace
                        )
                        )
                        'AddTable
                        tablePoint
                        (+ (length finalList) 2)
                        3
                        (* tsize 2.)
                        (* tsize 15.)
                     )
      )

      (vla-put-regeneratetablesuppressed table :vlax-true)
      (vla-settextheight table actitlerow tsize)
      (vla-settextheight table acheaderrow tsize)
      (vla-settextheight table acdatarow tsize)
      (vla-put-vertcellmargin table (/ tsize 4.25))
      (vla-settext table 0 0 "COURSE TABLE")
      (vla-settext table 1 0 "COURSE")
      (vla-settext table 1 1 "BEARING")
      (vla-settext table 1 2 "DISTANCE")

      (foreach item finalList
      (setq row (1+ row))
      (foreach n '(0 1 2)
         (vla-settext table row n (nth n item))
         (vla-setcellalignment table row n acMiddleCenter)
      )
      )

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

(*error* nil)
(princ)
)

现在，吃东西的时间到了。

mnyrac 发表于 2022-7-6 00:23:08

谢谢谢谢。。。总有一天我会像你们这些特别聪明的人一样学会如何做到这一点。

alanjt 发表于 2022-7-6 00:28:51

不客气。

pBe 发表于 2022-7-6 00:30:40

艾伦，你忙了12个小时了。。。。砰！我对使用grdraw有相同的想法，唯一的问题是为什么OP使用端点捕捉？我猜想这些线是存在的，如果是这样，那么就不需要grdraw了？

另一种方法是选择直线/多段线或拾取起点/终点，然后选择对象[如果目标点位于段之间]

随便。Alanjt的荣誉

只要在这个论坛上闲逛，我相信你一定会成功的。

neophoible 发表于 2022-7-6 00:34:38

是的，这不是不可能的，但它只会发生在那种闲逛的时候，包括大量持续的艰苦工作！
是的，同意。

alanjt 发表于 2022-7-6 00:35:36

哈哈。昨天早上我有点时间消磨。

伙计，我希望他不是在选台词，或者这整件事都很愚蠢，因为他有civil 3d。

页: 1 [2]

乐筑天下's Archiver