Chuyển đến nội dung
Diễn đàn CADViet

tientracdia

Thành viên
 Xem Hồ Sơ  Xem hoạt động của họ

  • Số lượng nội dung

    145

  • Đã tham gia

  • Lần ghé thăm cuối

Bài đăng được đăng bởi tientracdia

  4. Đã đăng · Trả lời báo cáo

    - ek cái lsp này ko phải dạng lsp pick từng điểm góc ranh để lấy tọa độ bạn ơi ^^, bạn cứ pick vào tâm vùng hay gọi theo địa chính là tâm thửa là nó tự lấy hết tọa độ các góc ranh, dòng nhắc tiếp theo là hỏi bạn đặt bảng tọa độ ở đâu, đơn giản vậy ah, còn vụ font chữ là do định dạng trong code khi up lên diễn đàn nó bị biến đổi vậy, cái này sửa tay đc mà ^^

    Bạn có Lisp tạo HSKT theo mau xin cho mình xin với

    http://www.cadviet.com/upfiles/3/114381_vtqp.rar

  5. Đã đăng · Trả lời báo cáo

     

    Bạn thử cái này, lưu định dạng .CVS

    Lệnh là "camcoc"

    Điểm chèn block đặt ở tâm nhé.

    Muốn chọn lại chỗ lưu file csv  dùng lệnh "fn"

    Muốn chọn lại block mẫu dùng lệnh "maublk"

    (vl-load-com)
