LISP例程帮助乐筑天下 - Powered by Discuz! Archiver

JSYoung81 发表于 2022-7-5 19:21:18

;;; THIS LISP WILL TAKE A LINE ON AN EXPLOPED
;;; PROFILE AND CALCULATE THE SLOPE
;;;
;;; THE LISP WILL ASK THE USER FOR THE RATIO
;;; OF THE PROFILE IN QUESTION (IE: 10:1 , ]
;;; 5:1 AND SO ON).
;;;
;;; NEXT THE USER WILL SELECT THE LINE IN QUESTION
;;; AND WILL PLACE THE SLOPE ON THE LINE AT THE MID-POINT
;;;
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.If not, see <http://www.gnu.org/licenses/>.
;;;
;;;
;;;
;;; SLOPELINE.LSP - COPYRIGHT 2014 BY J. SHAWN YOUNG
;;;
;;;
;;; VERSION 1.0 - INITIAL STATE
;;;
;;; VERSION 2.0 2014-11-26
;;; - RE-WROTE LISP TO BE MORE EFFICENT
;;; - NO MORE NEGITIVE SLOPES
;;; - ALLOW FOR SELECTION SETS OF LINES AND POLYLINES
;;;
;;; VERSION 2.1 2014-11-26
;;; - FIXED ISSUED WITH TEXT COMING IN UPSIDE DOWN
;;; IF LINE WAS DRAWN RIGHT TO LEFT
;;;
;;;
;;;
;;;

(DEFUN C:SLOPELINE (/    PT1 PT2 PT1_YPT1_XPT2_Y PT2_X RATIO
   SSET OBJ RISE RUN    SLOPEMIDPOINT ANG
   ANG2 LEN LST COUNTLAYERITEM COUNT CHECK
   N STYTEXT len2
   )
(vl-load-com)

;;; SELECTION SET ;;;

(SETQ SSET ;BEGIN SETQ
(SSGET ;BEGIN SSGET
'(
(-4 . "<XOR") ;BEGIN XOR
(0 . "LWPOLYLINE") ;GET POLYLINE
(0 . "LINE") ;GET LINE
(-4 . "XOR>") ;END XOR
)
) ;END SSGET
) ;END SETQ
(SETQ ;BEGIN SETQ
COUNT (SSLENGTH SSET) ;SET COUNT TO SELECTION SET LENGTH
N    0 ;N TO 0
RATIO 1
) ;END SETQ

;;; CHECK AND SET TEXT STYLE ;;;

(COMMAND "CMDECHO" 0) ;ECHO OFF

(setq stytext (tblsearch "style" "AE-25")) ;SEARCH FOR AE-25
(if ;BEGINS PROCESS FOR MAKING AE-25
(or
(= NIL stytext)
(/= (cdr (assoc 40 stytext)) 0.0)
)
(command "-style" "AE-25" "arial" "a" "y" "N" "2.5" "1.0" "0" "n"
   "n")
) ;END IF

;;; CHECK AND SET TEXT STYLE ;;;

(SETQ LAYER (TBLSEARCH "LAYER" "C-ANNO-TEXT"))
(IF
(= NIL LAYER)
(COMMAND "-LAYER" "N" "C-ANNO-TEXT" "S" "C-ANNO-TEXT" "C" "2" "" "")
)

(IF
(/= LAYER NIL)
(COMMAND "-LAYER" "S" "C-ANNO-TEXT" "")
)

;;; BEGIN MAIN FUNCTION ;;;

