Тема: Маркировка сети труб (labeling pipe network)
В процессе работы сталкнулся с проблемой маркировки сети труб. В моём случае, в Автокаде, каждая труба представлена в виде полилинии или линии. Каждая из этих полилиний находятся в слое именем которого является диаметр трубы. Задача промаркировать полилинии следующим образом: вид трубы...диаметр...длинна
где:
вид - задаётся в отдельном всплывающем окне
диаметр - берется из имени слоя
длинна - длинна полилинии (количество цифр после запятой определяется величиной по умолчанию, в меню Units)
Конечный вид маркировки (label-a): PVC d75 130 m
;| Created by Mikhael Burshtein 09/04/2008 The program for automatic creation labels of pipes. The label include 4 parts: 1) Prefix - to present type of pipe. 2) Diametr - that will be taken from name of layer. 3) Length - that will be taken from length of polyline. There are 3 available types: "LINE", "LWPOLYLINE", "POLYLINE". 4) Suffix - the units of length of pipes, for example (m). Restrictions: - this lisp available for "LINE", "LWPOLYLINE", "POLYLINE" - entities - this lisp available since from AutoCad 2000 and above |; (defun c:l2pipe () (vl-load-com) (make-lib-dial) (run-lib-dial) (setq sset (ssget '((-4 . "<OR")(0 . "LINE") (0 . "LWPOLYLINE") (0 . "POLYLINE")(-4 . "OR>")))) (foreach item (mapcar (function vlax-ename->vla-object) (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sset) ) ;_ mapcar ) ;_ vl-remove-if ) ;_ mapcar ;;; (setq sum_len (if (vlax-property-available-p item 'length) ;;; (vla-get-length item) ;;; ) ;_ if ;;; ;;; ) ;_ setq ;;for 2002 and -> (make-lib-dial) (setq Param (vl-catch-all-apply 'vlax-Curve-getEndParam (list item))) (if (not (vl-catch-all-error-p Param)) (setq sum_len (vlax-curve-getDistAtParam item Param)) );;end if (setq string (strcat inputpref " " "%%C" (vla-get-layer item) " " (rtos sum_len) inputsuff)) (setq ptS (vlax-curve-getStartPoint item) ptE (vlax-curve-getEndPoint item) ptM (vlax-curve-getPointAtDist item (* 0.5 (vlax-curve-getDistAtPoint item ptE))); 50% of the length = MID ;;; ptS (trans ptS 0 1); to UCS ;;; ptM (trans ptM 0 1) ) (setq pl "AcDbPolyline" 2d "AcDb2dPolyline" ln "AcDbLine") (cond ((= (vlax-get-property item "ObjectName") pl) ;retrieve the coordinates (setq thelist (vlax-get-property item 'coordinates)) ;convert to a list (setq thelist (vlax-safearray->list (variant-value thelist))) (setq thelist (cddr thelist));;return all the vertex but the two first! ;zero the counter (setq n 0);;begin (setq prv_xval (nth 0 ptS) prv_yval (nth 1 ptS)) (setq pt_mx (nth 0 ptM) pt_my (nth 1 ptM)) (repeat (/ (length thelist) 2) ;get the x coordinate (setq xval (nth n thelist)) ;increase the counter (setq n (1+ n)) ;get the y coordinate (setq yval (nth n thelist)) (setq n (1+ n)) (setq tmp (- (* (- pt_mx xval) (- pt_my prv_yval)) (* (- pt_my yval) (- pt_mx prv_xval)))) (setq tmp1 (+ (* (- pt_mx xval)(- pt_mx prv_xval)) (* (- pt_my prv_yval) (- pt_my yval)))) (if (AND (<= tmp1 0) (<= tmp 0.0000001)) (progn ;;------------------------------ ;;------------------------------ (calc) ;;------------------------------ ;;------------------------------ );;progn );;end if (setq prv_xval xval prv_yval yval) );;end repeat ) ((= (vlax-get-property item "ObjectName") 2d) ;retrieve the coordinates (setq thelist (vlax-get-property item 'coordinates)) ;convert to a list (setq thelist (vlax-safearray->list (variant-value thelist))) (setq thelist (cddr thelist));;return all the vertex but the two first! ;zero the counter (setq n 0);;begin (setq prv_xval (nth 0 ptS) prv_yval (nth 1 ptS)) (setq n (1+ n)) (setq pt_mx (nth 0 ptM) pt_my (nth 1 ptM)) (repeat (/ (length thelist) 3) ;get the x coordinate (setq xval (nth n thelist)) ;increase the counter (setq n (1+ n)) ;get the y coordinate (setq yval (nth n thelist)) (setq n (1+ n)) (setq n (1+ n)) (setq tmp (- (* (- pt_mx xval) (- pt_my prv_yval)) (* (- pt_my yval) (- pt_mx prv_xval)))) (setq tmp1 (+ (* (- pt_mx xval)(- pt_mx prv_xval)) (* (- pt_my prv_yval) (- pt_my yval)))) (if (AND (<= tmp1 0) (<= tmp 0.0000001)) (progn ;;------------------------------ ;;------------------------------ (calc) ;;------------------------------ ;;------------------------------ );;progn );;end if (setq prv_xval xval prv_yval yval) );;end repeat ) ((= (vlax-get-property item "ObjectName") ln) (setq prv_xval (nth 0 ptS) prv_yval (nth 1 ptS)) (setq pt_mx (nth 0 ptM) pt_my (nth 1 ptM)) (setq xval (nth 0 ptE)) (setq yval (nth 1 ptE)) (princ prv_xval)(princ "---")(princ prv_yval)(princ "\n") (princ xval)(princ "---")(princ yval)(princ "\n") (princ pt_mx)(princ "---")(princ pt_my)(princ "\n") (setq tmp (- (* (- pt_mx xval) (- pt_my prv_yval)) (* (- pt_my yval) (- pt_mx prv_xval)))) (setq tmp1 (+ (* (- pt_mx xval)(- pt_mx prv_xval)) (* (- pt_my prv_yval) (- pt_my yval)))) (if (AND (<= tmp1 0) (<= tmp 0.0000001)) (progn (calc) );;progn );;end if ) );;cond ) ;_ foreach (princ) ) ;_ defun (defun calc() (setq endp1 (list prv_xval prv_yval 0) endp2 (list xval yval 0)) (SETQ lang (ANGLE endp1 endp2) chkang (+ lang (GETVAR "viewtwist")) ldist (DISTANCE (LIST (CAR endp1) (CADR endp1)) (LIST (CAR endp2) (CADR endp2))) );;_ end of setq (IF (AND (> chkang 1.868) (< chkang 5.01)) (SETQ tang (ANGTOS (+ PI lang) 1 4) tentang (+ PI lang) osang (+ (* PI 1.5) lang)) ;_ end of setq (SETQ tang (ANGTOS lang 1 4) tentang lang osang (+ (* PI 0.5) lang)) ;_ end of setq );if (SETQ tstpt (list (nth 0 ptM) (nth 1 ptM) 0)) (SETQ ptabv (POLAR (POLAR endp1 lang (DISTANCE endp1 tstpt)) osang (* 1.1 (atof inputhgttxt))) ;polar ptabv2 (POLAR ptabv osang (* 1.5 2.0)) ptblw (POLAR (POLAR endp1 lang (DISTANCE endp1 tstpt)) (+ osang PI) (* 1.1 (atof inputhgttxt))) ;polar ptblw2 (POLAR ptblw (+ osang PI) (* 1.5 (atof inputhgttxt))) ) ;setq (SETQ txtpt ptblw txtpt2 ptblw2) ;_ end of setq (SETQ txtpt ptabv txtpt2 ptabv2) ;_ end of setq (SETQ adtent (LIST (CONS 0 "TEXT") (CONS 72 1) (CONS 73 2) (CONS 1 string) (CONS 7 "STANDARD") (CONS 8 (vla-get-layer item)) (CONS 50 tentang) (CONS 10 (LIST 0 0 0)) (CONS 11 txtpt) (CONS 40 (atof inputhgttxt)) ) ) ;setq (SETQ tentlen (CAADR (TEXTBOX adtent))) (ENTMAKE adtent) ) (defun make-lib-dial () ;;(setq cmdfname (strcat (getenv "TEMP") "\\prefix.dcl")) (setq fname (vl-filename-mktemp (strcat (getenv "TEMP") "\\prefix.dcl"))) (setq fn (open fname "w")) (write-line "libres : dialog {" fn) (write-line (strcat "label = " "\"" "Prefix" "\"" ";") fn) (write-line ":boxed_column {" fn) (write-line (strcat "label = " "\"" "Prefix/Suffix" "\"" ";") fn) (write-line ":edit_box {" fn) (write-line (strcat "label = " "\"" "Text Prefix" "\"" ";") fn) (write-line "alignment = left;" fn) (write-line "edit_width = 10;" fn) (write-line "value = PVC;" fn) (write-line (strcat "key = " "\"" "pref" "\"" ";") fn) (write-line "is_enabled = true;" fn) (write-line "}" fn) (write-line ":edit_box {" fn) (write-line (strcat "label = " "\"" "Text Suffix" "\"" ";") fn) (write-line "alignment = left;" fn) (write-line "edit_width = 10;" fn) (write-line "value = m;" fn) (write-line (strcat "key = " "\"" "suff" "\"" ";") fn) (write-line "is_enabled = true;" fn) (write-line "}" fn) (write-line ":edit_box {" fn) (write-line (strcat "label = " "\"" "Height Text" "\"" ";") fn) (write-line "alignment = left;" fn) (write-line "edit_width = 5;" fn) (write-line "value = 4;" fn) (write-line (strcat "key = " "\"" "hgt_txt" "\"" ";") fn) (write-line "is_enabled = true;" fn) (write-line "}" fn) (write-line "}" fn) (write-line "ok_cancel; " fn) (write-line "}" fn) (close fn) ) ;;;(make-lib-dial);ok ; ; (defun run-lib-dial () (setq dcl_ex (load_dialog fname)) (IF (NOT (NEW_DIALOG "libres" dcl_ex)) (EXIT)) (action_tile "cancel" "(done_dialog) (setq result nil)" ) (action_tile "accept" "(setq inputpref (get_tile \"pref\")) (setq inputsuff (get_tile \"suff\")) (setq inputhgttxt (get_tile \"hgt_txt\")) (done_dialog) (setq result T)" );;inputvalue -> value of prefix (start_dialog) (unload_dialog dcl_ex) (done_dialog) (vl-file-delete fname) )