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

vietanh2108

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

  • Số lượng nội dung

    24

  • Đã tham gia

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

  • Ngày trúng

    2

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

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

    Chào các bác, em tìm lisp này nhưng muốn nhờ mọi người sửa 1 chút. Lisp có chức năng tìm kiếm Att với nội dung cụ thể trong bản vẽ.

    1/ Sau khi tìm được các đội tượng -> Thêm chức năng Add các đối tượng đã tìm đc vào Selection set hiện hành nếu bấm ESC để thoát lệnh.

    2/ Nếu mở rộng chức năng tìm được cả TEXT, MTEXT thì tốt quá.

    Em xin cám ơn trước! 

    (defun c:find-att (/ ov ss i en ed an ad ah)
  (while (not ov)
         (setq ov (getstring t "\nATTRIB Value To Search For:   ")))

  (and (setq ss (ssget "X" (list (cons 0 "INSERT")
                                 (cons 66 1)
                                 (if (getvar "CTAB")
                                     (cons 410 (getvar "CTAB"))
                                     (cons 67 (- 1 (getvar "TILEMODE")))))))
       (setq i (sslength ss))
       (while (not (minusp (setq i (1- i))))
              (setq en (ssname ss i)
                    ed (entget en)
                    an (entnext en))
              (while (/= "SEQEND" (cdr (assoc 0 (entget an))))
                     (setq ad (entget an)
                           ah (cdr (assoc 40 ad))
                           an (entnext an))
                     (if (= (strcase ov)
                            (strcase (cdr (assoc 1 ad))))
                         (progn
                            (command "_.ZOOM" "_C" (cdr (assoc 10 ed)) (* ah 66))
                            ;(redraw en 3)
                            (getstring "\nPress Enter To Continue Searching..."))))))
  ;(redraw)
  (prin1))

     

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

    Mình thấy chức năng Overkill của autocad rất hay, tuy nhiên mỗi lần sử dụng là nó tự động xóa và merge các đối tượng tự động không qua quyết định của người dùng. Mình muốn tìm cách xét overkill như vậy nhưng không xóa mà đưa các đối tượng trùng vào selection set của autocad, mong các pro giúp đỡ! :)

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

    Bạn tham khảo thử! :)

     

    Function UnformatMtext(S As String) As String

Dim P1 As Integer
Dim P2 As Integer, P3 As Integer
Dim intStart As Integer
Dim strCom As String
Dim strReplace As String

Debug.Print S

Select Case Left(S, 4)
Case "\A0;", "\A1;", "\A2;"
S = Mid(S, P1 + 5)
End Select
intStart = 1
Do
P1 = InStr(S, "%%")
If P1 = 0 Then
Exit Do
Else
Select Case Mid(S, P1 + 2, 1)
Case "P"
S = Replace(S, "%%P", "+or-")
Case "D"
S = Replace(S, "%%D", " deg")
End Select
End If
Loop

Do
P1 = InStr(intStart, S, "\", vbTextCompare)
If P1 = 0 Then Exit Do
strCom = Mid(S, P1, 2)
Select Case strCom
Case "\p"
P2 = InStr(1, S, ";")
S = Mid(S, P2 + 1)
Case "\A", "\C", "\f", "\F", "\H", "\Q", "\T", "\W"
P2 = InStr(P1 + 2, S, ";", vbTextCompare)
P3 = InStr(P1 + 2, S, strCom, vbTextCompare)
If P3 = 0 Then
S = Left(S, P1 - 1) & Mid(S, P2 + 1)
End If
Do While P3 > 0
P2 = InStr(P3, S, ";", vbTextCompare)
S = Left(S, P3 - 1) & Mid(S, P2 + 1)
'Debug.Print s, strCom
P3 = InStr(1, S, strCom, vbTextCompare)
Loop
's = Left(s, P3 - 1) & mid(s, P3 + 1)
Case "\L", "\O"
Dim strLittle As String
strLittle = LCase(strCom)
P2 = InStr(P1 + 2, S, strLittle, vbTextCompare)
S = Left(S, P1 - 1) & Mid(S, P1 + 2, P2 - (P1 + 2)) & Mid(S, P2 + 2)
Case "\S"
P2 = InStr(P1 + 2, S, ";", vbTextCompare)
P3 = InStr(P1 + 2, S, "/", vbTextCompare)
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, S, "#", vbTextCompare)
End If
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, S, "^", vbTextCompare)
End If
S = Left(S, P1 - 1) & Mid(S, P1 + 2, P3 - (P1 + 2)) _
& "/" & Mid(S, P3 + 1, (P2) - (P3 + 1)) & Mid(S, P2 + 1)

