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

pdhuyxn2

Thành viên
  • Số lượng nội dung

    61
  • Đã tham gia

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

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


  1. Vào lúc 22/10/2016 tại 23:57, Bee đã nói:

    Filter xem ở đây. Có thể search thêm.

     

    Ở phần select filter chọn mtext. Xong apply quơ hết các bảng vào thôi

     

     

     

    Nếu mình hiểu đúng ý thì đây là link lisp paste data từ excel sang cad.

    Mình không có nhiều thời gian viết kỹ nên dùng tạm cái này nhé.

     

    https://drive.google.com/file/d/0B-3fZ45DSr_XMzl0NGl1TjRFVTA/view?usp=sharing

     

    Untitledf94db.png
     
     xem video thao tác 
     
     
    1.Select cell và copy.

    2.Bên cad sau khi load lisp. Gõ lệnh PAS

    3.Select hàng text (xem ảnh)

    4.Xem thôi ^_^

    Bác có thế Chỉnh Sửa LISP Copy từ EXCEL hàng Dọc PAS sang CAD hàng ngang được không A?

    Nhờ Các Bác trên Diễn Đàn Giúp đỡ. Cám ơn các Bác nhiều ạ...


  2. Nhờ các Bác trên diễn đàn giúp đỡ chỉnh sửa lisp này thành lisp  dóng kích thước hàng loạt các block.

      

    ;; AUTO DIMALINGED LINES AND POLYLINES
    ;;;-------------------------------------------------------------
    (defun TBCong (x1 x2) (/ (+ x1 x2) 2)) ;;;Trung binh cong
    ;;;-------------------------------------------------------------
    (defun MidP (p1 p2) ;;;Midpoint
    (list (TBCong (car p1) (car p2)) (TBCong (cadr p1) (cadr p2)) (TBCong (caddr p1) (caddr p2)))
    )
    ;;;-------------------------------------------------------------
    (defun getVert (e / i L) ;;;Return list of all vertex from pline e
    (setq i 0 L nil)
    (vl-load-com)
    (repeat (fix (+ (vlax-curve-getEndParam e) 1))
        (setq L (append L (list (vlax-curve-getPointAtParam e i))))
        (setq i (1+ i))
    )
    L
    )
    ;;;-------------------------------------------------------------
    (defun etype (e) (cdr (assoc 0 (entget e)))) ;;;Entity type
    ;;;-------------------------------------------------------------
    (defun dim2p (p1 p2 s) ;;;Dimaligned 2 Point
    (command "dimaligned" p1 p2 (polar (MidP p1 p2) (+ (angle p1 p2) (/ pi 2)) s))
    )
    ;;;-------------------------------------------------------------
    (defun dimLine(e s) ;;;Dimaligned Line
    (dim2p (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget e))) s)
    )
    ;;;-------------------------------------------------------------
    (defun dimPline(e s) ;;;Dimaligned PLine
    (setq Lp (getvert e) i 0)
    (repeat (1- (length Lp))
        (dim2p (nth i Lp) (nth (1+ i) Lp) s)
        (setq i (1+ i))
    )
    )

    ;;;-------------------------------------------------------------
    (defun C:ATD( / ss s oldos e) ;;;AutoDimaligned Line & Pline
    (if (not s0) (setq s0 0))
    (setq
        ss (ssget '((0 . "LINE,LWPOLYLINE")))
        s (getdist (strcat "\nKhoang cach tu doi tuong den duong kich thuoc <" (rtos s0) ">:"))
        oldos (getvar "osmode")
    )
    (if (not s) (setq s s0) (setq s0 s))
    (setvar "osmode" 0)
    (while (setq e (ssname ss 0))
        (if (= (etype e) "LINE") (dimLine e s) (dimPline e s))
        (ssdel e ss)
    )
    (setvar "osmode" oldos)
    (princ)
    )
     

     

    ATD.LSP

    Giong kich thuoc cac Block.dwg


  3. Nhờ Bác Chỉnh giúp:

     

     

     

    (defun C:nt ( / ELST ENT PT STR1 STR2)
      (defun get_str (default promp / str)
      (if (= (setq str (getstring t (strcat "\n" promp " <" default "> "))) "")
        default
        str
        )
      )
      (setq str1 "-") 
      (setq elst (acet-ss-to-list (ssget (list (cons 0 "*TEXT")))))
      (setq str2 (apply 'strcat (mapcar '(lambda (ent) (strcat (cdr (assoc 1 (entget ent))) str1)) elst)))
      (setq str2 (substr str2 1 (1- (strlen str2))))
      (setq pt (getpoint "\nChon diem chen Text: "))
      (vla-Copy (vlax-ename->vla-object (car elst)))
      (setq ent (entlast))
      (vla-Move (vlax-ename->vla-object ent) (vlax-3d-point (cdr (assoc 10 (entget ent)))) (vlax-3d-point pt))
      (entmod (subst (cons 1 str2) (assoc 1 (entget ent)) (entget ent)))
      (print)
      )

    Can giup do.dwg


  4. Vào lúc 29/7/2010 tại 10:02, gia_bach đã nói:

    Cật nhật theo yêu cầu : Nối text theo thứ tự các text được chọn.

     

    
    (defun c:at2t (/ center color data edata ent i sel ss str);All Text to Text
     (defun centerSS (ss / lst_max lst_min maxpt minpt ll ur)
       (vl-load-com)
       (foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
         (vla-GetBoundingBox ent 'minpt 'maxpt)
         (setq lst_min (cons (vlax-safearray->list minpt) lst_min)
        lst_max (cons (vlax-safearray->list maxpt) lst_max)  )   )
       (setq ll (list (car (vl-sort (mapcar 'car lst_min) '<))
    	   (car (vl-sort (mapcar 'cadr lst_min) '<))  )
      ur (list (last (vl-sort (mapcar 'car lst_max) '<))
    	   (last (vl-sort (mapcar 'cadr lst_max) '<)) ) )
       (mapcar '/ (mapcar '+ ll ur) '(2.0 2.0 2.0))    )  
    
     (defun Change_Str (data pt str color)
       (entmake (list (cons 0 "TEXT") (assoc 8 data) (cons 10 pt)
    	   (cons 11 pt) (assoc 7 data) (assoc 40 data)
    	   (cons 71 0) (cons 72 1) (cons 73 2)
    	   (cons 1 str) (cons 62 color)
    	   (if (assoc 6 data)  (assoc 6 data)  '(6 . "BYLAYER") )
    	   (if (assoc 39 data) (assoc 39 data) '(39 . 0) )
    	   (if (assoc 370 data) (assoc 370 data) '(370 . -1) ) ))  )
    
     (defun dxf (tag obj) (cdr (assoc tag obj)))
    ;main
     (or *color* (setq *color* 6 ))
     (setq color (getint (strcat "\nNhap so mau cua Text sau khi hoan thanh <" (itoa *color*) "> :")) )
     (if color (setq *color* color) (setq color *color*))
     (setq ss (ssadd))
     (while (setq sel (entsel "\nChon cac Text can noi voi nhau: "))
       (setq ent (car sel))
       (if (= (cdr (assoc 0 (entget ent))) "TEXT")
         (ssadd ent ss)) )  
     (if (> (sslength ss) 0)
       (progn
         (setq i -1
        str ""
        center (centerSS ss)	    
        data (entget (ssname ss 0))	    )
         (while (setq ent (ssname ss (setq i (1+ i))))
    (setq edata (entget ent)
          str (strcat str " " (dxf 1 edata))  )
    (entdel ent)	)
         (Change_Str data center (substr str 2) color)     )
       (princ "\nKhong chon duoc Text !"))
     (princ))
     

     

    Nhờ các bác trên diễn đàn chỉnh sửa Lisp này Nối text theo thứ tự các text được chọn thành chuỗi têxt mới sang Vị trí chọn. Các text cũ vẫn giữ nguyên.

     


  5. kHÔNG BIẾT LỖI DO ĐÂU MÀ KHÔNG CHAY ĐƯỢC EXCEL2016

    Sub text2xls()

      'Dim sset As AcadSelectionSet

      Dim texts()

      Dim lines()

      Dim gpCode(0) As Integer   'filter code

      Dim dataValue(0) As Variant

      On Error Resume Next

      Set acadapp = GetObject(, "AutoCAD.Application")        'autocadÁöÁ¤

      If Err Then

        MsgBox "AutoCAD¸¦ ½ÇÇàÇØ ÁÖ¼¼¿ä"

        End

      End If

      Set acaddoc = acadapp.ActiveDocument    'ÇöÀç document ÁöÁ¤

      Set acadutil = acaddoc.Utility   'utilityÁöÁ¤

      acadapp.Visible = True

      AppActivate acadapp.Caption                    'ijµå¸¦ È°¼ºÈ­

      

      gpCode(0) = 0           'filter ÄÚµå : entity type

      dataValue(0) = "Text" ' filter value : "Text"

      If acaddoc.SelectionSets.Count <> 0 Then acaddoc.SelectionSets("sset1").Delete

      Set sset = acaddoc.SelectionSets.Add("sset1")

      On Error Resume Next

      sset.SelectOnScreen gpCode, dataValue

      If Err Or sset.Count = 0 Then

        AppActivate ActiveWorkbook.Application.Caption

        MsgBox "Text¸¦ ¼±ÅÃÇØÁÖ¼¼¿ä"

        End

      End If

      ReDim texts(sset.Count - 1)

     

      For I = 0 To sset.Count - 1

        Set texts(I) = sset.Item(I)

      Next I

     

      

      

      sort_entityxy texts, sp, nrows  'text¸¦ xy¹æÇâÀ¸·Î Á¤·ÄÇϱâ

      msg = vbCrLf & CStr(UBound(texts) + 1) & " texts found, " & CStr(nrows) & " Lines found" & vbCrLf & "Select virtical lines"

            

      

      If Left(acadapp.Version, 2) = "14" Then

          AppActivate ActiveWorkbook.Application.Caption

          MsgBox msg

        Else

          acadutil.Prompt msg

      End If

      

     

      If UBound(sp) > 0 Then  ' ¿©·¯ÁÙÀÏ ¶§

      

          If sp(0) > 1 Then  '¿©·¯Ä÷³ÀÏ ¶§. ÇÑÄ÷³ÀÏ ¶§´Â ¾Æ¹«°Íµµ ÇÏÁö ¾ÊÀ½

            

            gpCode(0) = 0           'filter ÄÚµå : entity type

            dataValue(0) = "Line" ' filter value : "Text"

            If acaddoc.SelectionSets.Count <> 0 Then acaddoc.SelectionSets("sset1").Delete

            Set sset = acaddoc.SelectionSets.Add("sset1")

            AppActivate acadapp.Caption

            On Error Resume Next

            sset.SelectOnScreen gpCode, dataValue

            If Err Or sset.Count = 0 Then

              AppActivate ActiveWorkbook.Application.Caption

              MsgBox "¼¿À» ±¸ºÐÇϱâ À§ÇÑ ¼öÁ÷¼±À» ¼±ÅÃÇØÁÖ¼¼¿ä"

              End

            End If

            ReDim lines(sset.Count - 1)

      

            For I = 0 To sset.Count - 1

              Set lines(I) = sset.Item(I)

            Next I

     

            get_sepx_lines lines, sepxa   'lineÀÇ ½ÃÀÛÁ¡À» ÀÌ¿ëÇÏ¿© Ä÷³±¸ºÐ¼± ±¸Çϱâ

            

          End If

          

        Else   'ÇÑÁÙÀ϶§

        

          get_sepx_txts texts, sp, sepxa  'ùÁÙ text¸¦ ÀÌ¿ëÇÏ¿© Ä÷³±¸ºÐ¼± ±¸Çϱâ

          

      End If

     

     

      put2sheet texts, sp, sepxa  'ÁÖ¾îÁø text¸¦ ÁÙ(sp), Ä­(sepxa) Á¤º¸¿¡ ¬Ãç¼­ sheet¿¡ ³Ö±â

     

    End Sub

    image.png


  6. Vào lúc 14/4/2019 tại 21:11, dinhvantrang đã nói:

    Bạn có thể post lỗi lên đây được không? Với lại fil Add-In này có pass, bạn có thể inbox mình pass để mình xem qua cho nhé

     Nhờ Các Bác trên diễn đàn chỉnh sửa giúp sử dụng cad2017 và excel 2016 trên win 64 với ạ.


  7. Vào lúc 12/3/2019 tại 09:55, pdhuyxn2 đã nói:

    Nhờ Các Cao thủ sửa lỗi giúp em với:

    Trước em sử dụng add-in trên cad2008 và excel 2003 trên win 7 32bít. Bây giờ sử dụng cad2017 và excel 2016 trên win 64 bị lỗi không sử dụng được. Kính nhờ Các Bác Giúp em với. Em cám ơn ạ!

    didg.rar

    Nhờ các bác chỉnh giúp!


  8. Vào lúc 12/3/2019 tại 09:55, pdhuyxn2 đã nói:

    Nhờ Các Cao thủ sửa lỗi giúp em với:

    Trước em sử dụng add-in trên cad2008 và excel 2003 trên win 7 32bít. Bây giờ sử dụng cad2017 và excel 2016 trên win 64 bị lỗi không sử dụng được. Kính nhờ Các Bác Giúp em với. Em cám ơn ạ!

    didg.rar

    Nhờ Các Cao thủ sửa lỗi giúp em với ạ!

×