(defun c:fn ( / )
            (setq fn_camcoc (getfiled "Create Output File" "" "csv" 1))
);;; end defun fi
(defun c:maublk ( / camcoc_ten_blk1)
      (setq  camcoc_ten_blk1 (car (entsel "\nChon block ki hieu chen:")))
      (if (= (cdr (assoc 0 (entget camcoc_ten_blk1))) "INSERT")
        (progn
        (setq camcoc_ten_blk (cdr (assoc 2 (entget camcoc_ten_blk1))))
        (setq XscFactor (vlax-get-property (vlax-ename->vla-object camcoc_ten_blk1) 'XEFFECTIVESCALEFACTOR))
        (setq YscFactor (vlax-get-property (vlax-ename->vla-object camcoc_ten_blk1) 'YEFFECTIVESCALEFACTOR))
        )
        (alert "\nChua chon duoc block mau!")
      );;;end IF
);;; end defun fi

(defun c:camcoc ( / camcoc_gocquay COC EL1 GOC LIST_DON LIST_TONG OSMLAST PHIA_CAM PT10 PT11 PT_CHO_CAM_COC PT_MID TOA_DO_X TOA_DO_Y)
      (setq    OSMLAST    (getvar "osmode"))
      (setq list_tong (list)
      )
(if (null camcoc_khoang_cach)      
    (setq camcoc_khoang_cach 5)
)      
(if (null camcoc_ten_blk)      
      (c:maublk)
)
      ;(setq list_don (list))
(if
      (setq  coc (car (entsel "\nChon coc:")))
      (progn
      (if (= (cdr (assoc 0 (entget coc))) "LINE")
          (progn
              (setq pt_mid  ( mid (setq pt10 (cdr (assoc 10 (entget coc)))) (setq pt11(cdr (assoc 11 (entget coc))))));;;setq
          );;;progn
      );;;end IF
      ;(setq camcoc_khoang_cach (getreal "\nNhap khoang cach: "));;;setq
      ;(setq camcoc_khoang_cach (duy:xd_gts camcoc_khoang_cach camcoc_khoang_cach "\nNhap khoang cach: "))
      (setq camcoc_khoang_cach (duy:xd_gts gtn camcoc_khoang_cach "Nhap khoang cach:"))
      (setq phia_cam (getpoint pt_mid "\nChon phia cam: ") );;;setq
      (setvar "osmode" 0)
      (setq goc (angle pt_mid phia_cam))
      (setq pt_cho_cam_coc (polar pt_mid goc camcoc_khoang_cach));;;setq
      (setq camcoc_gocquay (RTD (- goc (/ pi 2))))
      (command "_.insert" camcoc_ten_blk pt_cho_cam_coc XscFactor YscFactor camcoc_gocquay)
      (setq el1 (entlast))
      ;(vlax-put-property (vlax-ename->vla-object el1) 'XEFFECTIVESCALEFACTOR XscFactor)
      ;(vlax-put-property (vlax-ename->vla-object el1) 'YEFFECTIVESCALEFACTOR YscFactor)
      (command "_.dimaligned" pt_mid (cdr (assoc 10 (entget el1))) (polar pt_mid (+ goc (/ pi 2)) 8))
      (setq toa_do_x  (rtos (cadr (assoc 10 (entget el1))) 2 3));;;setq
      (setq toa_do_y  (rtos (caddr (assoc 10 (entget el1))) 2 3));;;setq
      (setq list_don (list (rtos camcoc_khoang_cach 2 10) toa_do_y toa_do_x));;;setq
      (setq list_tong (append  list_tong (list list_don)));;;setq
      ;(princ list_tong);;;princ
(while (null fn_camcoc)
            (c:fn)
);;; end If
      (LM:WriteCSV list_tong fn_camcoc);      
      ;(startapp "explorer" fn)
      (setvar "osmode" OSMLAST)
        (princ)
      )    
(progn
      (princ "\nChon chua dung");;;princ
(princ)      
)
)
);;; end defun c:camcoc
(defun RTD (x) (/ (* x 180) pi) )
(defun mid ( a b )
    (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
)
(defun LM:writecsv ( lst csv / des sep )
    (if (setq des (open csv "a"))
        (progn
            (setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
            (foreach row lst (write-line (LM:lst->csv row sep) des))
            (close des)
            t
        )
    )
)

;; List -> CSV  -  Lee Mac
;; Concatenates a row of cell values to be written to a CSV file.
;; lst - [lst] list containing row of CSV cell values
;; sep - [str] CSV separator token

(defun LM:lst->csv ( lst sep )
    (if (cdr lst)
        (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
        (LM:csv-addquotes (car lst) sep)
    )
)

(defun LM:csv-addquotes ( str sep / pos )
    (cond
        (   (wcmatch str (strcat "*[`" sep "\"]*"))
            (setq pos 0)    
            (while (setq pos (vl-string-position 34 str pos))
                (setq str (vl-string-subst "\"\"" "\"" str pos)
                      pos (+ pos 2)
                )
            )
            (strcat "\"" str "\"")
        )
        (   str   )
    )
)
(defun duy:xd_gts (gtn gtmd mdich / gtn gtmd mdich)
(or gtn (setq gtn gtmd))
(setq gtn (cond ((getreal (strcat "\n" mdich " < " (rtos gtn 2 2) " >:")))(gtn)))
gtn)

    Lisp giải quyết được khoảng cách , tọa độ và xuất ra excel vị trí cọc GPMB, rất hay.

    xin nhờ Bạn giúp thêm cho việc chọn hướng gốc của tuyến ( để phân biện bên trái và phải tuyến ), chọn tên cọc ví dụ như H3,..nhập chiều rộng giải tỏa,  chọn hướng cấm cọc trái hay phải  thì xuất cọc theo hướng vuông góc và xuất ra bảng trên cad  và exxcel luôn, theo file minh họa sau

    cám ơn

    http://www.cadviet.com/upfiles/3/114381_coc_gpmb.dwg

  6. Đã đăng · Trả lời báo cáo

     

    Ý bạn là như thế này phải không?

    https://www.youtube.com/watch?v=oWMNNztIaps&feature=youtu.be

     

    Sau khi sắp xếp khung bản vẽ trong Model thì tiến hành vẽ 1 Pline nối 2 điểm của cạnh đáy khung.
    Lisp sẽ tiến hành chạy theo từng cặp đỉnh Pline cho đến hết.
    Thao tác:
    Gõ lệnh SXK => Kích chọn Pline vừa vẽ => nhập chiều cao khung bản vẽ hoặc kích chọn trực tiếp trên bản vẽ chiều cao của khung => Lúc này sẽ nhảy sang không gian Layout => Kích chọn điểm đặt khung => Chờ kết quả.
    Sau khi sắp xếp khung bản vẽ trong Model thì tiến hành vẽ 1 Pline nối 2 điểm của cạnh đáy khung.
    Lisp sẽ tiến hành chạy theo từng cặp đỉnh Pline cho đến hết.
    Thao tác:
     
    Sau khi sắp xếp khung bản vẽ trong Model thì tiến hành vẽ 1 Pline nối 2 điểm của cạnh đáy khung.
    Lisp sẽ tiến hành chạy theo từng cặp đỉnh Pline cho đến hết.
    Thao tác:
    Gõ lệnh SXK => Kích chọn Pline vừa vẽ => nhập chiều cao khung bản vẽ hoặc kích chọn trực tiếp trên bản vẽ chiều cao của khung => Lúc này sẽ nhảy sang không gian Layout => Kích chọn điểm đặt khung => Chờ kết quả.
    Sau khi sắp xếp khung bản vẽ trong Model thì tiến hành vẽ 1 Pline nối 2 điểm của cạnh đáy khung.
    Lisp sẽ tiến hành chạy theo từng cặp đỉnh Pline cho đến hết.
    Thao tác:
    Gõ lệnh SXK => Kích chọn Pline vừa vẽ => nhập chiều cao khung bản vẽ hoặc kích chọn trực tiếp trên bản vẽ chiều cao của khung => Lúc này sẽ nhảy sang không gian Layout => Kích chọn điểm đặt khung => Chờ kết quả.

    Lisp hay, mong được chia sẻ.

    thanks

  7. Đã đăng · Trả lời báo cáo

    1. Bạn xoá cái dòng (setq tl (getint "\n don vi ban do ht (500): "))

    2. Sửa lại (command "PLINE" pt4 "W" 0.0 w pt14 "W" 0.0 0.0 pt11 "")

    3. (command "TEXT" "M" pt h (RTD goc) canh )

        (command "TEXT" "M" pt h (+ (RTD goc) 180) canh )  xoá dấu "" ở cuối.

    ;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/108679-nho-chinh-sua-lisp-ghi-kich-thuoc-khong-dung-dim/page-2
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/108679-nho-chinh-sua-lisp-ghi-kich-thuoc-khong-dung-dim/
(defun RTD (a) (* 180 (/ a PI)))
(defun C:lkk (/ h k d w x f  so canh goc goc90 pt pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 pt10 pt11 pt12 pt13 pt14 text noidung diem hieu old echo)
  (setq echo (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (command "layer" "m" "B-Canh1" "c" "7" "" "")
  (command "style" "VHELVCN" "vni-Helve-Condense" 0 1 0 "" "")
  (setq old (getvar "OSMODE"))
  (setvar "OSMODE" 33)
  (command ".layer" "s" "B-CANH1" "")
  (if (tblsearch "style" "VHELVCN")  (setvar "TEXTSTYLE" "VHELVCN"))
  (command "UNDO" "BE" "")
  ;;(setq tl (getint "\n don vi ban do ht (500): "))
  (if (= tl nil) (setq tl 500))
   (setq tl1 (getint (strcat "\n don vi ban do ht (" (rtos tl 2 0) "): ")))
   (if tl1 (setq tl tl1))
  ;co so lan: x
  (setq x (/ 1000 tl))
  ;(setq h (/ 1.7 x))
  (while (= (setq h (/ 1.7 x)) 0))
  (setq d (/ 1.6 x)
 w (/ 0.48 x)
 k 2.50
 f (/ 0.90 x)) ; khoang cach mui ten voi canh can do
  (while (and (/= (setq pt1 (getpoint "\nDiem dau: ")) nil)
             (/= (setq pt2 (getpoint pt1 "\nDiem cuoi: ")) nil))
    (setvar "OSMODE" 0)    
    (setq goc (angle pt1 pt2) so (distance pt1 pt2)
          canh (rtos so 2 2)  )
    (setq pt8 (polar pt1 goc (/ so 2))
          pt7 (getpoint pt8 "\nPhia:")
          pt10 (inters pt1 pt2 pt7 (polar pt7 (+ goc (/ PI 2)) 1) nil)
          goc90 (angle pt10 pt7))
    (setq pt3 (polar pt1 goc90 f) 
          pt4 (polar pt2 goc90 f)
           pt5 (polar pt3 goc d)
          pt6 (polar pt5 goc d)
          pt9 (polar pt3 goc (/ so 2))  
           pt (polar pt8 goc90 (/ 1.4 x))
          pt11 (polar pt6 goc (- so (* 4 d)))
          pt14 (polar pt11 goc d))
		  
    (if (or (<= (RTD goc) 90) (>= (RTD goc) 270)) 
      (command "TEXT" "M" pt h (RTD goc) canh "")
      (command "TEXT" "M" pt h (+ (RTD goc) 180) canh "")
    );if
	(setq text (entlast)
		  noidung (entget text)
		  diem (cdr (assoc 10 noidung)))
    (setq pt12 (inters pt3 pt4 diem (polar diem goc90 20) nil)
		  pt13 (polar pt12 goc (* 2  (distance pt12 pt9)))
		  )
	(setq hieu (- (distance pt6 pt11) (distance pt12 pt13))) 
    (if (>= hieu (- 0 0.01))
      (progn
        (command "PLINE" pt3 "W" 0.0 w pt5 "W" 0.0 0.0 pt6 "")
	    (command "PLINE" pt11 "W" 0.0 0.0 pt14 "W" w 0.0 pt4 "")
        ;(command "MIRROR" "L" "" pt9 pt8 "")
      );progn
    );if
    
    (setvar "OSMODE" 33)
  );while
  (command "UNDO" "E" "")
  (setvar "OSMODE" old)
  (setvar "cmdecho" echo)
)
 

    Con phần này sửa ở đâu, mong bạn giữp

    2. Sửa lại (command "PLINE" pt4 "W" 0.0 w pt14 "W" 0.0 0.0 pt11 "")

    3. (command "TEXT" "M" pt h (RTD goc) canh )

        (command "TEXT" "M" pt h (+ (RTD goc) 180) canh )  xoá dấu "" ở cuối.

  9. Đã đăng · Trả lời báo cáo

    Cán ơn Phạm Thanh Bình, lisp rất hay

    Mong được Bạn giúp chỉnh giúp để thực hiện việc chọn xuất ra lần lươc theo từng nhóm excel:

    - chọn Loai đất

    - Chọn dien tích

    - chọn số thửa

    Ghi ra excel tứng cột ---> nhóm thứ nhất

    Xong enter hay ấn phải chuột chọn nhóm thứ hai như trên

    ..... cu  tiep ....

     

    ghi tiếp vào excel trước đó.

     

    Rất mong được bạn giúp.

  10. Đã đăng · Trả lời báo cáo

    Hình như mình diễn giải chưa rỏ lắm. Xin lỗi

    Bạn nhìn lại bản vẽ mẫu mình xem nha. Mình có một lớp thửa. Yêu cầu quét chọn một lần các pline thửa, lisp tạo vùng các lớp thửa đó tạo pline kin và đặt là lớp bienkin, từ pline kin đó tìm các tâm các vùng kín đó tạo điểm points ghi vao lớp cen.

    Mục đích tiếp là tính diện tich tự động các bienkin đó, để ghi vào vị trí các điểm tâm thửa .

    Nếu có gì không phải các bạn xin tha thứ cho.

  14. Đã đăng · Trả lời báo cáo

     

    Update theo yêu cầu.

    - chiều cao text lấy theo biến hệ thống TextSize

    - số chữ số thập phân lấy theo biến hệ thống Luprec (giống như trong Cad)

    (defun c:entPro2Ex (/ col i obj prolst pros row sosole spc ss x xlapp xlcells)
  ;; By : Gia_Bach 2013 ;;
  (vl-load-com)
  (defun getProEnt(obj sole / area bl cen heigh leng maxp minp obj tr width)
    (setq leng (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
	  area (vlax-curve-getArea obj))
    (vla-getBoundingBox obj 'minp 'maxp )
    (setq TR (vlax-safearray->list maxp) BL (vlax-safearray->list minp)
	  width (- (car TR) (car BL)) heigh(- (cadr TR) (cadr BL))
	  cen (mapcar '(lambda (a b) (/ (+ a b) 2.0)) TR BL))
    (list cen (rtos width 2 sole) (rtos heigh 2 sole) (rtos leng 2 sole) (rtos area 2 sole))  )
  ; main
  (if (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
    (progn
      (setq i -1 sosole (getvar "luprec"))
      (repeat (sslength ss)
	(setq obj (vlax-Ename->Vla-Object(ssname ss (setq i (1+ i))))
	      pros (getProEnt obj sosole)
	      proLst (append proLst (list pros))))
      (setq xlApp (vlax-get-or-create-object "Excel.Application")
	    xlCells (vlax-get-property(vlax-get-property(vlax-get-property(vlax-invoke-method(vlax-get-property xlApp "Workbooks") "Add") "Sheets") "Item" 1) "Cells"))
      (setq col 2 spc (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object))))
      (foreach pt (list "Length (mm)" "Witdth (mm)" "Perimeter" "Area")
	(vlax-put-property xlCells 'Item 1 col pt)
	(setq col (1+ col)))
      (setq col 1 row 2 txtheight (getvar "TextSize"))
      (foreach pt proLst
	(vla-AddText spc (- row 1) (vlax-3D-point (car pt)) txtheight)
	(vlax-put-property xlCells 'Item row col (- row 1))
	(setq col (1+ col))
	(foreach str (cdr pt)
	  (vlax-put-property xlCells 'Item row col str)
	  (setq col (1+ col)))
	(setq row (1+ row) col 1) )
      (vla-put-visible xlApp :vlax-true)
      (mapcar (function (lambda (x) (vl-catch-all-apply (function (lambda ()(if x (vlax-release-object x)))))))	(list xlCells xlApp)) ))
  (princ))

    Xin nhờ anh gia_bach giúp cho việc xuất nội dung từ excel sang cad them nội dung diện tích nằm dưới số thứ tụ.

    http://www.cadviet.com/upfiles/3/114381_drawing1_1.dwg

    Cám ơn

  19. Đã đăng · Trả lời báo cáo

    Lisp entPro2Ex của anh gia_bach viết rất hay. Cám ơn

    Khi chọn nhiều đa giác xuất ra execl thì trên exxcel có xuất phần số thứ tự. Mình không biết các đa giác đó hiện nằm trong vùng nào.

    Anh có thể bổ sung việc đánh số đó vào cad theo đúng phần đã xuất giúp mình với.

    http://www.cadviet.com/upfiles/3/114381_drawing1.dwg

    http://www.cadviet.com/upfiles/3/114381_book4.rar

  20. Đã đăng · Trả lời báo cáo

    Mình xin nhờ các Bạn viét giúp một lisp, Chọn vào vùng đa giác kín để hatch, thí lisp tạo ra lớp đường bao và vẽ đường bao xung quanh đa giác đó với kiểu nét đứt, độ rộng nét vẻ là 0.2 mm. Sau đó lisp hatch trong đường bao với loai hact là ANSI31 tỉ lệ hatch là 5.

    http://www.cadviet.com/upfiles/3/114381_tao_duong_ba_hatch.dwg

    Rất cám ơn

  24. Đã đăng

    Mình muốn viết lisp chon điểm xác định tọa độ và ghi ra file text :

    (defun C:TDMOC( / p so old k tyle1 lold f s)

;; mo de ghi vao file txt
(if (not (setq f (open (getfiled "Data save file" "" "txt" 1) "a"))) (exit));

;; ghi vao  ten cong trinh vao text
(write-line (strcat "\n"(getstring "Ghi chu ten cong trinh :" t)"\n") f);

;; chon ty le va xac dinh diem :ghi va chen ky hieu vao
  (setq lold (getvar "clayer"))
  (setq old (getvar "osmode"))
  (setvar "osmode" 9)
  (setq ltdtylein 500)
  (setq tyle1 (getint (strcat "\nTy le in ban do <" (itoa ltdtylein ) ">: ")))
  (if tyle1 (setq ltdtylein tyle1))
  (setq k (/ ltdtylein 1000.0))
  (setq so "1")
  (command "_.layer" "m" "TOADOMOC" "c" 2 "" "")
  (setvar "clayer" "TOADOMOC")
  (INITGET 128)
  (WHILE (SETQ P (GETPOINT (strcat "\nNhap so hieu diem <" so "> hoac Pick "))) 
    (cond 
      ((listp p) 
        (command "_.insert" "KHMOC" "s" k p 0.0 so)
        (setq so (itoa (1+ (atoi so))))
      )
      ((= (type p) 'STR) (setq so p))
    )
    (INITGET 128)
  )

  
;;-------------------------  ??? xac dinh TEN - TOA DO X -  TOA DO Y	vao txt hoac excel
  (write-line (strcat s "\t" (rtos (car pt) 2 3) "\t" (rtos (cadr pt) 2 3)) f) ;
  (while (not b)
		(if (/= "" (setq s (getstring "\nTen diem :" )	))
			(progn
			(command "osnap" "Node,End,Mid,Cen,Qua,Int,Per,Tan,Ext,Par")	;Tao cac truy bat diem End,Mid,Cen,Qua,Per,Tan,Ext, Par.
			(setq pt (getpoint "Vi tri lay toa do :")	)
			(write-line (strcat s "\t" (rtos (car pt) 2 3) "\t" (rtos (cadr pt) 2 3)) f)
			)
			(setq b t)
			)
		)
	(close f)
 ; ;;---------------------
 
  (setvar "osmode" old)
  (setvar "clayer" lold)
  (PRINC)
)

    Nhưng bị vướn không nhập vào text được, mong được các bạn giúp.

    http://www.cadviet.com/upfiles/3/114381_khmoc_1.dwg

×