(WHILE ;BEGIN IF
(> COUNT N) ;LOGIC STATEMENT

(PROGN ;BEGIN PROGN

   (SETQ ;BEGIN SETQ
OBJ (SSNAME SSET N) ;GET NEXT OBJECT IN SELECTION SET
OBJ (VLAX-ENAME->VLA-OBJECT OBJ) ;CONVERT
check (vlax-get obj 'objectname) ;get object name
len (vla-get-length obj)
len2 (/ len 2)
   ) ;END SETQ

   (IF ;BEGIN IF FOR LINE
(= CHECK "AcDbLine") ;LOGIC STATEMENT
(progn
(setq
   ITEM (ENTGET (SSNAME SSET N))
   PT1(CDR (ASSOC 10 ITEM))
   PT2(CDR (ASSOC 11 ITEM))
)

)
   ) ;END IF FOR LINE

   (IF ;BEGIN IF FOR POLYLINE
(= CHECK "AcDbPolyline") ;LOGIC STATEMENT
(setq ;BEGIN SETQ
lst (vlax-get OBJ 'coordinates) ;GETS COORDINATES
LEN (VLA-GET-LENGTH OBJ) ;GET LENGTH
LEN2(/ LEN 2) ;HALVE THE LENGTH
pT1 (list (car lst) (cadr lst)) ;GETS START POINT
lst (reverse lst) ;REVERSE LIST
pT2 (list (cadr lst) (car lst)) ;GETS END POINT
)
   ) ;END IF POLYLINE

   (setq
ANG (ANGLE PT1 PT2) ;GET ANGLE IN RADS
ANG2(/ (* ANG 180) PI) ;CONVERTS ANGLE TO DEGREES
PT1_X (CAR PT1) ;GETS X OF START POINT
PT1_Y (CADR PT1) ;GETS Y OF START POINT
PT2_X (CAR PT2) ;GETS X OF END POINT
PT2_Y (CADR PT2) ;GETS Y OF END POINT
RUN (- PT2_X PT1_X) ;GETS RUN
RISE(/ (- PT2_Y PT1_Y) RATIO)
;GETS RISE AND DIVIDES BY RATIO
   ) ;END SETQ

   (IF (> 0 RUN) ;BEGIN IF
(SETQ RUN (* RUN -1)) ;IF RUN IS NEGITIVE TURN POSITIVE
   ) ;END IF

   (IF (> 0 RISE) ;BEGIN IF
(SETQ RISE (* RISE -1)) ;IF RUN IS NEGITIVE TURN POSITIVE
   ) ;END IF

   (SETQ ;BEGIN SETQ
SLOPE (* (/ RISE RUN) 100) ;GETS SLOPE
   )
   (IF (> 0 SLOPE) ;BEGIN IF
(SETQ SLOPE (* SLOPE -1)) ;IF RUN IS NEGITIVE TURN POSITIVE
   ) ;END IF

   (SETQ
MIDPOINT (POLAR PT1 ANG LEN2)

   ) ;END SETQ
(if
(< PT2_X PT1_X)
(SETQ ANG2 (- ANG2 180)
))

   (COMMAND "_TEXT" "J" "BC" MIDPOINT ANG2 ( RTOS len 2 3))
   (SETQ N (+ 1 N)) ;INCREASE N BY 1
) ;END PROGN

) ;END IF

(COMMAND "CMDECHO" 1)

(PRINC)
)
;END DEFUN

我写这篇文章是为了给出展开剖面上的斜率。对其进行修改，使其与您保持距离。

tjjackson 发表于 2022-7-5 19:26:27

令人惊叹的谢谢你的帮助。
有没有办法更改文字方向、文字样式、大小和精度？我们对这些图纸的标准是零旋转和四舍五入到最近的英尺。（例如：232’）

JSYoung81 发表于 2022-7-5 19:27:17

在此处更改文字样式和图层
;;; CHECK AND SET TEXT STYLE ;;;

(COMMAND "CMDECHO" 0) ;ECHO OFF

(setq stytext (tblsearch "style" "AE-25")) ;SEARCH FOR AE-25
(if ;BEGINS PROCESS FOR MAKING AE-25
(or
(= NIL stytext)
(/= (cdr (assoc 40 stytext)) 0.0)
)
(command "-style" "AE-25" "arial" "a" "y" "N" "2.5" "1.0" "0" "n"
   "n")
) ;END IF
;;; CHECK AND SET TEXT STYLE ;;;

(SETQ LAYER (TBLSEARCH "LAYER" "C-ANNO-TEXT"))
(IF
(= NIL LAYER)
(COMMAND "-LAYER" "N" "C-ANNO-TEXT" "S" "C-ANNO-TEXT" "C" "2" "" "")
)

(IF
(/= LAYER NIL)
(COMMAND "-LAYER" "S" "C-ANNO-TEXT" "")

在此处为您的旋转和感知进行更改

(if
(< PT2_X PT1_X)
(SETQ ANG2 (- ANG2 180)
))

   (COMMAND "_TEXT" "J" "BC" MIDPOINT ANG2 ( RTOS len 2 3))
   (SETQ N (+ 1 N)) ;INCREASE N BY 1
) ;END PROGN

) ;END IF

将ang2更改为旋转角度，将3更改为0设置感知。

Stefan BMR 发表于 2022-7-5 19:29:43

嗨tj

这里是一个lisp，用于在每个可能的对极-pevious_极之间绘制线。
它还写下它旁边每一行的长度；该数字表示三维线的实际长度。它适用于您的图形，分解一次，因此每个极点是一个独立的块。
它使用直线，因为块位于特定高程，因此多段线只能投影到平面中，例如z=0。即便如此，也很难找到正确的极点序列，因为有许多交点，极点的编号顺序不明确，并且使用了字母数字系统，这使得排序更加困难。
文本，表示行的长度。。。我不熟悉英制单位，因此文字高度是硬编码的（5个单位，就像我在dwg中找到的文字）。如果文本高度取决于特定设置（如ltscale、dimscale、注释比例等），我可以更改它。

