方位和距离

BIGAL · 发表于 2022-7-6 00:27:14

好的，您需要这些代码位的相反部分，如下所示

(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(princ) ; dummy for else
(Alert "You need to be in model space for this option")
(exit)
; same with this
(setq curspace (vla-get-modelspace doc))

prodromosm · 发表于 2022-7-6 00:31:23

我做了更改，但不起作用？

copy

; dwg index to a table
; by Alan H NOV 2013
(defun AH:dwgindex (/ doc objtable ss1 lay ans ans2 plotabs ss1 tag2 tag3 list1 list2 curlayout colwidth numcolumns numrows INC rowheight )
(vl-load-com)
(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(princ) ; dummy for else
(Alert "You need to be in model space for this option")
(exit)
) ; end progn
) ; end if model
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
; same with this
(setq curspace (vla-get-modelspace doc))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  "))) 
;(setq pt1 (vlax-3d-point '(0 0 0))) 
; for testing
; read values from title blocks
;(setq bname "DA1DRTXT")
(setq bname "COGG_TITLE")
(setq tag2 "DRG_NO") ;attribute tag name
(setq tag3 "WORKS_DESCRIPTION") ;attribute tag name
(setq ss1 (ssget "x"  (list (cons 0 "INSERT") (cons 2 bname))))
(setq INC (sslength ss1))  
(repeat INC
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 (SETQ INC (- INC 1)) )) 'getattributes) 
       (if (= tag2 (strcase (vla-get-tagstring att)))
           (progn
           (setq ans (vla-get-textstring att))
           (if (/= ans NIL)
           (setq list1 (cons ans list1))
           ) ; if 
           ); end progn
         ) ; end if
       (if (= tag3 (strcase (vla-get-tagstring att)))
         (progn
         (setq ans2 (vla-get-textstring att))
         (if (/= ans2 NIL)
             (setq list2 (cons ans2 list2)) 
          ) ; end if
          ) ; end progn
 ) ; end if tag3 
) ; end foreach
) ; end repeat
(setvar 'ctab curlayout)
(command "Zoom" "E")
(command "regen")
(reverse list1)
;(reverse list2)
; now do table 
(setq numrows (+ 2 (sslength ss1)))
(setq numcolumns 2)
(setq rowheight 0.2)
(setq colwidth 130)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "DRAWING REGISTER")
(vla-settext objtable 1 0 "DRAWING NUMBER") 
(vla-settext objtable 1 1 "DRAWING TITLE") 
(SETQ X 0)
(SETQ Y 2)
(REPEAT (sslength ss1)
 (vla-settext objtable Y 0 (NTH X LIST1))
 (vla-settext objtable Y 1 (NTH X LIST2))
 (vla-setrowheight objtable y 10)
 (SETQ X (+ X 1))
 (SETQ Y (+ Y 1))
)
(vla-setcolumnwidth objtable 0 55)
(vla-setcolumnwidth objtable 1 130)
(command "_zoom" "e")
); end AH defun
(AH:dwgindex)
(princ)

BIGAL · 发表于 2022-7-6 00:34:36

我发布的例子只是展示了如何做一些事情的方法，比如你想要什么，而不是对你的请求的一个精确的解决方案——代码必须更改。

CADTUTOR不是一个免费的网站，任何人都可以访问并获得一个专门编写的soloution。如果我能抽出时间，我会更改代码。

你已经贴了很多次了，所以现在可能是你开始尝试写一些Lisp程序的东西的时候了。这里有很多人可以帮助并且非常愿意帮助那些自助的人。

pBe · 发表于 2022-7-6 00:37:29

为了好玩

copy

(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc cnt data  p1 p2 p1l p2l p3 ip data num)
 (vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
 
(defun _AttFunc  (en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
                 (if (and lst (setq v (assoc (car vals) lst)))
                         (vla-put-textstring at (cadr v))) vals))
                     (vlax-invoke (if (eq (type en) 'VLA-OBJECT)
                                 en (vlax-ename->vla-object en)) 'Getattributes)
         )
 )  
(if (not (member "geomcal.arx" (arx)))
   (arxload "geomcal")
   )
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
   Space (if (= (getvar "CVPORT") 1)
             (vla-get-PaperSpace ADoc)
             (vla-get-ModelSpace ADoc)
         ))
                                 
      
