Jump to content
InfoFile
Tác giả: TRUNGNGAMY
Bài viết gốc: 169078
Tên lệnh: xtd
chuyển text các cao độ trong Autocad sang file dạng *.txt

Mình gửi bạn lisp xuất sang file text,mình thường dùng đề lấy cao độ khi làm san nền ( một số video hướng dẫn san nền mình cũng dùng...

>>

Mình gửi bạn lisp xuất sang file text,mình thường dùng đề lấy cao độ khi làm san nền ( một số video hướng dẫn san nền mình cũng dùng lisp này)

(defun doichu ()
 (setvar "cmdecho" 0)
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
(if_file2)
 ;(setq s (getstring "\nFilename <Khong-Ten>: "))
;(if (= s nul) (setq s "Khong-Ten"))
(setq fn (open filename2 "w"))
 (setq i 0)
 (setq j 1)
 (prompt "\n")
 (prompt "\Chän C¸c §iÓm Cao §é : ")
 (setq ss  (ssget (list (cons 0 "Text"))))
 (if ss
           	(progn
              		(repeat (sslength ss)  
(setq ent (entget (ssname ss i)))    
(setq nd (cdr (assoc 1 ent)))
(setq ss1 (cdr (assoc 72 ent)))
(setq ss2 (cdr (assoc 73 ent)))
(if (and (= ss1 0) (= ss2 0))
   	(setq td (cdr (assoc 10 ent)))
   	(setq td (cdr (assoc 11 ent)))
)
;(setq td1 (cdr (assoc 10 ent)))
  (setq Y (cadr td))
  (setq X (car td))
  (setq z (caddr td))
  (write-line (strcat (itoa j)
		" "
		(rtos X 2 3)
		" "
		(rtos Y 2 3)
		" "
		(rtos z 2 3)
		" "
		nd
		) fn)
(setq i (+ i 1))
  (setq j (+ j 1))
   	)
)
)
 (close fn)
 (setvar "osmode" 191)
 (prompt "\n****	Chóc B¹n Thµnh C«ng ***")
 (princ)
)
;********************************
;*********
(defun c:xtd ()
 	(doichu)    
 )
;;***************************Mo file
(defun if_file1 (/ name1)
 (if (= filename1 nil)
(progn
      		(setq name1 (getfiled "Më TËp Tin Chøa Sè LiÖu"
                       	(strcat "d:/canhan/TUAN/luu/" "solieu") "txt" 2))
      		(if name1 (setq filename1 (strcase name1)))
 	)
(progn
(setq name1 (getfiled "Më TËp Tin Chøa Sè LiÖu"
                       	filename1 "txt" 2))
      		(if name1 (setq filename1 (strcase name1)))
)
)
      		)
;****************************Ghi file
(defun if_file2 (/ name2)
 (if (= filename2 nil)
(progn
      		(setq name2 (getfiled "Më TËp Tin Chøa Sè LiÖu"
                       	(strcat "d:/canhan/TUAN/luu/" "solieu") "txt" 1))
      		(if name2 (setq filename2 (strcase name2)))
 	)
(progn
(setq name2 (getfiled "L­u TËp Tin Sè LiÖu"
                       	filename2 "txt" 1))
      		(if name2 (setq filename2 (strcase name2)))
)
)
      		)

Lisp này hình như kg dùng đc.

Nhưng nuốn lấy dữ liệu file này mình nghĩ chỉ cần "nổ" từng thằng một, rồi lấy dữ liệu. Cái text số nguyên chính là số hiệu điểm, text thập phân là độ cao, hình tròn chính là điểm tọa độ. Nhiều cao thủ viết cái này trong vòng 5' là xong


<<

Filename: 169078_xtd.lsp
Tác giả: nhatphong
Bài viết gốc: 223195
Tên lệnh: ha2
Nhờ viết lisp tạo nhanh wipeout

Lisp chuyển các Wipeout thành các Lwpolyline.

;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Wipeout...
>>

Lisp chuyển các Wipeout thành các Lwpolyline.

;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Wipeout duoc chon thanh cac Lwpolyline.
(defun C:HA2( / cmd ped entlst ss ent)
(command "undo" "be")
(setq cmd (getvar "cmdecho") ped (getvar "peditaccept"))
(setvar "cmdecho" 0) (setvar "peditaccept" 0)
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "WIPEOUT")))))))
(foreach ent1 entlst
 (setq ss (ssadd) ent (entlast))
 (command "explode" ent1)
 (while (setq ent (entnext ent))
  (setq ss (ssadd ent ss)))
 (command "pedit" "m" ss "" "y" "j" 0 ""))
(setvar "cmdecho" cmd) (setvar "peditaccept" ped) (command "undo" "end")
(princ))

bạn ơi sao lúc bỏ Wipeout thành Pline thì được sao vẫn còn 1 điểm chấm nhỉ? xóa luôn trong lisp được kg!thank bạn


<<

Filename: 223195_ha2.lsp
Tác giả: hoan2182
Bài viết gốc: 101131
Tên lệnh: flat
Hỏi về cách chuyển cad 3d sang 2d

em dang sửa bản vẽ 2d nhưng bản vẽ bị lỗi khi các nét không cùng nằm trên 1 mặt phẳng.

xin các bác giúp đỡ em chuyển về cùng 1 mat75...

>>
em dang sửa bản vẽ 2d nhưng bản vẽ bị lỗi khi các nét không cùng nằm trên 1 mặt phẳng.

xin các bác giúp đỡ em chuyển về cùng 1 mat75 phẳng

Bạn sử dụng lệnh EXPLAN của Express Tool.

hoặc dùng LISP mình sưu tầm được. sau khi Load sử dụng lệnh : FLAT

;;; FLATTEN.LSP version 2k.01f, 14-Jul-2000
;;;
;;; FLATTEN sets the Z-coordinates of these types of objects to 0
;;; in the World Coordinate System:
;;;  "3DFACE" "ARC" "ATTDEF" "CIRCLE" "DIMENSION"
;;;  "ELLIPSE" "HATCH" "INSERT" "LINE" "LWPOLYLINE"
;;;  "MTEXT" "POINT" "POLYLINE" "SOLID" "TEXT"
;;;
;;;-----------------------------------------------------------------------
;;; copyright 1990-2000 by Mark Middlebrook
;;;   Daedalus Consulting
;;;   e-mail: mark@markcad.com
;;;
;;; Before you e-mail me with support questions, please make sure that
;;; you're using the current version. You can download it from
;;; http://markcad.com.
;;;
;;; This program is free software. You can redistribute it and/or modify
;;; it under the terms of the GNU General Public cấp quyền as published by
;;; the Free Software Foundation: http://www.gnu.org/copyleft/gpl.html.
;;;
;;; Thanks to Vladimir Livshiz for improvements in polyline handling
;;; and the addition of several other object types.
;;;
;;;-----------------------------------------------------------------------
;;; Revision history
;;;  v. 2k.0   25-May-1999  First release for AutoCAD 2000.
;;;  v. 2k.01  25-Jun-1999  Fixed two globalization bugs ("_World" & "_X")
;;;                         and revised error handler.
;;;  v. 2k.01f 14-Jul-1999  Added GNU GPL and download info to header.
;;;
;;;-----------------------------------------------------------------------
;;;*Why Use FLATTEN?
;;;
;;; FLATTENing is useful in at least two situations:
;;;  1) You receive a DXF file created by another CAD program and discover
;;;     that all the Z coordinates contain small round-off errors. These
;;;     round-off errors can prevent you from object snapping to
;;;     intersections and make your life difficult in other ways as well.
;;;  2) In a supposedly 2D drawing, you accidentally create one object with
;;;     a Z elevation and end up with a drawing containing objects partly
;;;     in and partly outside the Z=0 X-Y plane. As with the round-off
;;;     problem, this situation can make object snaps and other procedures
;;;     difficult.
;;;
;;; Warning: FLATTEN is not for flattening the custom objects created by
;;; applications such as Autodesk's Architectural Desktop. ADT and similar
;;; programs create "application-defined objects" that only the
;;; application really knows what to do with. FLATTEN has no idea how
;;; to handle application-defined objects, so it leaves them alone.
;;;
;;;-----------------------------------------------------------------------
;;;*How to Use FLATTEN
;;;
;;; This version of FLATTEN works with AutoCAD R12 through 2000.
;;;
;;; To run FLATTEN, load it using AutoCAD's APPLOAD command, or type:
;;;   (load "FLATTEN")
;;; at the AutoCAD command prompt. Once you've loaded FLATTEN.LSP, type:
;;;   FLATTEN
;;; to run it. FLATTEN will tell you what it's about to do and ask you
;;; to confirm that you really want to flatten objects in the current
;;; drawing. If you choose to proceed, FLATTEN prompts you to select objects
;;; to be flattened (press ENTER to flatten all objects in the drawing).
;;; After you've selected objects and pressed ENTER, FLATTEN goes to work.
;;; It reports the number of objects it flattens and the number left
;;; unflattenened (because they were objects not recognized by FLATTEN; see
;;; the list of supported objects above).
;;;
;;; If you don't like the results, just type U to undo FLATTEN's work.
;;;
;;;-----------------------------------------------------------------------
;;;*Known limitations
;;;  1) FLATTEN doesn't support all of AutoCAD's object types. See above
;;;     for a list of the object types that it does work on.
;;;  2) FLATTEN doesn't flatten objects nested inside of blocks.
;;;     (You can explode blocks before flattening. Alternatively, you can
;;;     WBLOCK block definitions to separate DWG files, run FLATTEN in
;;;     each of them, and then use INSERT in the parent drawing to update
;;;     the block definitions. Neither of these methods will flatten
;;;     existing attributes, though.
;;;  3) FLATTEN flattens objects onto the Z=0 X-Y plane in AutoCAD's
;;;     World Coordinate System (WCS). It doesn't currently support
;;;     flattening onto other UCS planes.
;;;
;;;=======================================================================

