Тема: Маркировка сети труб (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)
)
