Đến nội dung


Hình ảnh
- - - - -

[Nhờ sửa lisp] Đánh lý trình center line


  • Please log in to reply
6 replies to this topic

#1 aabbccdd

aabbccdd

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: -3 (bình thường)

Đã gửi 15 June 2015 - 11:14 AM

Chào các bác.

Em đang cần đánh lý trình trên center line (polyline) cho trước.

Mà về lisp cad thì em mù tịt, lang thang trên mạng tìm được cái lisp này:

;; written by Fatty T.O.H. ()2004 * all rights removed
;; edited 6/5/10
;; edited 6/10/10
;; Stationing

;;load ActiveX library
(vl-load-com)

;;local defuns

;//
(defun makeblock (adoc aprompt atag bname txtheight tstyle / at_obj blk_obj lay line_obj tst)

(if (not (tblsearch "block" bname))
  (progn

  (setq tst (getvar "textstyle"))
  (setvar "textstyle" tstyle)
  (setq lay (getvar "clayer"))
  (setvar "clayer" "0")
  
  (setq	blk_obj	(vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname))
  (setq line_obj (vlax-invoke blk_obj 'Addline '(0. 0. 0.) (list 0. 12.0 0.)))
  (vla-put-color line_obj acyellow)
  (setq at_obj (vla-addattribute blk_obj
		 txtheight
		 acattributemodeverify
		 aprompt
		 (vlax-3d-point '(-0.5 1. 0.))
		 atag
		 "0+00")
	)

  (vla-put-rotation at_obj (/ pi 2))
  (vla-put-color at_obj acwhite)
  (mapcar (function (lambda(x) vlax-release-object x))
	  (list at_obj line_obj blk_obj )
	  )
  (setvar "clayer" lay)
  (setvar "textstyle" tst)
  )
  )
  )

;;//
(defun start (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getstartpoint curve
    )
  )
)
    )
  )
  )
;;//
(defun end (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getendpoint curve
    )
  )
)
    )
  )
  )
;;//
(defun pointoncurve (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  pt
    )
  )
)
    )
  )
;;//
(defun paramatpoint (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getparamatpoint curve
  pt
    )
  )
)
    )
  )
;;//
(defun distatpt (curve pt)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatpoint curve
    (vlax-curve-getclosestpointto curve pt)
    )
  )
				)
    )
  )
;;//
(defun pointatdist (curve dist)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getclosestpointto curve
  (vlax-curve-getpointatdist curve dist)
    )
  )
)
    )
  )
;;//
(defun curvelength (curve)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatparam curve
  (- (vlax-curve-getendparam curve)
     (vlax-curve-getstartparam curve)
    )
  )
  )
)
    )
  )
;;//
(defun distatparam (curve param)
  (vl-catch-all-apply (function (lambda()
  (vlax-curve-getdistatparam curve
  param
  )
  )
				)
    )
  )
;;//
(defun statlabel  (num step div)
  ;; num - integer, zero based
  ;; step - double or integer, must be non zero
  
  (strcat
    (itoa (fix (/ num div)))
    "+"
    (if (zerop (rem num div))
      "00"
      (rtos (* (rem num div) step) 2 0))

    )
  )