(setq cnt -1 num 0)  
(if (and (vl-every '(lambda (b)
     (setq cnt (1+ cnt))                 
     (tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT" "TITLE" "DATA")))
(setq p1 (getpoint "\nPick Base Referene point: "))
(setq p2 (getpoint p1 "\nPick Second point: "))
(setq p1l (getstring "\nEnter Label of BP: "))
(setq p2l (getstring "\nEnter Label of SP: "))
 )
         (progn
  (setq angs (If (> (car p1)(car p2))
                    "ang(p1,p3,p2)" "ang(p1,p2,p3)"))
     (setq  data nil)
          (vlax-invoke space 'AddLine p1 p2)
          (_AttFunc (_Insert space "STATION" p1 ) (list (list "POINT" (strcase p1l))));<-- Optional
          (_AttFunc (_Insert space "STATION" p2 ) (list (list "POINT" (strcase p2l))));<-- Optional
        (while (setq p3 (getpoint p1 (strcat "\nPick point " (itoa (setq num (1+ num)))":")))
;;;                Place here DimeAng line <Optional>                ;;;
;;;                                                                ;;;
        (entmakex (list (cons 0 "LINE")'(6 . "HIDDEN2")'(8 . "Distance")
                 (cons 10 p1) (cons 11 p3)))
          (_AttFunc (_Insert space "POINT" p3 ) (list (list "POINT" (itoa num))))
        (setq data (cons (list
                           (itoa num)
                           (Strcat
                             (rtos
                               (cvunit (c:cal angs)
                                       "degree" "grad") 2 4)
                             "g"
                           )
                           (rtos (distance p1 p3) 2 2)
                         ) data))
          )
          (setq ip (getpoint  "\nPick Base point for Table: "))
          (_AttFunc (_Insert space "TITLE" ip )
                  (list (list "TITLE" (strcat "FROM " (strcase p1l) " -> " (strcase p2l)))))
  (foreach itm (reverse data)
        (_AttFunc (_Insert space "DATA" ip )
                  (list (list "NUM" (car itm))
                        (list "BEARING" (cadr itm))
                        (list "DISTANCE" (last itm))))
            (setq ip (polar ip (* pi 1.5) 1.0)))
 )
  (princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
 )
(princ)
)

prodromosm · 发表于 2022-7-6 00:37:58

你好，谢谢你的代码，但如果可以的话，我还需要一些修改

1）我想要DiaTabs。当我“为表格拾取基点：”
2）用同样的方法我“选择基准参考点：”并选择块并写入块的文本，用同样的方法当我选择文本块时写入文本的名称。因为在某些情况下，项目编号的顺序不是（1、2、3、4、5……100等），而是随机的（50、48、32、60、72、34、15.22……等）
DiaTabs。图纸

pBe · 发表于 2022-7-6 00:43:43

我试过这个，但我有一个小错误。。。。
我仍然有这个问题

2）用同样的方法我“选择基准参考点：”并选择块并写入块的文本，用同样的方法当我选择文本块时写入文本的名称。因为在某些情况下，项目编号的顺序不是（1、2、3、4、5……100等），而是随机的（50、48、32、60、72、34、15.22……等）

copy


(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc _getprop cnt data space ob1 ob2 ob3  p1 p2 p3 ip  num)
(vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
(defun _AttFunc  (en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
                 (if (and lst (setq v (assoc (car vals) lst)))
                         (vla-put-textstring at (cadr v))) vals))
                     (vlax-invoke (if (eq (type en) 'VLA-OBJECT)
                                 en (vlax-ename->vla-object en)) 'Getattributes)
         )
 )
(defun _getprop        (msg bn tg )
 (prompt msg)
 (if (setq
s (ssget "_:S:L" (list '(0 . "INSERT") '(66 . 1) (cons 2 bn)))
     )
   (setq att (_AttFunc (ssname s 0) nil)
  ip (cdr (assoc 10 (entget (ssname s 0)))))
  (progn (princ "\n<<Invlaid Seletion>>") (_getprop msg bn tg))
   )
 (list ip (assoc tg att) )
)  (if (not (member "geomcal.arx" (arx)))
   (arxload "geomcal")
   )
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
   Space (if (= (getvar "CVPORT") 1)
             (vla-get-PaperSpace ADoc)
             (vla-get-ModelSpace ADoc)
         ))
(setq cnt -1 num 1)  
(if (vl-every '(lambda (b)
     (setq cnt (1+ cnt))                 
     (tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT" "TITLE" "DATA")))
(progn
         (setq ob1 (_GETPROP "\nPick Base Referene point: " "STATION" "POINT" ))
(setq ob2 (_GETPROP "\nPick Second point: " "STATION" "POINT" ))
  (setq p1 (Car ob1) p2 (car ob2))
  (setq angs (If (> (car p1)(car p2))
                    "ang(p1,p3,p2)" "ang(p1,p2,p3)"))
     (setq  data nil)
        (while  (setq p3 (getpoint p1 (strcat "\nPick point " (itoa num)":")))
                  (if (and (cadr (sssetfirst nil  (ssget  "_C" p3 p3 '((2 . "POINT")))))
                         (setq ob3 (_GETPROP (strcat "\nPick point " (itoa num)":")
                                    "POINT" "POINT" )))
                  (progn (setq p3 (car ob3))
                        (setq data (cons (list
                           (itoa num)
                           (Strcat
                             (rtos
                               (cvunit (c:cal angs)
                                       "degree" "grad") 2 4)
                             "g"
                           )
                           (rtos (distance p1 p3) 2 2)
                         ) data))
                          (setq num (1+ num))
                          )
                  (princ "\nBlock "POINT" Not found"))
          )
  
          (setq ip (getpoint  "\nPick Base point for Table: "))
          (_AttFunc (_Insert space "TITLE" ip )
                  (list (list "TITLE" (strcat "FROM " (strcase (cadadr ob1)) " -> " (strcase (cadadr ob2))))))
  (foreach itm (reverse data)
        (_AttFunc (_Insert space "DATA" ip )
                  (list (list "NUM" (car itm))
                        (list "BEARING" (cadr itm))
                        (list "DISTANCE" (last itm))))
            (setq ip (polar ip (* pi 1.5) 1.0)))
 )
  (princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
 )
(princ)
)