(defun C:FLAT (/       tmpucs  olderr  oldcmd  zeroz   ss1     ss1len
                 i       numchg  numnot  numno0  ssno0   ename   elist
                 etype   yorn    vrt     crz
                )
 (setq tmpucs "$FLATTEN-TEMP$")        ;temporary UCS

 ;;Error handler
 (setq olderr *error*)
 (defun *error* (msg)
   (if (or
         (= msg "Function cancelled")
         (= msg "quit / exit abort")
       )
     ;;if user cancelled or program aborted, exit quietly
     (princ)
     ;;otherwise report error message
     (princ (strcat "\nError: " msg))
   )
   (setq *error* olderr)
   (if (tblsearch "UCS" tmpucs)
     (command "._UCS" "_Restore" tmpucs "._UCS" "_Delete" tmpucs)
   )
   (command "._UNDO" "_End")
   (setvar "CMDECHO" oldcmd)
   (princ)
 )

 ;;Function to change Z coordinate to 0

 (defun zeroz (key zelist / oplist nplist)
   (setq oplist (assoc key zelist)
         nplist (reverse (append '(0.0) (cdr (reverse oplist))))
         zelist (subst nplist oplist zelist)
   )
   (entmod zelist)
 )
 ;;Setup
 (setq oldcmd (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (command "._UNDO" "_Group")
 (command "._UCS" "_Delete" tmpucs "._UCS" "_Save" tmpucs "._UCS" "_World")
                                       ;set World UCS

 ;;Get input
 (prompt
   (strcat
     "\nFLATTEN sets the Z coordinates of most objects to zero."
   )
 )

 (initget "Yes No")
 (setq yorn (getkword "\nDo you want to continue <Y>: "))
 (cond ((/= yorn "No")
        (graphscr)
        (prompt "\nChoose objects to FLATTEN ")
        (prompt
          ""
        )
        (setq ss1 (ssget))
        (if (null ss1)                 ;if enter...
          (setq ss1 (ssget "_X"))      ;select all entities in database
        )
        ;;*initialize variables
        (setq ss1len (sslength ss1)    ;length of selection set
              i      0                 ;loop counter
              numchg 0                 ;number changed counter
              numnot 0                 ;number not changed counter
              numno0 0                 ;number not changed and Z /= 0 counter
              ssno0  (ssadd)           ;selection set of unchanged entities
        )                              ;setq

        ;;*do the work
        (prompt "\nWorking.")
        (while (< i ss1len)            ;while more members in the SS
          (if (= 0 (rem i 10))
            (prompt ".")
          )
          (setq ename (ssname ss1 i)   ;entity name
                elist (entget ename)   ;entity data list
                etype (cdr (assoc 0 elist)) ;entity type
          )

          ;;*Keep track of entities not flattened
          (if (not (member etype
                           '("3DFACE"     "ARC"        "ATTDEF"
                             "CIRCLE"     "DIMENSION"  "ELLIPSE"
                             "HATCH"      "INSERT"     "LINE"
                             "LWPOLYLINE" "MTEXT"      "POINT"
                             "POLYLINE"   "SOLID"      "TEXT"
                            )
                   )
              )
            (progn                     ;leave others alone
              (setq numnot (1+ numnot))
              (if (/= 0.0 (car (reverse (assoc 10 elist))))
                (progn                 ;add it to special list if Z /= 0
                  (setq numno0 (1+ numno0))
                  (ssadd ename ssno0)
                )
              )
            )
          )

          ;;Change group 10 Z coordinate to 0 for listed entity types.
          (if (member etype
                      '("3DFACE"    "ARC"       "ATTDEF"    "CIRCLE"
                        "DIMENSION" "ELLIPSE"   "HATCH"     "INSERT"
                        "LINE"      "MTEXT"     "POINT"     "POLYLINE"
                        "SOLID"     "TEXT"
                       )
              )
            (setq elist  (zeroz 10 elist) ;change entities in list above
                  numchg (1+ numchg)
            )
          )

          ;;Change group 11 Z coordinate to 0 for listed entity types.
          (if (member etype
                      '("3DFACE" "ATTDEF" "DIMENSION" "LINE" "TEXT" "SOLID")
              )
            (setq elist (zeroz 11 elist))
          )

          ;;Change groups 12 and 13 Z coordinate to 0 for SOLIDs and 3DFACEs.
          (if (member etype '("3DFACE" "SOLID"))
            (progn
              (setq elist (zeroz 12 elist))
              (setq elist (zeroz 13 elist))
            )
          )

          ;;Change groups 13, 14, 15, and 16
          ;;Z coordinate to 0 for DIMENSIONs.
          (if (member etype '("DIMENSION"))
            (progn
              (setq elist (zeroz 13 elist))
              (setq elist (zeroz 14 elist))
              (setq elist (zeroz 15 elist))
              (setq elist (zeroz 16 elist))
            )
          )

          ;;Change each polyline vertex Z coordinate to 0.
          ;;Code provided by Vladimir Livshiz, 09-Oct-1998
          (if (= etype "POLYLINE")
            (progn
              (setq vrt ename)
              (while (not (equal (cdr (assoc 0 (entget vrt))) "SEQEND"))
                (setq elist (entget (entnext vrt)))
                (setq crz (cadddr (assoc 10 elist)))
                (if (/= crz 0)
                  (progn
                    (zeroz 10 elist)
                    (entupd ename)
                  )
                )
                (setq vrt (cdr (assoc -1 elist)))
              )
            )
          )

          ;;Special handling for LWPOLYLINEs
          (if (member etype '("LWPOLYLINE"))
            (progn
              (setq elist  (subst (cons 38 0.0) (assoc 38 elist) elist)
                    numchg (1+ numchg)
              )
              (entmod elist)
            )
          )

          (setq i (1+ i))              ;next entity
        )
        (prompt " Done.")

        ;;Print results
        (prompt (strcat "\n" (itoa numchg) " object(s) flattened."))
        (prompt
          (strcat "\n" (itoa numnot) " object(s) not flattened.")
        )

        ;;If there any entities in ssno0, show them
        (if (/= 0 numno0)
          (progn
            (prompt (strcat "  "
                    )
            )
            (getstring
              "\nPress enter to see non-zero unchanged objects... "
            )
            (command "._SELECT" ssno0)
            (getstring "\nPress enter to unhighlight them... ")
            (command "")
          )
        )
       )
 )

 (command "._UCS" "_Restore" tmpucs "._UCS" "_Delete" tmpucs)
 (command "._UNDO" "_End")
 (setvar "CMDECHO" oldcmd)
 (setq *error* olderr)
 (princ)
)

;(prompt  "\nFLATTEN version 2k.01f loaded.  Type FLATTEN to run it.")
;(princ)

;;;eof


<<

Filename: 101131_flat.lsp
Tác giả: AGi
Bài viết gốc: 234365
Tên lệnh: od oc oca
có list nào copy tăng dần với block ATT ko?

 

Bạn dùng thử lisp này. Ssg đã post lên diễn đàn lâu lắm rồi. Riêng phần Att mới bổ sung theo gợi ý của bạn:

 

>>

 

Bạn dùng thử lisp này. Ssg đã post lên diễn đàn lâu lắm rồi. Riêng phần Att mới bổ sung theo gợi ý của bạn:

 

;;;**********************************************;;;CHUONG TRINH DANH SO THU TU VA COPY TANG DAN;;;1. Lenh OD: danh so thu tu, tuy chon so bat dau (begin) va so gia (increment) tuy y;;;2. Lenh OC: copy tang dan tu mot so thu tu co san;;;3. Lenh OCA: copy tang dan voi doi tuong Attribute Block;;;Chuong trinh chap nhan cac dinh dang bang so, chu, so va chu ket hop:;;;1, 2... A, B..., A1, A2..., AB-01, AB-02..., AB-01-C1, AB-01-C2...;;;Cac chu gioi han trong khoang tu A den Z. Cac so khong han che;;;Copyright by ssg - www.cadviet.com - December 2008;;;**********************************************;;;-------------------------------------------------(defun etype (e) ;;;Entity Type(cdr (assoc 0 (entget e))));;;-------------------------------------------------(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting(setq    sty (getvar "textstyle")    d (tblsearch "style" sty)    h (cdr (assoc 40 d)))(if (= h 0) (setq h (cdr (assoc 42 d))))(entmake    (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))));;;-------------------------------------------------(defun incN (n dn / n2 i n1) ;;;Increase number n(setq    n2 (itoa (+ dn (atoi n)))    i (- (strlen n) (strlen n2)))(if (> i 0) (setq n1 (substr n 1 i)) (setq n1 ""))(strcat n1 n2));;;-------------------------------------------------(defun incC (c / i c1 c2) ;;;Increase character c(setq    i (strlen c)    c1 (substr c 1 (- i 1))    c2 (chr (1+ (ascii (substr c i 1)))))(if (or (= c2 "{") (= c2 "["))    (progn (command "erase" (entlast) "") (alert "Over character!") (exit))    (strcat c1 c2)));;;============================(defun C:OD( / cn dn c n p) ;;;Make OrDinal number with any format(setq    cn (getstring "\nBegin at <1>: " T)    dn (getint "\nIncrement <1>: "))(if (not dn) (setq dn 1))(if (= cn "") (setq cn "1"))(setq c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn))(setq n (vl-string-subst "" c cn))(if (/= n "") (setq mode 1) (setq mode 0))(while (setq p (getpoint "\nBase point <exit>: "))    (wtxt cn p)    (if (= n "")         (setq cn (incC cn))        (setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))            ))(princ));;;============================(defun C:OC( / e dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from template(setq    e (car (entsel "\nSelect template text:"))    dn (getint "\nIncrement <1>: ")    p1 (getpoint "\nBase point:")    cn (cdr (assoc 1 (entget e))))(if (not dn) (setq dn 1))(if (= cn "") (setq cn "1"))(setq    c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)    n (vl-string-subst "" c cn))(while (setq p2 (getpoint p1 "\nNew point <exit>: "))    (command "copy" e "" p1 p2)    (if (= n "")         (setq cn (incC cn))        (setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))            )    (setq        dat (entget (entlast))        dat (subst (cons 1 cn) (assoc 1 dat) dat)    )    (entmod dat)    )(princ));;;============================(defun C:OCA( / e e0 dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from Atttribute block(setq    e0 (car (entsel "\nSelect attribute block:"))    e (entnext e0))(if (/= (etype e) "ATTRIB") (progn (alert "Object is not a Attribute Block!") (exit)))(setq    dn (getint "\nIncrement <1>: ")    p1 (getpoint "\nBase point:")    cn (cdr (assoc 1 (entget e))))(if (not dn) (setq dn 1))(if (= cn "") (setq cn "1"))(setq    c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)    n (vl-string-subst "" c cn))(while (setq p2 (getpoint p1 "\nNew point <exit>: "))    (command "copy" e0 "" p1 p2)    (if (= n "")         (setq cn (incC cn))        (setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))            )    (setq        dat (entget (entnext (entlast)))        dat (subst (cons 1 cn) (assoc 1 dat) dat)    )    (entmod dat)    (command "regen"))(princ));;;============================

 

Sao cái lisp này mình ko chạy đc vậy pro?

Báo lỗi: 

Select attribute block:; error: no function definition: ETYPE

http://www.cadviet.com/upfiles/3/31951_block_att_1.dwg


<<

Filename: 234365_od_oc_oca.lsp
Tác giả: hoacomay70
Bài viết gốc: 287525
Tên lệnh: test
Nhờ viết lisp vẽ đường thẳng vuông góc với Pline

Của bạn đây.

 

 