;;//
(defun insertstation (acsp bname pt rot tag num step div / block)
  (vl-catch-all-apply
    (function (lambda()
     (setq block (vlax-invoke-method acsp 'InsertBlock pt bname 1 1 1 rot))
		)
	      )
    )
  (changeatt block tag (statlabel num step div))

block
  )

;;//
(defun changeatt (block tag value / att)
  (setq atts (vlax-invoke block 'GetAttributes))
  (foreach att atts
    (if (equal tag (vla-get-tagstring att))
      (vla-put-textstring att value)
      )
    )
    )

;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
  
	 (setq param (paramatpoint curve pt)
	       ang ((lambda (deriv)
		   (if (zerop (cadr deriv))
		     (/ pi 2)
		     (atan (apply '/ deriv))
		   )
		 )
		  (cdr (reverse
			 (vlax-curve-getfirstderiv curve param)
		       )
		  )
		)
)
  ang
  )

;;// main program
(defun c:STAN (/ *error* acsp adoc block cnt div en ent label
	       lastp lay leng lnum mul num pt rot sign start step)
  
  (defun *error* (msg)
    (if msg (princ (strcat "\nError! " msg)))
    (princ)
    )
  
  (setvar "dimzin" 4)
  (setq lay (getvar "clayer"))
  (setvar "clayer" "0")
  (setq adoc	(vla-get-activedocument (vlax-get-acad-object))
	   acsp	(vla-get-block (vla-get-activelayout adoc))
     )
  
 (if (not (tblsearch "block" "Station"))
   (makeblock adoc "NUMBER" "NUMBER" "Station" 2.0 "Standard")
   )
  
 (while	(not
	  (and
	    (or
	      (initget 6)
	      (setq step (getreal "\nEnter step <25>: "))
	      (if (not step)
		(setq step 25.)))
	    (zerop (rem 100 step))))
   (alert (strcat "\nRemainder 100 / " (rtos step 2 2) " is not equal to zero
		  \nEnter correct step"))
   )


(if

  (setq
    ent	(entsel
	  "\nSelect curve near to the start point >>"
	  )
    )

   (progn

     (setq en	(car ent)
	   pt	(pointoncurve en (cadr ent))
	   leng	(distatparam en (vlax-curve-getendparam en))
	   )

     (setq num (fix (/ leng step))
	   )

     (setq div (fix (/ 100. step)
		    )
	   )

     (setq mul (- leng
		  (* (setq lnum (fix (/ leng (* step div)))) (* step div))))

     (if (not (zerop mul))
       (setq lastp T)
       (setq lastp nil)
       )

     (if (> (- (paramatpoint en pt)
	       (paramatpoint en (vlax-curve-getstartpoint en))
	       )
	    (- (paramatpoint en (vlax-curve-getendpoint en))
	       (paramatpoint en pt)
	       )
	    )
       (progn
	 (setq start leng
	       sign  -1
	       )
	 )
       (progn

	 (setq start (distatparam en (vlax-curve-getstartparam en))
	       sign  1
	       )
	 )
       )


     (vla-startundomark
       (vla-get-activedocument (vlax-get-acad-object))
       )
     (setq cnt 0)
     (repeat (1+ num)
       (setq pt	 (pointatdist en start)
	     rot (gettangent en pt)
	     )

       (setq block
	      (insertstation
		acsp
		"Station"
		(vlax-3d-point pt)
		rot
		"NUMBER"
		cnt
		step
		div)
	     )


       (setq cnt   (1+ cnt)
	     start (+ start (* sign step))
	     )
       )


     (if lastp
       (progn

	 (if (= sign -1)
	   (progn
	     (setq pt  (vlax-curve-getstartpoint en)
		   rot (gettangent en pt)
		   )
	     )
	   (progn
	     (setq pt  (vlax-curve-getendpoint en)
		   rot (gettangent en pt)
		   )
	     )
	   )
	 (setq block
		(insertstation
		  acsp
		  "Station"
		  (vlax-3d-point pt)
		  rot
		  "NUMBER"
		  (1- cnt)
		  0
		  div)
	       )

	 (setq label (strcat (itoa lnum) "+" (rtos mul 2 2))
	       )
	 (changeatt block "NUMBER" label)
	 )
       )
     (setvar "clayer" lay)
     (vla-endundomark
       (vla-get-activedocument (vlax-get-acad-object))
       )
     )
   (princ "\nNothing selected")
   )
  (*error* nil)
(princ)
)

(prompt "\n   >>>   Type STAN to execute...")
(prin1)

Nhưng mà nó lại đánh lý trình theo kiểu 0+00.

Các bác sửa giúp em thành đánh kiểu 0+000 (hay Km 0+000) với ạ.

Cảm ơn các bác :)


  • -1

#2 huunhantvxdts

huunhantvxdts

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 366 Bài viết
Điểm đánh giá: 53 (tàm tạm)

Đã gửi 15 June 2015 - 09:50 PM

Bạn chỉ cần thay dòng lệnh sau:

(setq div (fix (/ 100. step)

thành

(setq div (fix (/ 1000. step)


  • 1

#3 aabbccdd

aabbccdd

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: -3 (bình thường)

Đã gửi 16 June 2015 - 09:56 AM

Bạn chỉ cần thay dòng lệnh sau:

(setq div (fix (/ 100. step)

thành

(setq div (fix (/ 1000. step)

Được rồi bác ơi, cảm ơn bác.

Nhưng bác giúp em chút.

Nó lại đánh lý trình thành 1+20, em muốn nó thành 1+020 ý.

Bác giúp em với.


  • -1

#4 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 315 (khá)

Đã gửi 16 June 2015 - 10:32 AM

Bạn tìm đoạn này (trong hàm statlabel ): (rtos (* (rem num div) step) 2 0) =>Thay bằng: (if (= (strlen (rtos (* (rem num div) step) 2 0)) 2)(strcat "0" (rtos (* (rem num div) step) 2 0))(rtos (* (rem num div) step) 2 0)).


  • 0

#5 aabbccdd

aabbccdd

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: -3 (bình thường)

Đã gửi 16 June 2015 - 11:40 AM

Bạn tìm đoạn này (trong hàm statlabel ): (rtos (* (rem num div) step) 2 0) =>Thay bằng: (if (= (strlen (rtos (* (rem num div) step) 2 0)) 2)(strcat "0" (rtos (* (rem num div) step) 2 0))(rtos (* (rem num div) step) 2 0)).

nó báo lỗi này bác ơi:

 

stan(1).lsp successfully loaded.
Command: ; error: extra right paren on input


  • -1

#6 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 673 Bài viết
Điểm đánh giá: 315 (khá)

Đã gửi 16 June 2015 - 03:00 PM

Bạn kiểm tra lại dấu ). Bạn thay thế chưa đúng.

Tôi thay ở đây (Bạn có thể thay thế cả hàm):

(defun statlabel (num step div)
;; num - integer, zero based
;; step - double or integer, must be non zero
(strcat (itoa (fix (/ num div)))
"+"
(if (zerop (rem num div))
"000"
(if (= (strlen (rtos (* (rem num div) step) 2 0)) 2)
(strcat "0" (rtos (* (rem num div) step) 2 0))
(rtos (* (rem num div) step) 2 0)))))


  • 1

#7 aabbccdd

aabbccdd

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: -3 (bình thường)

Đã gửi 16 June 2015 - 03:11 PM

Bạn kiểm tra lại dấu ). Bạn thay thế chưa đúng.

Tôi thay ở đây (Bạn có thể thay thế cả hàm):

(defun statlabel (num step div)
;; num - integer, zero based
;; step - double or integer, must be non zero
(strcat (itoa (fix (/ num div)))
"+"
(if (zerop (rem num div))
"000"
(if (= (strlen (rtos (* (rem num div) step) 2 0)) 2)
(strcat "0" (rtos (* (rem num div) step) 2 0))
(rtos (* (rem num div) step) 2 0)))))

Cảm ơn bác nhiều :)


  • 0