(defun c:pole_line ( / *error* acDoc ms ht ss i e p a pn pp pole_list prev_list p1 p2 pt txt)
(setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
;;;(setq ht (/ (if (zerop (getvar 'measurement)) 0.1 2.5) (cond ((getvar 'cannoscalevalue)) (1.0))))
(setq ht 5.0)
(vla-startundomark acDoc)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(vla-endundomark acDoc)
(princ)
)

(if
(setq ss (ssget '((0 . "INSERT"))))
(progn
(repeat (setq i (sslength ss))
   (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
         p (vlax-get e 'InsertionPoint)
         a (vlax-invoke e 'GetAttributes)
         pn nil pp nil
         )
   (foreach x a
      (cond
      ((eq (vla-get-tagstring x) "POLE_NUM")
         (setq pn (vla-get-textstring x))
         )
      ((eq (vla-get-tagstring x) "PREV_POLE")
         (setq pp (vla-get-textstring x))
         )
      )
      )
   (if pn (setq pole_list (cons (list pn pp p) pole_list))
      (if pp (setq prev_list (cons (list pp p) prev_list)))
      )
   )
(foreach p2 pole_list
   (if
      (or
      (setq p1 (assoc (cadr p2) pole_list))
      (setq p1 (assoc (cadr p2) prev_list))
      )
      (progn
      (setq p1 (last p1) p2 (last p2)
            a(angle p1 p2)
            a(if (< (* pi 0.5) a (* pi 1.25)) (- a (/ pi 2.0)) (+ a (/ pi 2.0)))
            pt (polar (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2) a (* ht 2.0))
            )
      (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
      (setq txt (vla-addtext ms (rtos (distance p1 p2) 2 0) (vlax-3D-point 0.0 0.0 0.0) ht))
      (vla-put-alignment txt acalignmentmiddlecenter)
      (vla-put-textalignmentpoint txt (vlax-3D-point pt))
      )
   )
)
)
)
(vla-endundomark acDoc)
(princ)
)

tjjackson 发表于 2022-7-5 19:32:58

斯特凡，

这真是难以置信。它工作得很好。您可以将其更改为绘制多段线和测量二维点吗？我们正在测量跨度长度，需要2D距离。如果线宽可以是1，那就太好了。此外，我们可以将文本大小更改为10并添加ft标记（'）后缀吗？如果没有，是否可以将文字更改为标注文字，并使用dimstyle添加ft标记？

非常感谢你的帮助。这将节省很多时间。

Stefan BMR 发表于 2022-7-5 19:36:38

不客气，tj。

您可以考虑完成文本高度和英尺标记。
我之前的帖子解释了我为什么用台词。但是，我可以切换到0.0高程的多段线，但每个多段线只有一段（意味着它们不在单个对象中连接）。这对你有好处吗？

tjjackson 发表于 2022-7-5 19:40:17

完美的是的，请切换到多段线。我们希望它们是单独的部分，而不是一个实体。再次感谢你的帮助。

Stefan BMR 发表于 2022-7-5 19:45:07

那么图层、颜色呢？

tjjackson 发表于 2022-7-5 19:46:26

我喜欢它目前的设置方式。它将线条和文字放置在当前层中。

Stefan BMR 发表于 2022-7-5 19:51:36

给你。。。
(defun c:pole_line ( / *error* acDoc ms ht ss i e p a pn pp pole_list prev_list p1 p2 pt txt)
(setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
(setq ms (getvar 'ctab))
(vla-startundomark acDoc)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(vla-endundomark acDoc)
(princ)
)

(if
(setq ss (ssget '((0 . "INSERT"))))
(progn
(repeat (setq i (sslength ss))
   (setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
         p (reverse (cdr (reverse (vlax-get e 'InsertionPoint))))
         a (vlax-invoke e 'GetAttributes)
         pn nil pp nil
         )
   (foreach x a
      (cond
      ((eq (vla-get-tagstring x) "POLE_NUM")
         (setq pn (vla-get-textstring x))
         )
      ((eq (vla-get-tagstring x) "PREV_POLE")
         (setq pp (vla-get-textstring x))
         )
      )
      )
   (if pn (setq pole_list (cons (list pn pp p) pole_list))
      (if pp (setq prev_list (cons (list pp p) prev_list)))
      )
   )
(foreach p2 pole_list
   (if
      (or
      (setq p1 (assoc (cadr p2) pole_list))
      (setq p1 (assoc (cadr p2) prev_list))
      )
      (progn
      (setq p1 (last p1) p2 (last p2)
            a(angle p1 p2)
            a(if (< (* pi 0.5) a (* pi 1.25)) (- a (/ pi 2.0)) (+ a (/ pi 2.0)))
            pt (polar (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2) a 15.0)
            )
      (entmake
         (list
            '(0 . "LWPOLYLINE")
            '(100 . "AcDbEntity")
            (cons 410 ms)
            '(100 . "AcDbPolyline")
            '(90 . 2)
            '(70 . 0)
            (cons 10 p1)
            '(40 . 1.0)
            '(41 . 1.0)
            (cons 10 p2)
            '(40 . 1.0)
            '(41 . 1.0)
            '(210 0.0 0.0 1.0)
         )
      )
      (entmake
         (list
            '(0 . "TEXT")
            '(100 . "AcDbEntity")
            (cons 410 ms)
            '(100 . "AcDbText")
            (cons 10 pt)
            '(40 . 10.0)
            (cons 1 (strcat (rtos (distance p1 p2) 2 0) "'"))
            '(50 . 0.0)
            (cons 7 (getvar "textstyle"))
            '(72 . 1)
            (cons 11 pt)
            '(73 . 2)
         )
      )
      )
   )
)
)
)
(vla-endundomark acDoc)
(princ)
)

等待评论，TJ。。。

页: 1 [2]

乐筑天下's Archiver