(defun c:test(/ cd pl obj dd dait cl sl n os ki )
  (defun ad(v p1 p2 / a1)
    (abs (-...
>>

Của bạn đây.

 

 

(defun c:test(/ cd pl obj dd dait cl sl n os ki )
  (defun ad(v p1 p2 / a1)
    (abs (- (vlax-curve-getDistAtPoint (setq a1 (vlax-ename->vla-object v)) (vlax-curve-getClosestPointTo a1 p2))
  (vlax-curve-getDistAtPoint a1 (vlax-curve-getClosestPointTo a1 p1)))))
  
  (defun getp(v dis)
     (vlax-curve-getPointAtDist (vlax-ename->vla-object v) dis))
  
  (defun thgoc (ent pt / param obj) 
    (if (setq param (vlax-curve-getParamAtPoint (setq obj (vlax-ename->vla-object ent)) pt))
      (- (angle '(0 0 0) (vlax-curve-getFirstDeriv obj param))  (/ pi 2))
      nil))
  
  (defun daitc(v / obj)    
      (vlax-curve-getDistAtParam (setq obj (vlax-ename->vla-object v)) (vlax-curve-getEndParam obj)))
  
  ;;;
  
  (setq pl (car (entsel "\nChon Polyline:"))
li (car (entsel "\nChon duong thang vuong goc voi Polyline:"))
dail (daitc li)
dd (getpoint "\nDiem cuoi cua Polyline:")
cd (getreal "\nNhap buoc de rai:")
obj (vlax-ename->vla-object pl) 
dg (vlax-curve-getClosestPointTo obj (acet-dxf 10 (entget li)))
sl (getint "\nSo luong coc rai")
ct (vlax-curve-getDistAtPoint obj dg)
n 0
os (getvar "OSMODE"))
  (if (< (distance dd (vlax-curve-getStartPoint obj)) (distance dd (vlax-curve-getEndPoint obj)))
    (setq ki nil) (setq ki t))
  (setvar "OSMODE" 0)
  (repeat sl         
    (command "line"
    (setq dg1 (if ki (getp pl (+ ct (* (setq n (1+ n)) cd)))
     (getp pl (- ct (* (setq n (1+ n)) cd)))))   
    (polar dg1 (thgoc pl dg1) dail) ""))
  (setvar "OSMODE" os)
  (princ)
)

Cảm ơn bác nhiều lắm ạ, :D lisp hay wwoa' lun


<<

Filename: 287525_test.lsp
Tác giả: hainguyen2014
Bài viết gốc: 375693
Tên lệnh: cadviet
Nhờ Viêt Lisp Di Chuyển Đối Tượng Với Khoảng Cách Đều

 

May mắn là bản vẽ hainguyen2014 có sẵn 2 donut tại đầu và cuối đường dẫn nên  Lisp ...

>>

 

May mắn là bản vẽ hainguyen2014 có sẵn 2 donut tại đầu và cuối đường dẫn nên  Lisp  đúng trong trường hợp này. Tổng quát hơn chắc phải chọn  đường dẫn rồi mới quét chọn các Donut :) . Từ code có sẵn của bạn quansla, code lại theo ý tưởng đó :D :

(defun c:cadviet (/ cur ss lst n i L lr) (vl-load-com)
(defun trongtam_Donut (dt / ent ls10)
(setq ent (entget dt)) (setq ls10 (vl-remove-if '(lambda (x) (/= (car x) 10)) ent))
(mapcar '(lambda (x y) (* 0.5 (+ x y))) (cdr (car ls10)) (cdr (last ls10))) ) 

(command "undo" "be") (setq cur (car (entsel "Chon path curve :")))
(princ "Chon cac Donut :") (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 2))))
(setq lst (acet-ss-to-list ss) n (length lst) i 0) 
(setq L (vlax-curve-getDistAtPoint cur (vlax-curve-getendpoint cur)))
(foreach dt lst (setq lr (append lr (list (list dt (trongtam_Donut dt) 
(vlax-curve-getPointAtDist cur (/ (* i L) (1- n))) )))) (setq i (1+ i)) )
(foreach x lr (vla-move (vlax-ename->vla-object (car x)) (vlax-3d-point (cadr x)) 
(vlax-3d-point (last x)) ))
(command "undo" "e") (princ))

 

Cảm ơn anh pphung183 đã trợ giúp. 

Đường dẫn (line) trong file mục đích để kiểm tra thôi, không sử dụng để xác định phương. hi


<<

Filename: 375693_cadviet.lsp
Tác giả: hainguyen2014
Bài viết gốc: 375692
Tên lệnh: cadviet
Nhờ Viêt Lisp Di Chuyển Đối Tượng Với Khoảng Cách Đều

 

chắc là thế này :

(defun c:cadviet(/ A ANG B DELTA DI DT DT_CUOI DT_DAU K LST N P1 P2 R...
>>

 

chắc là thế này :

(defun c:cadviet(/ A ANG B DELTA DI DT DT_CUOI DT_DAU K LST N P1 P2 R SS)
(vl-load-com)
;;;(setvar "cmdecho" 0)
  (defun trongtam_Donut(dt)
    (setq ent (entget dt))
    (setq ls10 (vl-remove-if '(lambda(x)(/= (car x)10)) ent))
    (mapcar '(lambda(x y)
	       (* 0.5 (+ x y)))
	    (cdr (car ls10))(cdr (last ls10))))

  (setq ss (ssget '((0 . "LWPOLYLINE")(70 . 1)(90 . 2))))
  (setq lst (vl-sort (acet-ss-to-list ss)
		     '(lambda (x y) (< (car (trongtam_Donut x)) (car (trongtam_Donut y)))) ))
  (setq dt_dau (car lst)
	dt_cuoi (last lst)
	N (- (length lst) 1)
	di (distance (trongtam_Donut dt_dau)(trongtam_Donut dt_cuoi))
	ang (angle (trongtam_Donut dt_dau)(trongtam_Donut dt_cuoi))
	delta (/ di N 1.000)
	r '() k -1)
  (foreach dt lst
    (setq r (append r (list(list dt (trongtam_Donut dt)
				 (polar (trongtam_Donut dt_dau) ang (* (setq k (1+ k)) delta)))))))
  (setq dt (car r))
  (command "undo" "begin")
  (foreach dt r
    (command "move" (car dt) "" "_non" (cadr dt) "_non" (last dt)))
  (command "undo" "end")
;;;  (setvar "cmdecho" 1)
  (princ))

 

Cảm ơn anh gia_bach đã giải bài toán này giúp mình. 


<<

Filename: 375692_cadviet.lsp
Tác giả: hieuhx68
Bài viết gốc: 297202
Tên lệnh: vg
Vẽ vuông góc với 1 Pline bất kì

 

Update theo yêu cầu :

(defun c:Vg (/ curve pt ang )
  (if (setq curve (car (entsel "\nChon Curve : ")))
    (progn
  ...
>>

 

Update theo yêu cầu :

(defun c:Vg (/ curve pt ang )
  (if (setq curve (car (entsel "\nChon Curve : ")))
    (progn
      (or *len (setq *len 50))
      (initget 6)
      (setq *len (cond ((getdist (strcat "\nChieu dai <" (rtos *len) "> :"))) (*len)))
      (while (setq pt (getpoint "\n Chon diem tren Curve : "))
	(setq pt (vlax-curve-getClosestPointTo curve (trans pt 1 0))
	      ang (angle '(0 0) (Vlax-curve-getfirstderiv curve (vlax-curve-getParamAtPoint curve pt))) )
	(entmake (list '(0 . "LINE")(cons 10 pt)(cons 11 (polar pt (+ ang (/ pi 2) ) *len))(cons 62 3) ))
	(entmake (list '(0 . "LINE")(cons 10 pt)(cons 11 (polar pt (- ang (/ pi 2) ) *len))(cons 62 4) )) )))
  (princ) )

Thanks bác nhiều ạ. Vậy là lips đã hoàn thiện ngon lành rồi ạ.


<<

Filename: 297202_vg.lsp
Tác giả: Tue_NV
Bài viết gốc: 61542
Tên lệnh: ltt
Lisp làm tròn số ( là Text) trong CAD ???????
Thì bác cứ thử cái lisp của bác đi nó đâu có tác dụng gì đâu mà bảo?

Xin lỗi bạn mình bị lỗi 1 chỗ và đã sửa lại. Bạn thử nhé :...

>>
Thì bác cứ thử cái lisp của bác đi nó đâu có tác dụng gì đâu mà bảo?

Xin lỗi bạn mình bị lỗi 1 chỗ và đã sửa lại. Bạn thử nhé :

 

Xin admin và các cao thủ giúp thêm về vấn đề tròn số:

VD: số 0.34% thì kết qủa giữ nguyên = 0.34%

Nếu số 2.00% thì bỏ bớt số phía sau đi = 2%

Tôi phải chỉnh sửa rất nhiều bản vẽ như vậy. Rất mong được các bạn giúp đỡ cho. Cám ơn trước!

Tue_NV vẫn chưa hiểu là trong bản vẽ của bạn vừa có cả số thập phân (0.34) và có cả số %(0.34%) hay không?. Vì bạn chưa nói rõ

 

Thế này nhé :

Tue_NV sẽ lược bỏ theo ý của bạn : 0.34% -> thì kết qủa giữ nguyên = 0.34

Nếu số 2.00% thì bỏ bớt số phía sau đi = 2

 

Còn đuôi % thì bạn sử dụng Lisp thêm Text thêm vào vậy vì lí do :

 

Tue_NV vẫn chưa hiểu là trong bản vẽ của bạn vừa có cả số thập phân (0.34) và có cả số % (0.34%) hay không?

Vì bạn chưa nói rõ

 

Code này có chỉnh lại Lisp của bác ssg 1 chút :

;;;-------------------------------------------------------
(defun etype (e);;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun C:LTT( / ss n i oldDimzin e d v S)
(if (not n0) (setq n0 2))
(setq
ss (ssget '((0 . "TEXT,MTEXT")))
n (getint (strcat "\nSo chu so thap phan :"))
i 0
oldDimzin (getvar "dimzin")
)
(if n (setq n0 n) (setq n n0))
(setvar "dimzin" 8)
(repeat (sslength ss)
(setq e (ssname ss i))
(if (= (etype e) "MTEXT") (progn
(command "explode" e "")
(setq e (entlast))
))
(setq
d (entget e)
v (atof (cdr (assoc 1 d)))
S (rtos v 2 n)
d (subst (cons 1 S) (assoc 1 d) d)
)
(entmod d)
(setq i (1+ i))
)
(setvar "dimzin" oldDimzin)
(princ)
)

:s_big:


<<

Filename: 61542_ltt.lsp
Tác giả: anhsangxanh04kt
Bài viết gốc: 102558
Tên lệnh: vpl
Xin Lisp vẽ độ dốc dọc
Bạn dùng xem cái này có vừa ý không nhé

;;; Ve Pline theo chieu dai va do doc
;;; Writeb by Nguyen Van Tau Tel:0982.767.231
;;; 30 - 7 - 2010
(defun c:VPL (/ Pt Leng...
>>
Bạn dùng xem cái này có vừa ý không nhé

;;; Ve Pline theo chieu dai va do doc
;;; Writeb by Nguyen Van Tau Tel:0982.767.231
;;; 30 - 7 - 2010
(defun c:VPL (/ Pt Leng Slope X Y alpha)
 (setq Pt (getpoint "\nSpecify first point: "))
 (while (/= Leng 0.0)
   (setq Leng 0.0 )
   (vl-cmdf "_.pline" Pt)
   (setq Leng (getdist "\nSpecify length of line : "))
   (if (/= Leng nil)
     (progn
(setq Slope (getreal "\nSpecify slope of line <1/...>: ")
      alpha (atan Slope)
      X (* Leng (sin alpha))
      Y (* Leng (cos alpha))
      );
(setq Pt (list (+ X (car Pt)) (+ Y (cadr Pt))))
);
     (progn
(vl-cmdf "")
(exit)
);
     );end if
   );end while
 (princ)
 );end defun

bạn ơi. nhưng khi mình nhập độ dốc( theo%) vào thi không ra:(. bạn có thể giải thích cho minh <1/...> là sao. thanks nha:D


<<

Filename: 102558_vpl.lsp
Tác giả: phuongtran613
Bài viết gốc: 189572
Tên lệnh: mbl
đổi màu block reference và file xref

 

Lisp sau có chức năng Đổi màu Block (Cái này mình tham khảo lisp từ đâu đó và thêm tí mắm tí muối thôi). Hi vọng...

>>

 

Lisp sau có chức năng Đổi màu Block (Cái này mình tham khảo lisp từ đâu đó và thêm tí mắm tí muối thôi). Hi vọng đúng ý bạn

Mbl.gif

(defun err-ubc (s)
(if (/= s "Function cancelled")
(princ (strcat "\nError: " s))
)
(setq *error* olderr)
(princ)
)
(DEFUN C:mbl (/ BLK CBL CBL2 C ACL ALY NLY NCL)
(setq olderr *error* *error* err-ubc)
(setq C (acad_colordlg 1))      
(PROMPT "\n >Chon Blocks se thay doi mau: ")
(SETQ SS (SSGET '((0 . "INSERT"))))
(SETQ K 0)
(WHILE (< K (SSLENGTH SS))
	(setq CBL (tblsearch "BLOCK" (CDR (ASSOC 2 (ENTGET (SETQ BLK (SSNAME SS K)))))))
	(SETQ CBL2 (CDR (ASSOC -2 CBL)))
 (WHILE (BOUNDP 'CBL2)
  (SETQ EE (ENTGET CBL2))
(SETQ NCL (CONS 62 C))
  (SETQ ACL (ASSOC 62 EE))
  (IF (= ACL nil)
(SETQ NEWE (APPEND EE (LIST NCL)))
(SETQ NEWE (SUBST NCL ACL EE))
  )
  (ENTMOD NEWE)
  (SETQ CBL2 (ENTNEXT CBL2))
 )
 (ENTUPD BLK)
 (SETQ K (1+ K))
)
(setq *error* olderr)
)

 

Bác cho em xin thêm các lisp như trong link này nha.

http://www.cadonline.duyxuyen.vn/modules.php?name=Forums&file=viewtopic&t=17&postdays=0&postorder=asc&start=0

Cám ơn bác nhiều


<<

Filename: 189572_mbl.lsp
Tác giả: trieubb
Bài viết gốc: 211182
Tên lệnh: glt
Lisp tính lý trình các điểm trên 1 polyline/line

Hề hề hề

Phải chăng bạn cần cái này:


(defun c:glt (/ pl plst pa pd k l ltg p0 a lt lt1 lt2 txt tg etg...
>>

Hề hề hề

Phải chăng bạn cần cái này:


(defun c:glt (/ pl plst pa pd k l ltg p0 a lt lt1 lt2 txt tg etg txtp txtp1 txtp2 dl dl1 dl2)
(vl-load-com)
(command "undo" "be")
(setq ucsold (getvar "ucsname"))
(command "ucs" "w")
(setq pl (car (entsel "\n Chon polyline can ghi ly trinh")))
(setq plst (vl-sort (acet-geom-vertex-list pl) '(lambda (x y) (< (car x) (car y)))))
(setq pa (getstring t "\n Chon chieu ghi ly trinh <T or P>: "))
(if (= (strcase pa) "T")
   (setq pd (car plst))
   (setq pd (last plst))
)
(setq p0 (getpoint "\n Chon diem goc ghi ly trinh"))
(setq ltg (getreal "\n Nhap ly trinh goc: "))        
(setq k (getint "\n Chon so chu so thap phan: "))
(setq l (getint "\n Chon phuong an ghi ly trinh <1 or 2>: "))
(setq a (getpoint "\n Chon point can ghi ly trinh"))
(while ( /= a nil)
(if (= l 1)
   (progn
         (if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
             (setq lt (+ (- (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))
                              	(vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))  ) ltg )  )
             (setq lt (+ (- (vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))
                              	(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))
                                	) ltg )  )
         )
         (setq dl (abs (- lt (* (fix (/ lt 1000)) 1000))))
         (if (< (fix dl) 100)
             (if (< (fix dl) 10)
                 (setq txtp (strcat "00" (rtos dl 2 k)))
                 (setq txtp (strcat "0" (rtos dl 2 k)))
             )
             (setq txtp (rtos dl 2 k))
         )
         (if (> lt 0)
             (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" txtp))
             (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "-" txtp))
         )
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
   )
   (progn
    	(if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
        	(progn
                 (setq lt1 (+ (- (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))
                                    	(vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))  ) ltg )  )
                 (setq lt2 (+ (- (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh")))
                                    	(vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))  ) ltg ))
        	)
        	(progn
            	(setq lt1 (+ (- (vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))
                                       (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))  ) ltg ))
            	(setq lt2 (+ (- (vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))
                                       (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh"))) ) ltg ))
        	)
         )
         (setq dl1 (abs (- lt1 (* (fix (/ lt1 1000)) 1000))))
         (if (< (fix dl1) 100)
             (if (< (fix dl1) 10)
                 (setq txtp1 (strcat "00" (rtos dl1 2 k)))
                 (setq txtp1 (strcat "0" (rtos dl1 2 k)))
             )
             (setq txtp1 (rtos dl1 2 k))
         )
         (setq dl2 (abs (- lt2 (* (fix (/ lt2 1000)) 1000))))
         (if (< (fix dl2) 100)
             (if (< (fix dl2) 10)
                 (setq txtp2 (strcat "00" (rtos dl2 2 k)))
                 (setq txtp2 (strcat "0" (rtos dl2 2 k)))
             )
             (setq txtp2 (rtos dl2 2 k))
         )
         (if (and (>=  lt1 0) (>=  lt2 0))
          	(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "+" txtp2 )))
         (if (and (>=  lt1 0) (<  lt2 0))
             (setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "-" txtp2 )))
         (if (and (<  lt1 0) (>=  lt2 0))
          	(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "-" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "+" txtp2 )))
         (if (and (<  lt1 0) (<  lt2 0))
          	(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "-" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "-" txtp2 )))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
	)
)
(setq a (getpoint "\n Ban hay chon diem tiep theo: "))
)
(if (/= ucsold "")
   (command "ucs" "p")
)
(command "undo" "e")
(princ)
)



Hề hề hề.

@ phamxuanly gtvt: hãy gửi bản vẽ bị lỗi lên...

 

 

 

Kính chuyển bác phamthanhbinh lisp của bác khi chọn lý trình gốc là 0 thì tại 1000m ghi là Km1+000, 2000m ghi là Km2+000, 3000m ghi là Km3+000 thì ok, nhưng đến 4000m nó lại ghi là Km3+1000 bác xem lại nhé


<<

Filename: 211182_glt.lsp
Tác giả: duynguyencute
Bài viết gốc: 396104
Tên lệnh: tab2exl
chuyển thống kê thép sang excel

Hề hề hề,

Bạn dùng thử cái này coi sao nhé.

Mình viết và chỉ lấy ra các giá trị cần dùng để tinh toán mà...

>>

Hề hề hề,

Bạn dùng thử cái này coi sao nhé.

Mình viết và chỉ lấy ra các giá trị cần dùng để tinh toán mà thôi,nghĩa là chỉ lấy từ cột đường kính trở đi. Các số liệu khác mình thấy không cần thiết nên không mất công lấy làm chi. Còn nếu bạn thấy cần thì hãy tự bổ sung thêm dựa trên cái mình đã làm nhé.

 
(defun c:tab2exl (/ lst1 lst2 lst3 lst4 lst5 lst6)
(setq ssbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 66 1))))
          fn (getfiled "Chon file de save" "" "csv" 1)
          fw (open fn "w"))
(foreach bl ssbl
      (setq en (entnext bl))
      (while (/= (cdr (assoc 0 (entget en))) "SEQEND")
         	(if (= (cdr (assoc 0 (entget en))) "ATTRIB")
             	(cond
                   	((or (= (cdr (assoc 2 (entget bl))) "TK_2") (= (cdr (assoc 2 (entget bl))) "TK_4")
                              (= (cdr (assoc 2 (entget bl))) "TK_5") (= (cdr (assoc 2 (entget bl))) "TK_6"))
                            (if (= (cdr (assoc 2 (entget en))) "TL") (setq lst6 (append lst6 (list (cdr (assoc 1 (entget en)))))))
                            (if (= (cdr (assoc 2 (entget en))) "DT") (setq lst5 (append lst5 (list (cdr (assoc 1 (entget en)))))))
                            (if (= (cdr (assoc 2 (entget en))) "SLA") (setq lst4 (append lst4 (list (cdr (assoc 1 (entget en)))))))
                            (if (= (cdr (assoc 2 (entget en))) "SL1") (setq lst3 (append lst3 (list (cdr (assoc 1 (entget en)))))))
                            (if (= (cdr (assoc 2 (entget en))) "DAI") (setq lst2 (append lst2 (list (cdr (assoc 1 (entget en)))))))
                            (if (= (cdr (assoc 2 (entget en))) "DK") (setq lst1 (append lst1 (list (cdr (assoc 1 (entget en)))))))
                   	)
                   	( T nil)
                )
            )
            (setq en (entnext en))
      )
)
(setq ldata (mapcar 'list lst1 lst2 lst3 lst4 lst5 lst6))
(princ  "DK, DAI, SL1, SLA, DT, TL\n" fw)
(foreach data ldata
    (setq txt (strcat  (nth 0 data)  ","  (nth 1 data) "," (nth 2 data)  "," (nth 3 data)  "," (nth 4 data)  "," (nth 5 data) ","))
 	(princ (strcat txt "\n") fw)
)
(close fw)
(princ)
)
Chúc bạn vui.

 

như bảng thống kê của em thì sữa code sao bác http://www.cadviet.com/upfiles/5/85997_bv_thong_ke.dwg

,nhờ các bác giúp em với, em cám ơn nhiều ah


<<

Filename: 396104_tab2exl.lsp
Tác giả: conghoa
Bài viết gốc: 280465
Tên lệnh: bl1
chuyển các đối tượng trong block về cùng 1 layer

 

Hầy, sửa đi một tẹo của bạn KK. Code tường minh ở chỗ nào cần tường minh thôi ^^

(defun C:bl1(/ lay...
>>

 

Hầy, sửa đi một tẹo của bạn KK. Code tường minh ở chỗ nào cần tường minh thôi ^^

(defun C:bl1(/ lay m)
	(vl-load-com)	
	(command "UNDO" "BE")
	(setq lay (getvar 'CLAYER))(setvar 'cmdecho 0)
	(vlax-for blks (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
		(vlax-for e blks 
			(vla-put-color e 
				(cond 
					((/= (setq m (vla-get-color e)) 256) m)
					((cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (vla-get-Layer e))))))
				)
			)
			(vla-put-layer e lay)  
		)
	)
	(command "UNDO" "END")
(princ)
)

 

@ketxu chỉnh giúp mình thành chọn từng block nhé! Thanks.


<<

Filename: 280465_bl1.lsp
Tác giả: thanhluuqt
Bài viết gốc: 393695
Tên lệnh: zz
nội suy cao độ tại giao điểm

Chương trình nội suy cao độ theo các đường đồng mức và/hoặc các điểm tham chiếu. Cung cách hoạt động đúng như ssg đã trình bày ở bài...

>>

Chương trình nội suy cao độ theo các đường đồng mức và/hoặc các điểm tham chiếu. Cung cách hoạt động đúng như ssg đã trình bày ở bài trước. Tên lệnh: ZZ

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;
;;;This program interpolate elevation at 1 point-object
;;;from 2 equal level polylines and/or reference point-objects
;;;Elevation of each reference point-object is specified by nearest text_object
;;;Written by ssg - December 2007 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;

;;;--------------------------------------------------------------------
(defun mod(x y) (fix (rem x y)) ) ;;;Remainder result of divide, return INT
;;;--------------------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt at p
(setq
sty (getvar "textstyle")
d (tblsearch "style" sty)
h (cdr (assoc 40 d))
)
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p)
(if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)
;;;--------------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss)
(setq
e (ssname ss i)
Le (append Le (list e))
i (1+ i)
)
)
Le
)
;;;--------------------------------------------------------------------
(defun ss2Lp(ssp / Lp i e p) ;;;Convert ss of points to list of 3Dpoints
(setq i 0 Lp nil)
(repeat (sslength ssp)
(setq
e (ssname ssp i)
p (cdr (assoc 10 (entget e)))
Lp (append Lp (list p))
i (1+ i)
)
)
Lp
)
;;;--------------------------------------------------------------------
(defun aver(Ln / tot x) ;;;Average List of Number
(setq tot 0)
(foreach x Ln (setq tot (+ tot x)))
(/ tot (length Ln))
)
;;;--------------------------------------------------------------------
(defun distance_xy (p1 p2) ;;;Distance between 2 projections of p1 and p2
(setq
pp1 (list (car p1) (cadr p1) 0)
pp2 (list (car p2) (cadr p2) 0)
)
(distance pp1 pp2)
)
;;;--------------------------------------------------------------------
(defun inter2p(p p1 p2) ;;;Interpolate zp from p1, p2
(setq
d1 (distance_xy p p1)
d2 (distance_xy p p2)
z1 (caddr p1)
z2 (caddr p2)
)
(/ (+ (* d1 z2) (* d2 z1)) (+ d1 d2))
)
;;;--------------------------------------------------------------------
(defun ariang(p1 p2 p3) ;;;Arithmetic Angle between 2 vector p1p2 and p2p3
(setq
a1 (angle p2 p1)
a2 (angle p2 p3)
)
(abs (- (abs (- a1 a2)) pi))
)
;;;--------------------------------------------------------------------
(defun pair(p Lp / Lpair Lpass p1 p2 ass chk x y)
;;;Arrange list of points Lp in pairs, opposite by p. Return list of pair_list
(setq Lpair nil)
(while Lp
(setq
p1 (car Lp)
ass (lambda (x) (cons x (ariang p1 p x)))
chk (lambda (x y) (< (cdr x) (cdr y)))
Lpass (vl-sort (mapcar 'ass Lp) 'chk)
p2 (car (car Lpass))
Lpair (append Lpair (list (list p1 p2)))
Lp (vl-remove p1 Lp)
Lp (vl-remove p2 Lp)
)
)
Lpair
)
;;;--------------------------------------------------------------------
(defun getZ(p sst) ;;;Get nearest text in sst, assign to zp
(setq
Lt (ss2ent sst)
neap (lambda (x y)
(<
(distance_xy p (cdr (assoc 10 (entget x))))
(distance_xy p (cdr (assoc 10 (entget y))))
)
)
Lt (vl-sort Lt 'neap)
z (atof (cdr (assoc 1 (entget (car Lt)))))
p (subst z (caddr p) p)
)
)
;;;--------------------------------------------------------------------
(defun placp(pl p / pp) ;;;Check pl across p, different z
(vl-load-com)
(setq pp (vlax-curve-getClosestPointTo pl p))
(and (= (car p) (car pp)) (= (cadr p) (cadr pp)))
)
;;;--------------------------------------------------------------------


;;;MAIN PROGRAM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;
(defun C:ZZ(/ oldos p Ln Lpp res sspl pl1 pl2 pp1 pp2 v1 ssp sst Lp x)

;;;INPUT DATA
(setq oldos (getvar "osmode"))
(setvar "osmode" 8)
(setq
p (getpoint "\nBase point:")
Ln nil Lpp nil res nil
)
(setvar "osmode" 0)
(prompt "\nSelect 2 Equal Level Polylines or ...")
(setq sspl (ssget '((0 . "LWPOLYLINE"))))

;;;INTERPOLATE FROM EQUAL LEVEL PLINE
(if (and sspl (setq pl1 (ssname sspl 0) pl2 (ssname sspl 1))) (progn
(vl-load-com)
(setq
pp1 (vlax-curve-getClosestPointTo pl1 p)
pp2 (vlax-curve-getClosestPointTo pl2 p)
)
;;;If pline across p then write result and exit
(if (and (= (car p) (car pp1)) (= (cadr p) (cadr pp1))) (setq res (caddr pp1)))
(if (and (= (car p) (car pp2)) (= (cadr p) (cadr pp2))) (setq res (caddr pp2)))
(if res (progn
(alert "The polyline across the point")
(wtxt (rtos res) p)
(setvar "osmode" oldos)
(princ)
(exit)
))
;;;Else continue...
(setq
v1 (inter2p p pp1 pp2)
Ln (append Ln (list v1))
)
))

;;;INTERPOLATE FROM REFERENCE POINTS
(prompt "\nSelect Reference Points or ...")
(if (and (setq ssp (ssget '((0 . "POINT"))))
(setq sst (ssget "X" '((0 . "TEXT"))))
)
(progn
(setq Lp (vl-remove p (ss2Lp ssp)))
(if (/= (mod (length Lp) 2) 0)
(progn
(alert "Number of reference points must be in Even (n = 2k). Action is canceled!")
(exit)
)
(progn
(foreach x Lp (setq Lp (subst (getZ x sst) x Lp)))
(setq Lpp (pair p Lp))
(foreach x Lpp (setq Ln (append Ln (list (inter2p p (car x) (cadr x))))))
)
)
)
)

;;;WRITE RESULT
(if Ln (wtxt (rtos (aver Ln)) p))
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;

Thuyết minh hoạt động của chương trình:

1) Nội suy theo đường đồng mức: từ điểm đang xét, kẻ 2 đường vuông góc (theo mặt bằng) với 2 đường đồng mức. Sau đó thực hiện nội suy theo công thức:

Z = (d1*Z2 + d2*z1) / (d1 + d2), không quan tâm đến 3 điểm có thẳng hàng hay không.

 

2) Nội suy theo các cặp điểm tham chiếu:

Công thức nội suy vẫn như trên. Yêu cầu tổng số điểm chọn, trừ điểm đang xét, phải là số chẵn. Nếu không, chương trình sẽ ra thông báo và sau đó exit.

Xem ra cũng khá dài dòng vì để lấy được dữ liệu của 1 điểm phải cần đến 2 đối tượng khác loại nhau (lấy X, Y từ point và lấy Z từ text). Trong 2 thành phần đó, chương trình dựa vào point là chính. Độ cao Z được lấy theo đối tượng text gần nhất so với point. Lưu ý: điểm chuẩn của text đối với chương trình là điểm insert của nó. Do đó, trong các vùng phức tạp, mật độ text dày đặc, có khả năng gặp phải trường hợp “râu ông nọ cắm cằm bà kia”! Nếu có thể, nên chuyển điểm insert của text về trùng (x, y) với đối tượng point mà nó biểu diễn để bảo đảm cho chương trình chạy chính xác.

 

3) Theo mình, các bản vẽ đã “lỡ có” rồi thì thôi. Nhưng khi lập bản vẽ mới, nên có quy ước nhất quán sẽ tạo điều kiện thuận lợi hơn cho lập trình khi cần. Chẳng hạn, cách ghi text và point, nếu bảo đảm được 1 trong 2 điều kiện sau thì chương trình này sẽ đơn giản hơn rất nhiều, và hoàn toàn không phải bận tâm đến vấn đề nêu trên:

- Các đối tượng point được vẽ đúng độ cao z (giống như các pline đồng mức).

- Các đối tượng text có điểm insert đúng tọa độ x, y của point

 

Vbao xem và test trong nhiều trường hợp khác nhau. Nếu có vấn đề gì thì phản hồi, mình sẽ sửa và bổ sung.

Anh cho e hỏi sao lisp này e k dùng dc ạ? load vào xong, nhưng đánh lệnh zz thì không được ạ.không tồn tại lệnh zz. còn  Cái lisp Test thì em lại dùng ok ạ? 


<<

Filename: 393695_zz.lsp
Tác giả: mehonphap88
Bài viết gốc: 337610
Tên lệnh: laytd ghitd
Lisp thống kê tọa độ địa chính

anh ơi anh có thể sửa lại dùm em file này. chạy theo chiều kim đồng hồ không? ( hoặc anh nào cũng được ạ). em cảm ơn nhiều

>>

anh ơi anh có thể sửa lại dùm em file này. chạy theo chiều kim đồng hồ không? ( hoặc anh nào cũng được ạ). em cảm ơn nhiều

Mình đang dùng lsp này. Bạn nào đang làm địa chính vẽ 1/500 in 2=1 thì dùng rất phù hợp.  Còn in tỷ lệ khac thì chỉnh lại code lsp là đc
Lệnh như sau :
ghitd (Xuất bảng tọa độ góc ranh theo cách pick điểm tuần tự do ng dùng chỉ định)
laytd (Xuất bảng tọa độ theo cách ng dùng pick chọn 1 điểm trong vùng muốn xuất tọa độ. kết quả xuất ra bảng tọa độ theo nguyên tắc lấy điểm thứ 1 là điểm cao nhất và chạy tọa độ cùng chiều kim đồng hồ )


;Ndaitfunc 2013
;Viet boi : Ndait Nguyen
;;-------------------------------------------------------
;Ghi toa do tu dong theo chieu kim dong ho
(defun c:laytd (/ p bound k lstpt lstx lsty newlst i bien t1 p1 diem x y ymax kmax n c new name ltext diemve pt p1
p2 p3 p4 p5 p6 pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 pt10 pt11 pt12 pt13 pt14 pt15 pt16 pt17)
(luuBHT)
(setq p (getpoint "\nPick point :"))
(setvar "osmode" 0)
(taolop '("vunglaytd" "diemtd" "texttd"))
(setvar "clayer" "vunglaytd")
(command "style" "APTIMA" "vaptimn.ttf" 0 1 0 "" "" "")
(if (/= p nil) (command "-Boundary" p "" ));end if
(setq bound (entget (entlast)))
(setq k (cdr (assoc 90 bound)))
(setq lstpt '() lstx '() lsty '() newlst '())
(setq i 1)
(while (<= i k)
(progn
(setq bien (assoc 10 bound))
(setq t1 (member bien bound))
(setq p1 (car t1))
(setq bound (cdr t1))
(setq diem (cdr p1))
(setq x (car diem) y (cadr diem))
(setq lstx (append lstx (list x)) lsty (append lsty (list y)))
(setq lstpt (append lstpt (list diem)))
(setq i (+ 1 i))));while
(setq ymax (maximum lsty))
(setq kmax (vl-position ymax (reverse lsty)))
(setq lstpt (reverse lstpt))
(setq newlst (member (nth kmax lstpt) lstpt))
(setq n 0)
(repeat kmax (setq newlst (append newlst (list (nth n lstpt)))) (setq n (+ 1 n)))
(setq c 0 new '())
(foreach name newlst (setq new (append new (list (append (list (setq c (1+ c))) name)))))
(setq c 1 new (append new (list (nth 0 new))))
(setq ltext '())
(setq ltext (append ltext (list (nth 0 new))))
(setq newlst (append newlst (list (nth 0 newlst))))
(repeat (- (length new) 1)
(setq ltext (append ltext (list (append (nth c new)
(list (distance (append (nth (- c 1) newlst) '(0.0)) (append (nth c newlst) '(0.0))))))))
(setq c (1+ c)));repeat
(setq n 0)
(setvar "clayer" "diemtd")
(repeat (- (length new) 1)
(ndait_addtext (itoa (car (nth n new))) "texttd" 256 (cdr (nth n new)) 1.0 0.0 "aptima" "BL")
(command "CIRCLE" (cdr (nth n new)) "0.25" "")
(setq n (1+ n)));repeat
(setq diemve (getpoint "\nChon vi tri ve bang toa do : "))
(if (null diemve)
(prompt "\nKhong ve bang ! ")
(progn
(setvar "osmode" 0)
(setvar "orthomode" 0)
(taolop '("Text_Bang" "Line_Bang"))
(setq pt diemve)
(taochu "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH" "Text_Bang" 256 (polar (polar pt 0.0 2.5) (* 0.5 Pi) 0.75) 1.0 "Aptima")
(command "layer" "s" "Line_Bang" "")
(setq pt1 pt pt (polar pt (* 1.5 pi) 0.25))
(setq p (polar (polar pt 0.0 0.5) (* 1.5 pi) 2.0))
(setq p1 p
p2 (polar (polar p1 0.0 11.8) (* 0.5 pi) 0.25)
p3 (polar (polar p1 0.0 0.5) (* 1.5 Pi) 2.25)
P4 (polar p3 0.0 7.0)
p5 (polar p4 0.0 9.0)
p6 (polar (polar p5 0.0 7.5) (* 0.5 Pi) 1.5))
(setq pt2 (polar pt1 0.0 5.5)
pt3 (polar pt2 0.0 18.0)
pt4 (polar pt3 0.0 5.5)
pt5 (polar pt2 (* 1.5 Pi) 2.5)
pt6 (polar pt5 0.0 9.0)
pt7 (polar pt6 0.0 9.0)
pt8 (polar pt1 (* 1.5 Pi) 5.0)
pt9 (polar pt8 0.0 5.5)
pt10 (polar pt9 0.0 9.0)
pt11 (polar pt10 0.0 9.0)
pt12 (polar pt11 0.0 5.5))
(taochu "Soá hieäu" "Text_Bang" 256 p1 1.0 "Aptima")
(taochu "Toïa ñoä" "Text_Bang" 256 p2 1.0 "Aptima")
(taochu "ñieåm" "Text_Bang" 256 p3 1.0 "Aptima")
(taochu "X( m )" "Text_Bang" 256 p4 1.0 "aptima")
(taochu "Y( m )" "Text_Bang" 256 p5 1.0 "aptima")
(taochu "Caïnh" "Text_Bang" 256 p6 1.0 "aptima")
(command "layer" "s" "Line_Bang" "")
(command "line" pt1 pt2 pt5 pt6 pt7 pt3 pt4 pt12 pt11 pt10 pt9 pt8 pt1 "")
(command "line" pt2 pt3 "")
(command "line" pt5 pt9 "")
(command "line" pt6 pt10 "")
(command "line" pt7 pt11 "")
(setq pt (polar pt (* 1.5 pi) 6.9))
(setq i 0)
(repeat (length ltext) (ghihang pt (nth i ltext)) (setq i (1+ i)) (setq pt (polar pt (* 1.5 pi) 2.0)))
(setq pt13 (polar pt8 (* 1.5 Pi) (+ (* 2.0 (length ltext)) 0.25)))
(setq pt14 (polar pt13 0.0 5.5)
pt15 (polar pt14 0.0 9.0)
pt16 (polar pt15 0.0 9.0)
pt17 (polar pt16 0.0 5.5))
(command "layer" "s" "Line_Bang" "")
(command "line" pt8 pt13 pt14 pt9 "")
(command "line" pt14 pt15 pt10 "")
(command "line" pt15 pt16 pt11 "")
(command "line" pt16 pt17 pt12 "")
));if
(traBHT)
(princ))
;;----------------------------------------------------------------
;;;Xuat so lieu toa do diem ra file va danh so thu tu
(defun c:ghitd (/ SBD DIEMDAU pt pt0 canh diem text text0 dspt ltext DIEMCUOI Tongdiem diemve i f fl)
(luuBHT)
;(setq TL (getvar "userr1"))
;(if (<= TL 0.0) (tyle))
(setvar "cmdecho" 0) (setvar "cecolor" "256")
(setq dspt '() ltext '() pt0 nil canh nil)
(Setq SBD (getint "\n Nhap so hieu diem bat dau ghi toa do : <Enter=1> "))
(if (null SBD) (setq SBD 1) (setq SBD SBD))
(command "style" "APTIMA" "vaptimn.ttf" 0 1 0 "" "" "")
(taolop '("MiaP" "MiaT"))
(SETQ DIEMDAU SBD)
(while (setq pt (getpoint (strcat "\n Chon diem toa do : <Mia so " (itoa SBD) "> (Enter de ket thuc)")))
(if (not (null pt0)) (setq canh (distance pt0 pt)))
(setq pt0 pt)
(setq diem (strcat (itoa SBD) " " (trtos (car pt) 3) " " (trtos (cadr pt) 3)))
(setq text (list SBD (car pt) (cadr pt) canh))
(command "layer" "s" "MiaP" "")
(command "point" pt "")
(command "CIRCLE" pt "0.25" "")
(taochu (itoa SBD) "MiaT" 256 pt 1.0 "Aptima")
(setq SBD (1+ SBD))
(setq dspt (append dspt (list diem)))
(setq ltext (append ltext (list text)))
);end while
(setq text0 (nth 0 ltext))
(setq canh (distance (list (nth 1 text0) (nth 2 text0) 0) pt0))
(Setq text (list (nth 0 text0) (nth 1 text0) (nth 2 text0) canh))
(setq ltext (append ltext (list text)))
(setq Tongdiem (itoa (- SBD diemdau)))
(SETQ DIEMCUOI (- SBD 1))
(setq diemve (getpoint "\nChon vi tri ve bang toa do : "))
(if (null diemve)
(prompt "\nKhong ve bang ! ")
(progn
(setvar "osmode" 0)
(setvar "orthomode" 0)
(taolop '("Text_Bang" "Line_Bang"))
(setq pt diemve)
(taochu "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH"
"Text_Bang" 256 (polar (polar pt 0.0 2.5) (* 0.5 Pi) 0.75) 1.0 "Aptima")
(command "layer" "s" "Line_Bang" "")
(setq pt1 pt pt (polar pt (* 1.5 pi) 0.25))
(setq p (polar (polar pt 0.0 0.5) (* 1.5 pi) 2.0))
(setq p1 p
p2 (polar (polar p1 0.0 11.8) (* 0.5 pi) 0.25)
p3 (polar (polar p1 0.0 0.5) (* 1.5 Pi) 2.25)
P4 (polar p3 0.0 7.0)
p5 (polar p4 0.0 9.0)
p6 (polar (polar p5 0.0 7.5) (* 0.5 Pi) 1.5)) ;_ end of setq
(setq pt2 (polar pt1 0.0 5.5)
pt3 (polar pt2 0.0 18.0)
pt4 (polar pt3 0.0 5.5)
pt5 (polar pt2 (* 1.5 Pi) 2.5)
pt6 (polar pt5 0.0 9.0)
pt7 (polar pt6 0.0 9.0)
pt8 (polar pt1 (* 1.5 Pi) 5.0)
pt9 (polar pt8 0.0 5.5)
pt10 (polar pt9 0.0 9.0)
pt11 (polar pt10 0.0 9.0)
pt12 (polar pt11 0.0 5.5)) ;_ end of setq
(taochu "Soá hieäu" "Text_Bang" 256 p1 1.0 "Aptima")
(taochu "Toïa ñoä" "Text_Bang" 256 p2 1.0 "Aptima")
(taochu "ñieåm" "Text_Bang" 256 p3 1.0 "Aptima")
(taochu "X( m )" "Text_Bang" 256 p4 1.0 "aptima")
(taochu "Y( m )" "Text_Bang" 256 p5 1.0 "aptima")
(taochu "Caïnh" "Text_Bang" 256 p6 1.0 "aptima")
(command "layer" "s" "Line_Bang" "")
(command "line" pt1 pt2 pt5 pt6 pt7 pt3 pt4 pt12 pt11 pt10 pt9 pt8 pt1 "") ;_ end of command
(command "line" pt2 pt3 "")
(command "line" pt5 pt9 "")
(command "line" pt6 pt10 "")
(command "line" pt7 pt11 "")
(setq pt (polar pt (* 1.5 pi) 6.9))
(setq i 0)
(repeat (length ltext) (ghihang pt (nth i ltext)) (setq i (1+ i)) (setq pt (polar pt (* 1.5 pi) 2.0)))
(setq pt13 (polar pt8 (* 1.5 Pi) (+ (* 2.0 (length ltext)) 0.25))
pt14 (polar pt13 0.0 5.5)
pt15 (polar pt14 0.0 9.0)
pt16 (polar pt15 0.0 9.0)
pt17 (polar pt16 0.0 5.5))
(command "layer" "s" "Line_Bang" "")
(command "line" pt8 pt13 pt14 pt9 "")
(command "line" pt14 pt15 pt10 "")
(command "line" pt15 pt16 pt11 "")
(command "line" pt16 pt17 pt12 "")))
(if (/= (setq f (getstring "\n<Ten FILE> luu toa do diem , Go <ENTER> neu khong luu : ")) "")
(progn
(if (findfile f) (setq fl (open f "a")) (setq fl (open f "w")))
(write-line "DANH SACH TOA DO DIEM " fl)
(write-line (strcat "File name : " (getvar "dwgprefix") (getvar "dwgname")) fl)
(write-line (strcat "TONG SO DIEM : " Tongdiem) fl)
(write-line (strcat "DIEM DAU : " (itoa DIEMDAU) " DIEM CUOI : " (itoa DIEMCUOI)) fl)
(setq i 0)
(repeat (length dspt) (write-line (nth i dspt) fl) (setq i (1+ i)))))
(if fl (close fl))
(traBHT)
(princ))
;;Dung cho ham ghitd
(defun ghihang (point hang / p p1 p2 p3 pt pt2 pt3 pt4 pt5 t1 t2 t3 t4)
(setq pt point
p (polar (polar pt 0.0 2.0) (/ pi 2.0) 0.25)
t1 (rtos (car hang) 2 0)
t2 (trtos (cadr hang) 3)
t3 (trtos (cadr (cdr hang)) 3))
(if (not (null (nth 3 hang))) (setq t4 (trtos (nth 3 hang) 2)))
(setq p1 p
p2 (polar p1 0.0 12.0)
p3 (polar p2 0.0 8.5)
p4 (polar (polar p3 0.0 5.5) (* 0.5 Pi) 1.0))
(taochu t1 "Text_Bang" 256 p1 0.9 "aptima")
(Ndait_addtext t3 "Text_Bang" 256 p2 0.9 nil "aptima" "R")
(Ndait_addText t2 "Text_Bang" 256 p3 0.9 nil "aptima" "R")
(if (not (null t4)) (Ndait_addText t4 "Text_Bang" 256 p4 0.9 nil "aptima" "R")));end of defun
;-----------------------------------
;Cac ham dung chung
;;Luu va tra bien he thong
(defun luuBHT ()
(setq
auts (getvar "autosnap")
blip (getvar "blipmode")
ceco (getvar "cecolor")
clay (getvar "clayer")
cmec (getvar "cmdecho")
fdia (getvar "filedia")
osmo (getvar "osmode")
orth (getvar "orthomode")
plwi (getvar "plinewid")
pola (getvar "polarmode")
tsty (getvar "textstyle")) ;_ end of setq
) ;_ end of defun
(defun traBHT ()
(setvar "autosnap" auts)
(setvar "blipmode" blip)
(setvar "cecolor" ceco)
(setvar "clayer" clay)
(setvar "cmdecho" cmec)
(setvar "filedia" fdia)
(setvar "osmode" osmo)
(setvar "orthomode" orth)
(setvar "plinewid" plwi)
(setvar "polarmode" pola)
(setvar "textstyle" tsty)
) ;_ end of defun
;---
;;Tao lop theo danh sach di kem
(defun taolop (dslop)
(mapcar '(lambda (a) (if (null (tblsearch "layer" a)) (command "layer" "N" a ""))) dslop)
)
;-----
;Ham tao text
(defun taochu (noidung lop mau diem caochu kieu / x y)
(setq x (car diem) y (cadr diem))
(entmod (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 lop) (cons 62 mau)
(cons 100 "AcDbText") (list 10 x y 0.0) (cons 40 caochu)
(cons 1 noidung) (cons 7 kieu))))
) ;defun
(defun Ndait_addtext (noidung lop mau diem caochu goc kieu canhchu / x y va ha)
(cond
((= canhchu "L") (setq va 0 ha 0));Left
((= canhchu "C") (setq va 0 ha 1));Center
((= canhchu "R") (setq va 0 ha 2));Right
;((= canhchu "A") (setq va 0 ha 3));Aligned
((= canhchu "M") (setq va 0 ha 4));Middle
;((= canhchu "F") (setq va 0 ha 5));Fit
((= canhchu "TL") (setq va 3 ha 0));Top Left
((= canhchu "TC") (setq va 3 ha 1));Top Center
((= canhchu "TR") (setq va 3 ha 2));Top Right
((= canhchu "ML") (setq va 2 ha 0));Middle Left
((= canhchu "MC") (setq va 2 ha 1));Middle Center
((= canhchu "MR") (setq va 2 ha 2));Middle Right
((= canhchu "BL") (setq va 1 ha 0));Bottom Left
((= canhchu "BC") (setq va 1 ha 1));Bottom Center
((= canhchu "BR") (setq va 1 ha 2));Bottom Right
(T (setq va 0 ha 0));canhchu false -> Left
);cond
(if (null (tblsearch "style" kieu)) (setq kieu (getvar "textstyle")))
(if (null goc) (setq goc 0.0))
(if (null caochu) (setq caochu 1.0))
(if (null diem) (progn (initget 1) (setq diem (getpoint "\npick point :"))))
(if (null mau) (setq mau 256))
(if (null lop) (setq lop (getvar "clayer")))
(setq x (car diem) y (cadr diem))
(entmod (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 lop)
(cons 62 mau) (cons 100 "AcDbText") (list 10 x y 0.0)
(cons 40 caochu) (cons 50 goc)(cons 1 noidung) (cons 7 kieu)
(cons 72 ha) (list 11 x y 0.0) (cons 100 "AcDbText") (cons 73 va))))
);defun
;Tra ve so lon nhat trong danh sach a
(defun maximum (a)
(setq i 0 maxa (max (nth 0 a) (nth 1 a)))
(repeat (length a) (setq maxa (max (nth i a) maxa)) (setq i (1+ i)))
maxa)
;;Doi so thuc sang chuoi (giong rtos)
;;VD (trtos 1.05 3) -> "1.050"
(defun trtos (Num dec / HSLT N0 N1 N2 N3 them0 them1 CHU)
(setq HSLT dec N0 (+ Num 0.000000001) N1 (- N0 (fix N0)) N2 (rtos N1 2 HSLT)
N3 (- (strlen N2) 2) them0 "." them1 "")
(if (>= N3 HSLT)
(setq CHU (rtos N0 2 HSLT))
(if (= N3 -1)
(setq CHU (strcat (rtos N0 2 HSLT)
(if (= HSLT 0)
(setq them0 "") (repeat HSLT (setq them0 (strcat them0 "0"))))))
(setq CHU (strcat (rtos N0 2 HSLT)
(repeat (- HSLT N3) (setq them1 (strcat them1 "0")))))
);if
);if
CHU)
;the end


ps: trên máy người dùng nhất định phải có font Aptima (vaptimn.ttf) nếu không lsp sẽ bị lỗi.

<<

Filename: 337610_laytd_ghitd.lsp
Tác giả: namgiangduy89
Bài viết gốc: 386457
Tên lệnh: lbtd
Lisp thống kê tọa độ địa chính

Hề hề hề,

Muốn cụ thì có cụ :

Xin lỗi bác Duy vì mình chôm ít đồ của bác để xài cho nó lẹ. Có chỉnh...

>>

Hề hề hề,

Muốn cụ thì có cụ :

Xin lỗi bác Duy vì mình chôm ít đồ của bác để xài cho nó lẹ. Có chỉnh sửa chút chút cho nó hợp với mưu đồ của chủ thớt.

http://www.cadviet.com/upfiles/3/5194_taobangtoadotrichthua.lsp

 

 
(defun c:lbtd (/ oldos en enlst e1 i n dvbd db1 dth dtn)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuyen gia tri goc tu do sang radian
;;;Cu phap su dung (duy:s_do>radian giatri)
;;;giatri la goc tinh theo do, kq la goc tinh theo radian
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:s_do>radian (gt / gt kq)
(setq kq (* (/ pi 180) gt))
kq)
 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao moi text
;;;Cu phap su dung (duy:t_text diemchen docao gocquay canhle noidung textstyle layer color)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_text (d c g cl nd k la co / d c g cl nd k la co)
(cond
((= cl "trai") (setq kcl 0))
((= cl "phai") (setq kcl 2))
((= cl "giua") (setq kcl 1))
)
(cond ((= g "") (setq g 0) ))
(cond ((= cl "") (setq kcl 0) ))
(setq g (duy:s_do>radian g))
(cond ((= k "") (setq k (getvar "TEXTSTYLE")) ))
(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(entmake (list (cons 0 "TEXT")(cons 10 d)(cons 11 d)(cons 40 c)(cons 50 g)(cons 72 kcl)(cons 1 nd)(cons 7 k)(cons 8 la)
 
(cons 62 co)))
(princ)
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao moi line
;;;Cu phap su dung (duy:t_line diemdau diemcuoi layer color ltype ltypescale)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_line (a b la co lt slt / a b la co lt slt)
(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(cond ((= lt "") (setq lt "bylayer") ))
(cond ((= slt "") (setq slt 1) ))
(entmake (list (cons 0 "LINE")(cons 10 a)(cons 11 <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />(cons 8 la)(cons 62 co)(cons 6 lt)(cons 48 slt) ))
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun vepolyline (/ i)
(setq i 0)
(command "pline")
(while (setq p (getpoint (strcat "\n Chon dinh thu " (rtos (setq i (1+ i)) 2 0) " <Enter de ket thuc>")))
	(command p)
)
(command "c")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(alert "\n Chon lan luot cac dinh cua thua dat can lap bang toa do")
(command "undo" "be")
(vepolyline)
(setq en (entlast) i 0
          enlst (acet-geom-vertex-list en)
          n (length enlst) )
 
(setq dvbd (getpoint "\nChon diem dat bang: "))
(duy:t_line dvbd (list (+ (car dvbd) 30) (cadr dvbd)) "" "" "" "")
(duy:t_line (list (car dvbd) (- (cadr dvbd) 5)) (list (+ (car dvbd) 30) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 0) (- (cadr dvbd) 0)) (list (+ (car dvbd) 0) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 5) (- (cadr dvbd) 0)) (list (+ (car dvbd) 5) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 23) (- (cadr dvbd) 0)) (list (+ (car dvbd) 23) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 26.5) (- (cadr dvbd) 0)) (list (+ (car dvbd) 26.5) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 30) (- (cadr dvbd) 0)) (list (+ (car dvbd) 30) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 5) (- (cadr dvbd) 2.5)) (list (+ (car dvbd) 23) (- (cadr dvbd) 2.5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 14) (- (cadr dvbd) 2.5)) (list (+ (car dvbd) 14) (- (cadr dvbd) 5)) "" "" "" "")
 
(duy:t_text (list (+ (car dvbd) 2.5) (- (cadr dvbd) 3)) 1 0 "giua" "§Ønh" "" "" "")
(duy:t_text (list (+ (car dvbd) 14) (- (cadr dvbd) 1.75)) 1 0 "giua" "Täa §é" "" "" "");;;"Täa §é"
(duy:t_text (list (+ (car dvbd) 9.5) (- (cadr dvbd) 4.25)) 1 0 "giua" "X (m)" "" "" "")
(duy:t_text (list (+ (car dvbd) 18.5) (- (cadr dvbd) 4.25)) 1 0 "giua" "Y (m)" "" "" "")
(duy:t_text (list (+ (car dvbd) 24.75) (- (cadr dvbd) 1.75)) 1 0 "giua" "Tªn" "" "" "")
(duy:t_text (list (+ (car dvbd) 28.25) (- (cadr dvbd) 1.75)) 1 0 "giua" "C¹nh" "" "" "")
(duy:t_text (list (+ (car dvbd) 24.75) (- (cadr dvbd) 4.25)) 1 0 "giua" "C¹nh" "" "" "")
(duy:t_text (list (+ (car dvbd) 28.25) (- (cadr dvbd) 4.25)) 1 0 "giua" "(m)" "" "" "")
 
(setq dvbd (list (car dvbd) (- (cadr dvbd) 5)))
(setq db1 dvbd)
 
(while (< i (1- n))
	(setq dtn (nth i enlst))
	(duy:t_text (list (+ (car dvbd) 2.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (setq i (1+ i)) 2 0) "" "" "")
	(duy:t_text dtn 1 0 "giua" (rtos  i  2 0) "" "" "")    
	(duy:t_text (list (+ (car dvbd) 9.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (cadr dtn) 2 3) "" "" "")
	(duy:t_text (list (+ (car dvbd) 18.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (car dtn) 2 3) "" "" "")              
	(duy:t_line (list (car dvbd) (- (cadr dvbd) 2)) (list (+ (car dvbd) 23) (- (cadr dvbd) 2)) "" "" "" "")
	(duy:t_line (list (+ (car dvbd) 23) (- (cadr dvbd) 3)) (list (+ (car dvbd) 30) (- (cadr dvbd) 3)) "" "" "" "")
	(setq e1 (entlast))
	(if (> i 1)
 		(progn
                  (duy:t_text (list (+ (car dvbd) 24.8) (- (cadr dvbd) 0.5)) 1 0 "giua"
                                    (strcat (rtos (1- i) 2 0) "-" (rtos i 2 0)) "" "" "")
                  (duy:t_text (list (+ (car dvbd) 28.3) (- (cadr dvbd) 0.5)) 1 0 "giua" (rtos (distance dtn dth) 2 2) "" "" "")
 		)
	)
	(setq dth dtn)
    
	(setq dvbd (list (car dvbd) (- (cadr dvbd) 2)))
)
(command "erase" e1 en "")
(duy:t_text (list (+ (car dvbd) 2.5) (- (cadr dvbd) 1.5)) 1 0 "giua" "1"  "" "" "")
(duy:t_text (list (+ (car dvbd) 9.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (cadr (nth 0 enlst)) 2 3) "" "" "")
(duy:t_text (list (+ (car dvbd) 18.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (car (nth 0 enlst)) 2 3) "" "" "")              
(duy:t_line (list (car dvbd) (- (cadr dvbd) 2)) (list (+ (car dvbd) 30) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_text (list (+ (car dvbd) 24.8) (- (cadr dvbd) 0.5)) 1 0 "giua" (strcat (rtos i 2 0) "-1" ) "" "" "")
(duy:t_text (list (+ (car dvbd) 28.3) (- (cadr dvbd) 0.5)) 1 0 "giua" (rtos (distance (nth 0 enlst) dth) 2 2) "" "" "")
(duy:t_line db1 (list (car db1) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_line (list (+ (car db1) 5) (cadr db1) ) (list (+ (car dvbd) 5) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_line (list (+ (car db1) 14) (cadr db1) ) (list (+ (car dvbd) 14) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_line (list (+ (car db1) 23) (cadr db1) ) (list (+ (car dvbd) 23) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_line (list (+ (car db1) 26.5) (cadr db1) ) (list (+ (car dvbd) 26.5) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_line (list (+ (car db1) 30) (cadr db1) ) (list (+ (car dvbd) 30) (- (cadr dvbd) 2)) "" "" "" "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)

1. Nhờ anh xem lại lisp dùm em làm nó ra thế này: Chon diem dat bang: ; error: no function definition: DUY:T_LINE

2. Chế độ truy bắt điểm không thực hiện đuợc.

3. Nếu được anh bổ sung thêm phần chọn chiều cao chữ và chế độ số thập phân sau dấu phẩy

4. Phần xuất bảng toạ độ anh thêm dùm 2 lựa chọn ;(cad /Excel)

     Câu lệnh như sau khi chèn trên cad xong enter (cad /Excel), xuất trên Excel chỉ cần lây giá trị text .

     thế là xong!


<<

Filename: 386457_lbtd.lsp
Tác giả: 3d.decor
Bài viết gốc: 152171
Tên lệnh: tkh
Lisp thống kê diện tích Hatch theo Layer

Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình...

>>

Bạn dùng tạm. Lưu ý trong bản vẽ của bạn có Hatch Cỏ khủng, đôi khi lisp lỗi, mình chưa rõ nguyên nhân. Các bản vẽ khác bình thường

(defun c:tkh (/ lst msp pt ss lay ar txtsiz)
 (vl-load-com)  
 (if (setq ss (ssget(list (cons 0 "HATCH"))))
   (progn
     (foreach e (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
       (setq lay (vla-get-layer e) ar (vla-get-area e))
       (if (not (assoc lay lst))
         (setq lst (cons (cons lay ar) lst))
         (setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
                          (assoc lay lst) lst)))      )
     (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
		tl 0.000001
           pt (getpoint "\nDiem dat Bang :" )
           txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
           msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
     (foreach e lst
       (vla-addtext msp (car e) (vlax-3d-point pt) txtsiz )
       (vla-addtext msp 
	(strcat (rtos (* (cdr e) tl) 2 2) " m2") (vlax-3d-point (polar pt 0 (* 10 txtsiz))) txtsiz )
       (setq pt (polar pt (/ pi -2) (* 1.5 txtsiz)))  )      )
   (alert "Khong chon duoc Hatch.")    )
 (princ))

Lisp độ lại từ Thống kê text của a gia_bach và chỉ phù hợp với các phiên bản CAD cho tính Hatch area.

lỗi rồi pro ơi

Diem dat Bang :; error: Automation Error. Invalid input


<<

Filename: 152171_tkh.lsp
Tác giả: hardwell
Bài viết gốc: 264904
Tên lệnh: sht
Nhờ viết lisp xuất tọa độ x,y,giá trị cao độ text (theo ví dụ đính kèm)

(Defun c:sht ( / picset Idx Entt PLis)

(If (Setq picset (Ssget (List (Cons 0 "*TEXT"))))

(Progn

(Setq Idx...

>>

(Defun c:sht ( / picset Idx Entt PLis)

(If (Setq picset (Ssget (List (Cons 0 "*TEXT"))))

(Progn

(Setq Idx 0)

(Repeat (SSlength picset)

(Setq Entt (Entget (SSname picset Idx)))

(If (And (Or (Equal (Cdr (Assoc 0 Entt)) "TEXT") ;;Doi tuong la TEXT

(Equal (Cdr (Assoc 0 Entt)) "MTEXT") ;;Hoac doi tuong la MTEXT

)

(Numberp (Read (Cdr (Assoc 1 Entt)))) ;;La TEXT dang chu so

)

(Progn

(Setq Pnt (List (Cadr (Assoc 10 Entt)) (Caddr (Assoc 10 Entt)) (AtoF (Cdr (Assoc 1 Entt)))))

(Setq Entt (Subst (Cons 10 Pnt) (Assoc 10 Entt) Entt))

(Entmod Entt)

)

)

(Setq Idx (+ Idx 1))

)

)

)

(Princ)

)

Bạn dùng lisp sau.Nó sẽ tự gán giá trị Z bằng giá trị text cho bạn

 

Thanks bạn rất nhiều ! Mình đã dùng được rồi.

 

Ưu điểm lớn nhất của lisp bạn viết là sử dụng được ngay không cần phải mò mẫm phần mềm như việc sử dụng DPSurvey, ai cũng sử dụng được ngay.

 

Nhưng chỉ có một bất tiện hơi nhỏ so với việc sử dụng cái DPSurvey là nếu chỉ dùng bản vẽ có vài chục text thì thao tác rất nhanh, nhưng nếu mình chọn khoảng vài ngàn đến hơn chục ngàn text trên bản vẽ lớn thì mình phải bấm enter vài ngàn lần (hoặc giữ nguyên nút enter để màn hình command nó chạy hết các text, mất khoảng hơn chục phút).

 

Tùy vào độ lớn của bản vẽ mình sẽ sử dụng cả 2 cách trên.

 

Thực sự mình cảm ơn 2 bạn DanKhaosat và cd2k44 rất nhiều.


<<

Filename: 264904_sht.lsp
Tác giả: jangboko
Bài viết gốc: 409966
Tên lệnh: test
Nhờ Viết Lisp Chọn Text

 

 Thay mapcar thành command nhé ^_^

(defun c:test (/ txt)
  (if (not (setq txt (car (entsel "\nChon text mau: "))))
   ...
>>

 

 Thay mapcar thành command nhé ^_^

(defun c:test (/ txt)
  (if (not (setq txt (car (entsel "\nChon text mau: "))))
    (princ "\nBan da khong chon text mau!")
    (progn
      (if (not (setq ss	(ssget (list (cons 0 "TEXT")
				     (assoc 40 (entget txt))
				     (assoc 7 (entget txt))
			       )
			)
	       )
	  )
	(princ "\Ban da khong chon text.")
	(command "_Pselect" ss "")
      )
    )
  )
  (princ)
)

Cảm ơn bạn. Rất nhanh và rất ngon lành


<<

Filename: 409966_test.lsp

Trang 234/330

234