Case "\U"
strLittle = Mid(S, P1 + 3, 4)
Debug.Print strLittle
Select Case strLittle
Case "2248"
strReplace = "ALMOST EQUAL"
Case "2220"
strReplace = "ANGLE"
Case "2104"
strReplace = "CENTER LINE"
Case "0394"
strReplace = "DELTA"
Case "0278"
strReplace = "ELECTRIC PHASE"
Case "E101"
strReplace = "FLOW LINE"
Case "2261"
strReplace = "IDENTITY"
Case "E200"
strReplace = "INITIAL LENGTH"
Case "E102"
strReplace = "MONUMENT LINE"
Case "2260"
strReplace = "NOT EQUAL"
Case "2126"
strReplace = "OHM"
Case "03A9"
strReplace = "OMEGA"
Case "214A"
strReplace = "PROPERTY LINE"
Case "2082"
strReplace = "SUBSCRIPT2"
Case "00B2"
strReplace = "SQUARED"
Case "00B3"
strReplace = "CUBED"

End Select
S = Replace(S, "\U+" & strLittle, strReplace)

Case "\~"
S = Replace(S, "\~", " ")

Case "\\"
intStart = P1 + 2
S = Replace(S, "\\", "\")
GoTo Selectagain

Case "\P"
intStart = P1 + 1
GoTo Selectagain
Case Else
Exit Do
End Select
Selectagain:
Loop

Do
P1 = InStr(1, S, "\P", vbTextCompare)
If P1 = 0 Then
Exit Do
Else
S = Left(S, P1 - 1) & vbCrLf & Mid(S, P1 + 2)
End If
Loop
For intStart = 0 To 1
If intStart = 0 Then
strCom = "}"
Else
strCom = "{"
End If
P2 = InStr(1, S, strCom)

Do While P2 > 0
S = Left(S, P2 - 1) & Mid(S, P2 + 1)
P2 = InStr(1, S, strCom)
Loop
Next intStart


UnformatMtext = S

End Function

Sub Testmt()
Dim Mt As AcadMText, V As Variant
ThisDrawing.Utility.GetEntity Mt, V, "Pick an Mtext:"
Debug.Print Mt.TextString
Mt.TextString = UnformatMtext(Mt.TextString)
Debug.Print Mt.TextString
End Sub
    • Vote tăng 1

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

    Đối với hình đơn giản thì có thể dùng BO hay hatch, tuy nhiên lại phải tốn qua nhiều bước trung gian, hơn nữa máy chạy rất nặng, tốn tài nguyên ko cần thiết để xác định vùng kín... ở đây e chỉ cần break cái polyline ngay tại giao điểm và sau đó nối nó lại bằng cái đường cắt thôi.

     

    Có những công việc lập đi lập lại nhiều lần, nếu có thể sử dụng lisp sẽ tiết kiệm thời gian và tăng năng suất mà! Không phải lisp được tạo ra cho mục đích này sao !? :)

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

    Chào mọi người, em có  đoạn lisp phía dưới đưa số lượng đối tượng đã chọn vào clipboard để việc còn lại chỉ là Ctrl+V để lấy số liệu. H e muốn nhờ mn sửa dùng để có thể lấy tên layer của đối tượng đầu tiên trong nhóm đối tượng đã chọn đưa vào clipboard tương tự thế này.

    Cho e cám ơn trước! :)

    (defun C:f1 ( / SS )
  (and
    (setq SS (vl-some 'ssget (list "_I" nil)))
    (_SetClipBoardText (itoa (sslength SS)))
  )
  (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun _SetClipBoardText ( text / htmlfile result )

    ;;  Caller's sole responsibility is to pass a
    ;;  text string. Anything else? Pie in face.

    ;;  Attribution: Reformatted version of
    ;;  post by XShrimp at theswamp.org.
    ;;
    ;;  See http://tinyurl.com/2ngf4r.

    (setq result
        (vlax-invoke
            (vlax-get
                (vlax-get
                    (setq htmlfile (vlax-create-object "htmlfile"))
                   'ParentWindow
                )
               'ClipBoardData
            )
           'SetData
            "Text"
            text
        )
    )

    (vlax-release-object htmlfile)

    text

)

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

    Em tìm được lisp này trên mạng với chức năng highlight và zoom tới đối tượng có Handle ID tương ứng. Nhờ bác nào đi qua giúp em thêm chức năng làm việc vơi 1 và cả với nhiều ID với.

    Kiểu như em có list ID

    A;B;C;D...

    thì nó hightlight và zoom tất cả các đối tượng có ID trong chuỗi ngăn cách bởi ";"

    Em xin chân thành cám ơn. :D

    P/s: zhid để zoom tới, còn chid để tạo text ID của đối tượng.

    ;Zoom to handle ID
    (defun c:zhid ( / YourHandle ll ur )
      (vl-load-com)
      (setq YourHandle (getstring "\nEnter Handle: "))
      (if (handent YourHandle)
        (progn
          (vla-getboundingbox (vlax-ename->vla-object (handent YourHandle)) 'll 'ur)
          (vla-zoomwindow (vlax-get-acad-object) ll ur)
          (sssetfirst nil (ssadd (handent YourHandle)))
        )
        (princ "\nHandle not in drawing")
      )
      (princ)
    )
;Tao Handle ID
(defun c:chid (/ ss n ed sz)
  (setq sz (getvar 'TextSize))
  (prompt "Select objects: ")
  (if (and (setq ss (ssget)) (setq n (sslength ss)))
    (while (>= (setq n (1- n)) 0)
      (setq ed (entget (ssname ss n)))
      (entmake (list '(0 . "TEXT")
                     (assoc 10 ed)
                     (cons 1 (cdr (assoc 5 ed)))
                     (cons 40 sz)
               )
      )
    )
  )
  (princ)
)
    • Vote tăng 1

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

    Em tìm được lisp này trên mạng của thánh Lêmác cơ mà bị cái kẹt nó đang chọn tất cả các block trên Model. Em muốn nhờ các bác sửa tí xíu thôi, mong ai đi ngang qua giúp cho.

    - Lọc các Block ở vùng chọn selectonscreen thay vì toàn model

    Em xin cám ơn các bác đã quan tâm chủ đề trên! :D

     

    ;; Select Blocks by Attribute Value - Lee Mac

;; Selects all attributed blocks in the current layout which contain a specified attribute value.

(defun c:selblkbyattval ( / att atx ent idx sel str )

(if (/= "" (setq str (strcase (getstring t "\nSpecify attribute value: "))))

(if (and

(setq sel

(ssget "_X"

(list '(0 . "INSERT") '(66 . 1)

(if (= 1 (getvar 'cvport))

(cons 410 (getvar 'ctab))

'(410 . "Model")

)

)

)

)

(progn

(repeat (setq idx (sslength sel))

(setq ent (ssname sel (setq idx (1- idx)))

att (entnext ent)

atx (entget att)

)

(while

(and (= "ATTRIB" (cdr (assoc 0 atx)))

(not (wcmatch (strcase (cdr (assoc 1 atx))) str))

)

(setq att (entnext att)

atx (entget att)

)

)

(if (= "SEQEND" (cdr (assoc 0 atx)))

(ssdel ent sel)

)

)

(< 0 (sslength sel))

)

)

(sssetfirst nil sel)

(princ (strcat "\nNo blocks found with attribute value matching \"" str "\"."))

)

)

(princ)

)
    • Vote tăng 1
    • Vote giảm 1

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

    hjx, em đi khắp nơi lục lọi mà toàn thấy từ Excel qua CAD là nhiều... cho em lại đề một chút! có cách nào thay thế được Data Extraction bằng VBA ko, ý là có 1 file Excel vs 1 button, bấm 1 phát là nhảy qua CAD cho phép chọn quét các attrblock cần thiết về ra được các cột

    - Số lượng

    - Layer name

    - Tên block

    - Attr 1

    - Attr 2

    ....

    - Attr n

    Bác nào giúp em với, em xin cảm ơn trước!!!!

     

    cám ơn bác! ý em là sửa lại giúp em theo ý tưởng ở trên á!!! ^^

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

    hjx, em đi khắp nơi lục lọi mà toàn thấy từ Excel qua CAD là nhiều... cho em lại đề một chút! có cách nào thay thế được Data Extraction bằng VBA ko, ý là có 1 file Excel vs 1 button, bấm 1 phát là nhảy qua CAD cho phép chọn quét các attrblock cần thiết về ra được cột

    - Số lượng

    - Layer name

    - Tên block

    - Attr 1

    - Attr 2

    ....

    - Attr n

    Bác nào giúp em với, em xin cảm ơn trước!!!!

     

    BTW, e có kiếm đc 1 file VBA trên mạng với macro Extract tất cả các block trong bản vẽ, bác nào đi qua sửa lại giúp em với

     

    http://www.cadviet.com/upfiles/7/158710_jwaextattr.zip

    • Vote tăng 1

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

    hjx, em đi khắp nơi lục lọi mà toàn thấy từ Excel qua CAD là nhiều... cho em lại đề một chút! có cách nào thay thế được Data Extraction bằng VBA ko, ý là có 1 file Excel vs 1 button, bấm 1 phát là nhảy qua CAD cho phép chọn quét các attrblock cần thiết về ra được các cột

    - Số lượng

    - Layer name

    - Tên block

    - Attr 1

    - Attr 2

    ....

    - Attr n

    Bác nào giúp em với, em xin cảm ơn trước!!!!

    • Vote tăng 1

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

    Data extraction và -dataextraction thì hay quá nhưng bị cái phiền phức và nhiều bước lựa chọn khi hiện dialog.

    - Mn có thì cho em xin lisp nào chọn các block cần r bấm 1 phát là nhảy ra bảng Excel BookN.xls xuất hết tất cả các attribute, layer name và combine lại nếu giống nhau như data extraction thì em xin đội ơn ạ!!! :D

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

    Cám ơn các bác đã góp ý cho em học hỏi đc thêm nhiều điều, em có một mong muốn cải tiến nho nhỏ cái líp trên nữa.. giúp em viết thêm 2 dòng này với

    - Lấy màu của Text đối tượng để đưa vào màu cho block vừa insert vào.

    - Nếu ko có block "CODE_COL" trong bản vẽ thì báo về "Chua khoi tao block CODE_COL".

    Em xin cám ơn!!!!

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

    Bạn sử dụng lệnh FIND của CAD cũng được, tuy nhiên nhược điểm là gọi lệnh này sẽ hiện Dialog và mất thời gian load. Góp vui cho bạn một LISP tìm và thay thế tự động!

    ;superstr.lsp l. gabriel 11-11-1996  22:04:42
;
;object: string search and replace. Works for both text and attributes. Program
;        will globally search and replace every text/attribute within the selection set.
;
;Rev 1.0 Added Dimension string search and replace l. gabriel 06.12.08
;
(defun atext (num)
   (cdr (assoc num d))
)
;
(defun echooff ()
  (setq oldecho (getvar "CMDECHO"))
  (setq oldblip (getvar "BLIPMODE"))
  (setq oldosm (getvar "OSMODE"))
  (setvar "CMDECHO" 0)
  (setvar "BLIPMODE" 0)
  (setvar "OSMODE" 0)
  (setq olderror_echo *ERROR*)
  (terpri)
  (defun *ERROR* (msg)
    (princ " \n")
    (princ msg)
    (echoon)
  )
)
;
(defun echoon ()
  (setvar "CMDECHO" oldecho)
  (setvar "BLIPMODE" oldblip)
  (setvar "OSMODE" oldosm)
  (setq *ERROR* olderror_echo)
  (princ)
)
;super search and replace routine
(defun c:FEQ()
    (echooff)
    (setq olsosmode (getvar "OSMODE"))
    (setvar "OSMODE" 0)
    (setq p (ssget))   
    (if p 
	(progn 
            (setq osl (strlen (setq os (getstring "\nOld string: " t))))
            (setq nsl (strlen (setq ns (getstring "\nNew string: " t))))
	    (setq l 0 chm 0 n (sslength p))
	    (setq adj 
		(cond 
		    ((/= osl nsl) (- nsl osl))
		    (T nsl)
		)
	    )
	(while (< l n)                   
	    (setq d (entget (setq e (ssname p l))))
	    (if (and (= (atext 0) "INSERT")(= (atext 66) 1))
		(progn
		    (setq e (entnext e))
		    (while e
			(setq d (entget e))
			(cond 
			    ((= (atext 0) "ATTRIB")
				(setq chf nil si 1)
				(setq s (cdr (setq as (assoc 1 d))))
				(while (= osl (setq sl (strlen
				    (setq st (substr s si osl)))))
				    (cond
					((= st os)
					    (setq s (strcat (substr s 1 (1- si)) ns
					    (substr s (+ si osl))))
					    (setq chf t)
					    (setq si (+ si adj))
					)
				    )
				(setq si (1+ si))
			    )
			    (if chf 
				(progn        
				    (setq d (subst (cons 1 s) as d))
				    (entmod d)	       
				    (entupd e)	       
				    (setq chm (1+ chm))
				)
			    )
			    (setq e (entnext e))
			    )
			    ((= (atext 0) "SEQEND")
				(setq e nil)) 
			    (T (setq e (entnext e)))
                        )
		    )
		)
	    )
            (if (= "MTEXT"            ; Look for MTEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
	    (if (= "DIMENSION"            ; Look for DIMENSION entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
	    (if (= "TEXT"            ; Look for TEXT entity type (group 0)
               (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (progn
                     (setq chf nil si 1)
                     (setq s (cdr (setq as (assoc 1 e))))
                     (while (= osl (setq sl (strlen
                        (setq st (substr s si osl)))))
                        (if (= st os)
                           (progn
                              (setq s (strcat (substr s 1 (1- si)) ns
                                        (substr s (+ si osl))))
                           (setq chf t) ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 s) as e))
                  (entmod e)         ; Modify the TEXT entity
                  (setq chm (1+ chm))
               ))
            )
         )
         (setq l (1+ l))
	)
	)
    )
    (if (> chm 1)
       (princ (strcat "\nUpdated " (itoa chm) " text strings"))
       (princ (strcat "\nUpdated " (itoa chm) " text string"))
    )
    (setvar "OSMODE" oldosmode)
    (terpri)
    (echoon)
)
    • Vote tăng 1

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

    Thưa các bác, kiểu là em có sẵn 1 block CODE_COL vs 4 attribute

    -Tên_cột

    -Cao_đáy

    -Cao_đỉnh

    -Trừ_cao

    và mặt bằng có text tên cột C1, C2... Cn. Em muốn chọn tất cả các text tên cọc và chạy LISP để biến tất cả các text tên cột đó thành block CODE_COL vs tên cột được đưa vào attribute Tên_cột... bác nào đi qua giúp dùm em với, em xin cám ơn trc!

×