AutoCAD text birleştirme lisp

Bu lisp ile dtext ile yazılmış bir kaç tane yazıya tıklayarak, mtext ile yazılmış şekilde ard arda sıralanır.

Autocad lisp kodlar

;;  Similar to the Txt2MTxt Express Tools function, but allows the user          ;;
;;  additional control over where the text is placed in the resultant MText.     ;;
;;  The user can pick MText or DText, positioning such text using one of two     ;;
;;  modes: "New Line" or "Same Line". The Modes can be switched by pressing      ;;
;;  Space between picks.                                                         ;;
;;  The user can also hold shift and pick text to keep the original text in      ;;
;;  place, and press "u" between picks to undo the last text pick.               ;;

(defun c:YAZI-BIRLESTIR ( /  ;; -={ Local Functions }=-

*error* align_Mt Get_MTOffset_pt
                   GetTextWidth ReplaceUnderline

;; -={ Local Variables }=-

CODE
                  DATA DOC
                  ELST ENT ET
                  FORMFLAG
                  GRDATA
                  LHGT LLST
                  MLST MSG
                  NOBJ NSTR
                  OBJ
                  SHFT SPC
                  TENT TOBJ TEXTSS
                  UFLAG UNDER
                  WLST
              
                  ;; -={ Global Variables }=-

; *T2M_mode*  ~  Mode for line addition
)

;     --=={ Sub Functions  }==--      ;

;; -={ Error Handler }=-

(defun *error* (err)
    (and uFlag (vla-EndUndoMark doc))
    (and tObj  (not (vlax-erased-p tObj)) (vla-delete tObj))
    
    (if eLst (mapcar (function entdel)
               (vl-remove-if (function null) eLst)))
    
    (or (wcmatch (strcase err) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " err " **")))
    (princ))

;;-------------------------------------------------------------------------------;;

(defun align_Mt (obj / al)
    (cond (  (eq "AcDbMText" (vla-get-ObjectName obj))
             (vla-get-AttachmentPoint obj))

(  (eq "AcDbText" (vla-get-ObjectName obj))
             (setq al (vla-get-Alignment obj))

(cond (  (<= 0 al 2) (1+ al))
                   (  (<= 3 al 5) 1)
                   (t (- al 5))))))

;;-------------------------------------------------------------------------------;;

(defun Get_MTOffset_pt ( obj pt / miP maP al )
    (vla-getBoundingBox obj 'miP 'maP)
    (setq miP (vlax-safearray->list miP)
          maP (vlax-safearray->list maP))

(setq al (vla-get-AttachmentPoint obj) r (vla-get-rotation obj))

(cond (  (or (eq acAttachmentPointTopLeft   al)
                 (eq acAttachmentPointTopCenter al)
                 (eq acAttachmentPointTopRight  al))
           
             (polar pt (- r (/ pi 2.)) (vla-get-Height obj)))

(  (or (eq acAttachmentPointMiddleLeft   al)
                 (eq acAttachmentPointMiddleCenter al)
                 (eq acAttachmentPointMiddleRight  al))
           
             (polar pt (- r (/ pi 2.)) (+ (vla-get-Height obj)
                                          (/ (- (cadr maP) (cadr miP)) 2.))))
  
          (  (or (eq acAttachmentPointBottomLeft   al)
                 (eq acAttachmentPointBottomCenter al)
                 (eq acAttachmentPointBottomRight  al))
           
             (polar pt (- r (/ pi 2.)) (+ (vla-get-Height obj)
                                          (- (cadr maP) (cadr miP)))))))

;;-------------------------------------------------------------------------------;;

(defun GetTextWidth (obj / tBox eLst)
    (cond (  (eq "AcDbText" (vla-get-objectname obj))

(setq eLst (entget  (vlax-vla-object->ename obj))
                   tBox (textbox
                          (subst
                            (cons 1 (strcat "..." (cdr (assoc 1 eLst))))
                              (assoc 1 eLst) eLst)))

(- (caadr tBox) (caar tBox)))

(  (vla-get-Width obj))))

;;-------------------------------------------------------------------------------;;

(defun ReplaceUnderline (str / i under)
    (if (vl-string-search "%%U" (strcase Str))
      (progn
        (while (and (< i (strlen Str))
                    (setq i (vl-string-search "%%U" (strcase Str) i)))
          (if under
            (setq Str (strcat (substr Str 1 i) "\\l" (substr Str (+ i 4))) i (+ i 4) under nil)
            (setq Str (strcat (substr Str 1 i) "\\L" (substr Str (+ i 4))) i (+ i 4) under t  )))
        
        (if under (setq str (strcat str "\\l")))))
    
    str)

;     --=={ Main Function  }==--

(setq doc (vla-get-ActiveDocument
              (vlax-get-acad-object))

spc (if (or (eq AcModelSpace (vla-get-activespace doc))
                    (eq :vlax-true   (vla-get-MSpace doc)))

(vla-get-modelspace doc)
              (vla-get-paperspace doc)))
  
  (setq Et
      (and (vl-position "acetutil.arx" (arx))
           (not
             (vl-catch-all-error-p
               (vl-catch-all-apply
                 (function (lambda nil (acet-sys-shift-down))))))))

(or *T2M_Mode* (setq *T2M_Mode* 0))
  (setq mLst '("New Line " "Same Line"))

(while
    (progn
      (setq ent (car (entsel "\nSelect Text/MText [Shift-Click keep original]: ")))
      (and et (setq shft (acet-sys-shift-down)))
      
      (cond (  (not ent)
               (princ "\n** Nothing Selected **"))
            
            (  (not (wcmatch (cdr (assoc 0 (entget ent))) "*TEXT"))
               (princ "\n** Object is not Text **")))))

(setq uFlag (not (vla-StartUndoMark doc)))

(setq tObj
    (vla-AddMText spc
      
      (vla-get-InsertionPoint
        (setq obj (vlax-ename->vla-object ent))) (GetTextWidth obj)
      
          (ReplaceUnderline (vla-get-TextString obj))))

(foreach p '(InsertionPoint Layer Color StyleName Height)
    (vlax-put-property tObj p
      (vlax-get-property obj p)))

(vla-put-rotation tObj
    (if (eq "AcDbText" (vla-get-ObjectName obj))
      (- (vla-get-rotation obj)
         (angle '(0. 0. 0.)
           (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t))))
      (vla-get-rotation obj)))
  
  (vla-put-AttachmentPoint tObj (align_Mt obj))

(or (and shft
           (setq eLst (cons nil eLst)))
      (and (entdel ent)
           (setq eLst (cons ent eLst))))

(princ (eval (setq msg '(strcat "\n  Current Mode: " (nth *T2M_mode* mLst) "    Yatay veya dikey için space tusuna bas"
                                  "\n Birlestirmek istedigin yazilari seç [Orijinal yazının kalmasını istiyorsan Shitt basılı tut] [Undo] <Place MText> "))))

(while
    (progn
      (setq grdata (grread 't 15 2)
            code   (car grdata) data (cadr grdata))

(cond (  (and (= 5 code) (listp data))

(vla-put-InsertionPoint tObj
                 (vlax-3D-point
                   (Get_MTOffset_pt tObj (trans data 1 0)))) t)

(  (and (= 3 code) (listp data))

(if (and (setq tEnt (car (nentselp data)))
                        (wcmatch (cdr (assoc 0 (entget tEnt))) "*TEXT"))
                 
                 (AddtoMTextSelection tEnt)

(progn
                   (vla-put-Visible tObj :vlax-false)

(if (setq textss (GetSelectionSet "\nPick Corner Point: " data '((0 . "TEXT,MTEXT"))))
                     (
                       (lambda ( i )
                         (while (setq e (ssname textss (setq i (1+ i))))
                           (AddtoMTextSelection e)
                         )
                         (princ (eval msg))
                       )
                       -1
                     )
                     (princ (strcat "\n** No Text/MText Selected **" (eval msg)))
                   )
                   
                   (vla-put-Visible tObj :vlax-true) t
                 )
               )
            )

(  (= 25 code) nil)

(  (= 2 code)

(cond (  (= 13 data) nil)
                     
                     (  (= 32 data)
                      
                        (setq *T2M_mode* (- 1 *T2M_mode*))
                        (princ (eval msg)))
                     
                     (  (vl-position data '(85 117))
                      
                        (if (< 1 (length eLst))
                          (progn
                            
                            (vla-put-TextString tObj
                              (substr (vla-get-TextString tObj) 1 (car lLst)))

(vla-put-Width tObj (car wLst))
                            
                            (if (car eLst) (entdel (car eLst)))
                            (setq eLst (cdr eLst) lLst (cdr lLst) wLst (cdr wLst)) t)
                          
                          (progn
                            (princ "\n** Nothing to Undo **")
                            (princ (eval msg)))))                           
                            
                     (t )))

(t ))))

(setq uFlag (vla-EndUndoMark doc))
  (princ))

(defun AddtoMTextSelection ( tEnt / nStr nObj formflag )
  (setq lLst (cons (strlen (vla-get-TextString tObj)) lLst)
        wLst (cons (vla-get-Width tObj) wLst))
  
  (setq nStr
     (vla-get-TextString
       (setq nObj
          (vlax-ename->vla-object tEnt))) formflag nil)
  
  (vla-put-Width tObj
    ((if (= *T2M_mode* 1) + max)
      (vla-get-Width tObj) (GetTextWidth nObj)))
  
  (if (not (or (eq (vla-get-Color nObj) (vla-get-Color tObj))
             (vl-position (vla-get-Color nObj) '(255 0))))
    
    (setq nStr (strcat "\\C" (itoa (vla-get-Color nObj)) ";" nStr) formflag t))
  
  (setq nStr (ReplaceUnderline nStr))
  
  (if (not (or (eq (vla-get-Height nObj) (vla-get-Height tObj))
             (and lHgt (eq (vla-get-Height nObj) lHgt))))
    
    (setq nStr (strcat "\\H" (rtos (/ (float (vla-get-Height nObj))
                                      (cond (lHgt) ((vla-get-Height tObj)))) 2 2)  "x;" nStr)
      lHgt (vla-get-Height nObj) formflag t))
  
  (if (not (eq (vla-get-StyleName nObj) (vla-get-StyleName tObj)))
    (setq nStr
       (strcat "\\F" (vla-get-fontfile
                       (vla-item
                         (vla-get-TextStyles doc)
                         (vla-get-StyleName nObj))) ";" nStr) formflag t))
  
  (if formflag (setq nStr (strcat "{" nStr "}")))
  
  (vla-put-TextString tObj
    (strcat
      (vla-get-TextString tObj)
      (if (zerop *T2M_mode*)
        (strcat "\\P" nStr)
        (strcat " "  (vl-string-left-trim (chr 32) nStr)))))
  
  (vla-update tObj)
  (or (and et (acet-sys-shift-down)
        (setq eLst (cons nil eLst)))
    (and (entdel tEnt)
      (setq eLst (cons tEnt eLst)))) t)

(defun GetSelectionSet ( str pt filter / gr data pt1 pt2 lst )
  (princ str)

(while (and (= 5 (car (setq gr (grread t 13 0)))) (listp (setq data (cadr gr))))
    (redraw)

(setq pt1 (list (car data) (cadr pt) (caddr data))
          pt2 (list (car pt) (cadr data) (caddr data)))

(grvecs
      (setq lst
        (list
          (if (minusp (- (car data) (car pt))) -30 30)
          pt pt1 pt pt2 pt1 data pt2 data
        )
      )
    )
  )

(redraw)

(ssget (if (minusp (car lst)) "_C" "_W") pt data filter)
)

(vl-load-com)
(princ "\n YAZI-BIRLESTIR lisp calistirma komutunu giriniz http://zyapimuhendisi.blogspot.com")
(princ)

Lisp dosyasını oluşturmayı ve AutoCAD"e yüklemeyi bilmiyorsanız. Lispi bilgisayara kaydetmek ve AutoCAD"e yüklemek için AutoCAD lisp dosyasını kaydetme ve yükleme nasıl yapılır yazısını okuyun

Autocad lisp çalıştırma

📜 Komut satırına "*YAZI-BIRLESTIR*" yazın ve enterlayın

📜Birleştirmek istediğiniz ilk yazıya tıklayın

📜Birleştirmek istediğiniz 2. yazıya tıklayın. Tıkladığınız zaman 2. tıklanan yazı ilk tıklanan yazını altına yada yanına geçer, Space tuşuna basarak alt veya yanı tercihlerini değiştirebilirsiniz.

📜Sırası ile diğer yazıları tıklayın, tıkladığınız son yazı bir önceki yazının altına geçer. Alt alta geçen yazıların, yan yana geçmesini istiyorsanız space tuşuna basın

📜 Mausu yerleştirmek istediğinizz yere getirin. ve enter tuşuna basın. Enter tuşuna bastıktan sonra o anda mausun ekranda bulunduğu yere yazı yerleştirilir.

AutoCAD text birleştirme lisp daha fazla ara

👀 google

👀 yandex

👀 bing

👀 youtube

👀 facebook

👀 wikipedia

👀 google kitap

👀 google trends

👀 uzmantv

👀 twitter

👀 pinterest

👀 eksisozluk

AutoCAD text birleştirme lisp ilgili benzer konular

👀 AUTOCAD TEXT BİRLEŞTİRME LİSP

👀 autocad text komutu

👀 autocad yazı birleştirme

👀 autocad text alt satıra gecme

👀 autocad text alt komutları

Yukarı çık

🐃 Yazı Lispleri lisp

AutoCAD lisp dosyasını kaydetme ve yükleme nasıl yapılır

Bu sitede yayınlanan bütün AutoCAD Lispleri Bilgisayara kaydetme ve AutoCAD"e yükleme aşağıdaki gibi yapabilirsiniz

AutoCAD lisp dosyasını kaydetme

🍀 AutoCAD Lisp kodlarının hepsini kopyalayın, siyah alanda yeşil yazılı bütün kodları kopyalayın.

-- Siyah alana tıklayıp sağ tuşa tıklayın hepsini seçin, sağ tuşa tıklayın kopyalayın

-- Mause ile tıkla ve sürükleyerek hepsini seçebirilirsiniz

🍀 Bilgisayardan not defterini açın ve kopyaladığınız kodları not defterine yapıştır.
🍀 Farklı kaydet tıklayın *DOSYAADİ*.LSP olarak kaydedin. Burada .lsp uzantısı ile kaydetmek çok önemlidir. Yoksa AutoCADe yükleme yapamaz ve çalıştıramazsınız. br /> Resimdeki örnekte DOSYAADİ.lsp olarak kaydediliyor

AutoCAD lisp dosyasını yükleme

🐋 Autocad proğramını açın
🐋 Komut satırına APPLOAD yazın ve enter tuşuna basın

🐋 *DOSYAADİ*.LSP dosyasını kaydettiğiniz yerde bulun, seçin ve load (yükle) tıklayın.
Aşağıdaki resimde örnek olarak DOSYAADİ.LSP dosyasını seçiyoruz

🐋 Karşınıza yükleme seçenekleri penceresi açılacaktır.
-- Always load : Bunu seçerseniz AutoCAD"i her açtığınızda dosyayı tekrar yüklemek gerekir.
-- Load Once : Lispi 1 kere yükledikten sonra AutoCADi kapatıp açsanız bile yükleme yapmanıza gerek kalmaz.
-- Do not Load : Lispi yüklemez.
-- Always load tıklayın, yükleme seçenekleri penceresi kapanacak.

🐋 Close tıklayın. Load/unload pencersini kapatın.

Yukarı çık

lisp

AutoCAD şekillerin etrafına kapalı alan çizme lispi

🌴 Birleşik şekillerin etrafına hepsini kapsayan kapalı alan çizer.

🌴 Kapalı alan çizdiğiniz bölgenin içindeki diğer alanları silme tercihi sunar

🌴 Sadece sectiğini neznelerin etrafını çizer, çakışan fakat seçilmeyen şekillerin etrafını çizmez

🌴 Autocad Boundary komutuna benzer bir komuttur.

Autocad lisp kodlar

(defun c:KAPALI-ALAN-CIZ ( / *error* idx sel )

(defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (if (setq sel (ssget))
        (progn
            (LM:startundo (LM:acdoc))
            (LM:outline sel)
            (initget "Yes No")
            (if (/= "No" (getkword "\nErase original objects? [Yes/No] <Yes>: "))
                (repeat  (setq idx (sslength sel))
                    (entdel (ssname sel (setq idx (1- idx))))
                )
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
    (if (setq box (LM:ssboundingbox sel))
        (progn
            (setq app (vlax-get-acad-object)
                  dis (/ (apply 'distance box) 20.0)
                  lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
                  are (apply '* (apply 'mapcar (cons '- (reverse lst))))
                  dis (* dis 1.5)
                  ent
                (entmakex
                    (append
                       '(   (000 . "LWPOLYLINE")
                            (100 . "AcDbEntity")
                            (100 . "AcDbPolyline")
                            (090 . 4)
                            (070 . 1)
                        )
                        (mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
                           '(   (caar   cadar)
                                (caadr  cadar)
                                (caadr cadadr)
                                (caar  cadadr)
                            )
                        )
                    )
                )
            )
            (apply 'vlax-invoke
                (vl-list* app 'zoomwindow
                    (mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
                )
            )
            (setq cmd (getvar 'cmdecho)
                  enl (entlast)
                  rtn (ssadd)
            )
            (while (setq tmp (entnext enl)) (setq enl tmp))
            (setvar 'cmdecho 0)
            (command
                "_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
                (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
            )
            (while (< 0 (getvar 'cmdactive)) (command ""))
            (entdel ent)
            (while (setq enl (entnext enl))
                (if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
                         (equal (vla-get-area obj) are 1e-4)
                    )
                    (entdel enl)
                    (ssadd  enl rtn)
                )
            )
            (vla-zoomprevious app)
            (setvar 'cmdecho cmd)
            rtn
        )
    )
)

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

(vl-load-com) (princ)

(princ "\n https://zyapimuhendisi.blogspot.com lisp calistirma komutunu KAPALI-ALAN-CIZ giriniz ")

AutoCAD şekillerin etrafına kapalı alan çizme lispi çalıştırma

📜 Komut satırına "KAPALI-ALAN-CIZ" yazın ve enterlayın

📜Etrafına polyline çizmek yani birleştirmek istediğiniz şekilleri seçin ve enterlayın

📜 Erase original objects soracak : Etrafını çizdiğiniz şekiller içerde kalsınmı yoksa silinsinmi tercihini soruyor

-- Eğer silinsinmesini istiyorsanız yes secin ve enterlayın. Seklin içindeki nesneler silinecek

-- Eğer silinmesin kalsın istiyorsanız no yu seçin

Şekillerin hepsini değil sadece seçilenlerin etrafına kapalı alan çizme

📜 Komut satırına "KAPALI-ALAN-CIZ" yazın ve enterlayın

📜 Şimdi 3 şeklide değilde sadece 2 tanesini seçiyorum. Sadece kare ve daireyi seçiyorum, çokgeni seçmiyorum ve enter tuşuna basıyorum

📜 Eski şekiller silinsinmi sorusuna no diyorum

📜 Bir önceki örnekten farklı olarak sadece 2 şeklin etrafını çiziyor.

AutoCAD şekillerin etrafına kapalı alan çizme lispi daha fazla ara

👀 google

👀 yandex

👀 bing

👀 youtube

👀 facebook

👀 wikipedia

👀 google kitap

👀 google trends

👀 uzmantv

👀 twitter

👀 pinterest

👀 eksisozluk

AutoCAD şekillerin etrafına kapalı alan çizme lispi ilgili benzer konular

👀 autocad hizalama çizgisi

👀 autocad açili çizim komutu

👀 autocad kısayolları

👀 autocad iki çizgi arası mesafe ayarlama

👀 autocad iki çizgi çizerken ölçülendirme

👀 autocad hızlı çizim teknikleri

👀 autocad multiline komutu

👀 autocad komutları

Yukarı çık

🐇 Çizim Lisp lisp

AutoCAD toplam alan veya toplam çevreyi istediğin yere yazdırma - Metraj Lispi

+ Bir veya birkaç alan ve çevresi olan şekillerin. toplam alan ve toplam çevresini istediğiniz yere yazdırma lispi.

AutoCAD toplam alan veya toplam çevreyi istediğin yere yazdırma

Autocad lisp kodlar

;;----------------------------------------------------------------------;;
;; Length Field Commands    UZUNLUK YAZMA  KOMUTLARI                             ;;
;;----------------------------------------------------------------------;;

(defun c:UZUNLUK-YAZ  ( ) (lengthfield nil "%lu6"))            ;; Current units CEVRE CM YAZ
(defun c:UZUNLUK-YAZ-0,01 ( ) (lengthfield nil "%lu6%ct8[0.01]")) ;; Current units with 0.01 conversion factor (cm->m) CEVRE METRE YAZ

;;----------------------------------------------------------------------;;
;; Area Field Commands         ALAN YAZMA KOMUTLARI                                         ;;
;;----------------------------------------------------------------------;;

(defun c:ALAN-YAZ  ( ) (areafield nil "%lu6%qf1"))           ;; Current units ALAN CM YAZ
(defun c:ALAN-YAZ-0,001 ( ) (areafield nil "%lu6%qf1%ct8[1e-4]")) ;; Current units with 1e-4 (0.0001) conversion factor (cm2->m2) ALAN METRE YAZ

(defun lengthfield ( tag fmt / *error* idx lst obj prp sel )
    
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (LM:startundo (LM:acdoc))
    (setq prp
       '(
            ("AcDbArc"        . "ArcLength")
            ("AcDbCircle"     . "Circumference")
            ("AcDbLine"       . "Length")
            ("AcDbPolyline"   . "Length")
            ("AcDb2dPolyline" . "Length")
            ("AcDb3dPolyline" . "Length")
        )
    )

(if
        (setq sel
            (LM:ssget "\nSelect objects to obtain total length <exit>: "
                (list
                    (list
                       '(000 . "ARC,CIRCLE,LINE,*POLYLINE")
                       '(-04 . "<NOT")
                           '(-04 . "<AND")
                               '(000 . "POLYLINE") '(-04 . "&") '(070 . 80)
                           '(-04 . "AND>")
                       '(-04 . "NOT>")
                        (if (= 1 (getvar 'cvport))
                            (cons 410 (getvar 'ctab))
                           '(410 . "Model")
                        )
                    )
                )
            )
        )
        (LM:outputtext tag
            (if (= 1 (sslength sel))
                (progn
                    (setq obj (vlax-ename->vla-object (ssname sel 0)))
                    (strcat
                        "%<\\AcObjProp Object(%<\\_ObjId "
                        (LM:objectid obj)
                        ">%)." (cdr (assoc (vla-get-objectname obj) prp))
                        (if (and fmt (/= "" fmt)) (strcat " \\f \"" fmt "\">%") ">%")
                    )
                )
                (progn
                    (repeat (setq idx (sslength sel))
                        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                              lst
                            (vl-list*
                                "%<\\AcObjProp Object(%<\\_ObjId "
                                (LM:objectid obj)
                                ">%)." (cdr (assoc (vla-get-objectname obj) prp)) ">%" " + "
                                lst
                            )
                        )
                    )
                    (strcat
                        "%<\\AcExpr "
                        (apply 'strcat (reverse (cdr (reverse lst))))
                        (if (and fmt (/= "" fmt)) (strcat " \\f \"" fmt "\">%") ">%")
                    )
                )
            )
        )
    )
    (*error* nil) (princ)
)

;;----------------------------------------------------------------------;;

(defun areafield ( tag fmt / *error* idx lst sel )

(defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (LM:startundo (LM:acdoc))

(if
        (setq sel
            (LM:ssget "\nSelect objects to obtain total area <exit>: "
                (list
                    (list
                       '(000 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE,REGION,SPLINE")
                       '(-04 . "<NOT")
                           '(-04 . "<AND")
                               '(000 . "POLYLINE") '(-04 . "&") '(070 . 88)
                           '(-04 . "AND>")
                       '(-04 . "NOT>")
                        (if (= 1 (getvar 'cvport))
                            (cons 410 (getvar 'ctab))
                           '(410 . "Model")
                        )
                    )
                )
            )
        )
        (LM:outputtext tag
            (if (= 1 (sslength sel))
                (strcat
                    "%<\\AcObjProp Object(%<\\_ObjId "
                    (LM:objectid (vlax-ename->vla-object (ssname sel 0)))
                    ">%).Area"
                    (if (and fmt (/= "" fmt)) (strcat " \\f \"" fmt "\">%") ">%")
                )
                (progn
                    (repeat (setq idx (sslength sel))
                        (setq lst
                            (vl-list*
                                "%<\\AcObjProp Object(%<\\_ObjId "
                                (LM:objectid (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                                ">%).Area>%" " + "
                                lst
                            )
                        )
                    )
                    (strcat
                        "%<\\AcExpr "
                        (apply 'strcat (reverse (cdr (reverse lst))))
                        (if (and fmt (/= "" fmt)) (strcat " \\f \"" fmt "\">%") ">%")
                    )
                )
            )
        )
    )
    (*error* nil) (princ)
)

;; Output Text  -  Lee Mac
;; Prompts the user to specify a point at which to create an MText object containing the supplied string or to
;; select a table cell, text, mtext, multileader, attribute, or attributed block to be populated with the supplied string.
;; tag - [str] Optional target attribute tag
;; str - [str] Field expression or other text content

(defun LM:outputtext ( tag str / ent enx flg idx obj oid sel tab tmp typ )
    (if
        (setq tmp
            (ssget "_X"
                (list '(0 . "ACAD_TABLE")
                    (if (= 1 (getvar 'cvport))
                        (cons 410 (getvar 'ctab))
                       '(410 . "Model")
                    )
                )
            )
        )
        (repeat (setq idx (sslength tmp))
            (setq tab (cons (vlax-ename->vla-object (ssname tmp (setq idx (1- idx)))) tab))
        )
    )
    (while
        (not
            (progn
                (if flg
                    (progn
                        (setvar 'errno 0)
                        (initget "Point eXit")
                        (setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block [Point/eXit] <eXit>: "))
                    )
                    (progn
                        (initget "Object eXit")
                        (setq sel (getpoint "\nSpecify point or table cell [Object/eXit] <eXit>: "))
                    )
                )
                (cond
                    (   (= 7 (getvar 'errno))
                        (prompt "\nMissed, try again.")
                    )
                    (   (or (null sel) (= "eXit" sel)))
                    (   (= "Point" sel)
                        (setq flg nil)
                    )
                    (   (= "Object" sel)
                        (not (setq flg t))
                    )
                    (   flg
                        (setq ent (car sel)
                              enx (entget ent)
                              typ (cdr (assoc 0 enx))
                              obj (vlax-ename->vla-object ent)
                        )
                        (cond
                            (   (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
                                (if (vlax-write-enabled-p obj)
                                    (LM:outputtext:puttextstring obj str)
                                    (prompt "\nThe selected text object is on a locked layer.")
                                )
                            )
                            (   (and (= "ATTRIB" typ)
                                     (/= 'str (type tag))
                                )
                                (if (vlax-write-enabled-p obj)
                                    (progn
                                        (LM:outputtext:puttextstring obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*") (LM:outputtext:updatefield ent))
                                    )
                                    (prompt "\nThe selected attribute is on a locked layer.")
                                )
                            )
                            (   (and
                                    (or
                                        (and (= "ATTRIB" typ)
                                             (setq tmp (cdr (assoc 330 enx)))
                                        )
                                        (and (setq tmp (last (cadddr sel)))
                                             (= "INSERT" (cdr (assoc 0 (entget tmp))))
                                        )
                                    )
                                    (setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
                                    (or
                                        (and (= 'str (type tag))
                                             (setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
                                             (setq obj (nth idx tmp))
                                        )
                                        (and (not (cdr tmp))
                                             (setq obj (car tmp))
                                        )
                                        (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'vla-get-tagstring tmp) 2))
                                             (setq obj (nth (car idx) tmp))
                                        )
                                    )
                                )
                                (if (vlax-write-enabled-p obj)
                                    (progn
                                        (LM:outputtext:puttextstring obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*") (LM:outputtext:updatefield (vlax-vla-object->ename obj)))
                                    )
                                    (prompt "\nThe selected attribute is on a locked layer.")
                                )
                            )
                            (   (and (= 2 (length sel)) (= "MULTILEADER" typ))
                                (setq typ (cdr (assoc 172 (reverse enx))))
                                (cond
                                    (   (and (<= acblockcontent typ acmtextcontent) (not (vlax-write-enabled-p obj)))
                                        (prompt "\nThe selected multileader is on a locked layer.")
                                    )
                                    (   (= acmtextcontent typ)
                                        (LM:outputtext:puttextstring obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*") (vla-regen (LM:acdoc) acactiveviewport))
                                        t
                                    )
                                    (   (and
                                            (= acblockcontent typ)
                                            (setq tmp (LM:getmleaderattributes obj))
                                            (or
                                                (and (= 'str (type tag))
                                                     (setq oid (cdr (assoc (strcase tag) tmp)))
                                                )
                                                (and (not (cdr tmp))
                                                     (setq oid (cdar tmp))
                                                )
                                                (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'car tmp) 2))
                                                     (setq oid (cdr (nth (car idx) tmp)))
                                                )
                                            )
                                        )
                                        (LM:setmleaderattributevalue obj oid str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*") (vla-regen (LM:acdoc) acactiveviewport))
                                        t
                                    )
                                    (   (prompt "\nThe select multileader has no editable content."))
                                )
                            )
                            (   (prompt "\nThe selected object is not text, mtext, multileader, attribute or attributed block."))
                        )
                    )
                    (   (setq tmp (LM:getcell tab (trans sel 1 0)))
                        (if (vlax-write-enabled-p (car tmp))
                            (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-settext (append tmp (list str)))))
                            (prompt "\nThe selected table cell belongs to a table on a locked layer.")
                        )
                    )
                    (   (vla-addmtext
                            (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                            (vlax-3D-point (trans sel 1 0))
                            0.0
                            str
                        )
                    )
                )
            )
        )
    )
)

(defun LM:outputtext:puttextstring ( obj str )
    (vla-put-textstring obj "") ;; To clear any existing field
    (vla-put-textstring obj str)
    t
)

(defun LM:outputtext:updatefield ( ent / cmd rtn )
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (setq rtn (vl-cmdf "_.updatefield" ent ""))
    (setvar 'cmdecho cmd)
    rtn
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; Get MLeader Attributes  -  Lee Mac
;; Returns an association list of attribute tags & object IDs for all attributes held by an mleader block
;; mld - [vla] MLeader vla-object
;; Returns: [lst] List of ((<Attribute Tag> . <Object ID>) ... )

(defun LM:getmleaderattributes ( mld / rtn )
    (vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld)) (vla-get-contentblockname mld))
        (if
            (and
                (= "AcDbAttributeDefinition" (vla-get-objectname obj))
                (= :vlax-false (vla-get-constant obj))
            )
            (setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (LM:intobjectid obj)) rtn))
        )
    )
    (reverse rtn)
)

;; Object ID (integer)  -  Lee Mac
;; Returns an integer representing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:intobjectid ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (defun LM:intobjectid ( obj ) (vla-get-objectid32 obj))
        (defun LM:intobjectid ( obj ) (vla-get-objectid   obj))
    )
    (LM:intobjectid obj)
)

;; Set MLeader Attribute Value  -  Lee Mac
;; obj - [vla] MLeader vla-object
;; idx - [int] Attribute Definition Object ID
;; str - [str] Attribute value

(defun LM:setmleaderattributevalue ( obj idx str )
    (if (vlax-method-applicable-p obj 'setblockattributevalue32)
        (defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
        (defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue   obj idx str))
    )
    (LM:setmleaderattributevalue obj idx str)
)

;; List Box  -  Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg - [str] Dialog label
;; lst - [lst] List of strings to display
;; bit - [int] 1=allow multiple; 2=return indexes
;; Returns: [lst] List of selected items/indexes, else nil
 
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select="
                            (if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "listbox" dch)
                )
            )
            (prompt "\nError Loading List Box Dialog.")
        )
        (   t     
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn
                (if (= 1 (start_dialog))
                    (if (= 2 (logand 2 bit))
                        (read (strcat "(" rtn ")"))
                        (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
                    )
                )
            )
        )
    )
    (if (< 0 dch)
        (unload_dialog dch)
    )
    (if (and tmp (setq tmp (findfile tmp)))
        (vl-file-delete tmp)
    )
    rtn
)

;; Get Cell  -  Lee Mac
;; If the supplied point lies within a cell boundary,
;; returns a list of: (<VLA Table Object> <Row> <Col>)
 
(defun LM:getcell ( lst pnt / dir )
    (setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
          pnt (vlax-3D-point pnt)
    )
    (vl-some
       '(lambda ( tab / row col )
            (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
                (list tab row col)
            )
        )
        lst
    )
)

;; ObjectID  -  Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:objectid ( obj )
    (eval
        (list 'defun 'LM:objectid '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
                   '(LM:ename->objectid (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LM:objectid obj)
)

;; Entity Name to ObjectID  -  Lee Mac
;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name

(defun LM:ename->objectid ( ent )
    (LM:hex->decstr
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; Hex to Decimal String  -  Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string

(defun LM:hex->decstr ( hex / foo bar )
    (defun foo ( lst rtn )
        (if lst
            (foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )
    (defun bar ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (bar (/ int 10) (cdr lst)))
            )
            (bar int '(0))
        )
    )
    (foo (vl-string->list (strcase hex)) nil)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
    (strcat
        "\n Toplam alanı yazmak için ALAN-YAZ giriniz"
        "\n Toplam Uzunluğu yazmak için UZUNLUK-YAZ giriniz"
        "\n Z Yapı Mühendisi"
    )
)
(princ)

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

Toplam alanı yazma

- komut satırına "ALAN-YAZ" yazın ve enter düğmesine basın

- Alanları yazmak istediğiniz şekilleri seçin enter tuşuna basın

- alanı yazmak istediğiniz yeri secin

1--herhangi boş bir yere tıklayın

--- alan tıkladığınız yere yazılacak

2 --- alanı ekranda yazılı bir yazının üzerine yazdırma

---Alanları yazmak istediğiniz şekilleri seçip

--- enter düğmesine bastıktan sonra

--- Object (nesne ) seçeneği için O yazın ve enterlayın veya object tıklayın

--- üzerine yazmak istediğiniz yazıya tıklayın. örnekte yazı7 tıklıyorum

--- yazı7 yi tıkladıktan sonra, yazı7 yerine toplam alan yazılacaktır.

Toplam uzunluğu yazma lispi

Alan yazna kısmında adımlar aynen uygulanır. Burada ALAN-YAZ yerine UZUNLUK-YAZ yazılır.

--- Kumanda satırına "UZUNLUK-YAZ" yazın.

--- Nesneleri seçin ve enter tuşuna basın.

--- Uzunluk yazmak istediğiniz yere tıklayın.

--- toplam uzunluk yazılacak.

Yukarı çık

🐄 Metraj Lispi 🐅 Alan-Çevre Lispleri lisp

AutoCAD iki nokta arasındaki uzunluğu yazan lisp - Metraj Lispi

Autocad de tıkladığın herhangi iki nokta arasındaki uzaklığı yazar.

Autocad lisp kodlar

AutoCAD iki nokta arasındaki uzunluğu yazan lisp resimli anlatım

- Komut satırına "UZUNLUK-IKI-NOKTA" yazın ve enter tuşuna basın

- yazi boyu istenecek, yazılacak yazının yüksekliğini belirleyin. 10 20 100 şeklinde bir sayı giriniz

- ben yazı boyunu 4 yazıp entera basıyorum

- ilk noktayı giriniz : ilk noktaya ekranda tıklayınız

- ikinci noktaya ekranda tıklayınız

- ikinci noktaya tıkladıktan sonra arasındaki mesafeyi üzerine yazar

AutoCAD iki nokta arasındaki uzunluğu yazan lisp daha fazla ara

👀 google

👀 yandex

👀 bing

👀 youtube

👀 facebook

👀 wikipedia

👀 google kitap

👀 google trends

👀 uzmantv

👀 twitter

👀 pinterest

👀 eksisozluk

AutoCAD iki nokta arasındaki uzunluğu yazan lisp ilgili benzer konular

👀 autocad uzunluk ölçme komutu

👀 autocad seçilen çizgilerin toplam uzunluğu

👀 autocad çizgi uzunluğu gösterme

👀 autocad kot verme

👀 autocad spline uzunluğu ölçme kısayol

👀 autocad uzunluk yazma

👀 harocad lisp

Yukarı çık

🐄 Metraj Lispi 🐊 uzunluk lispleri lisp

AutoCAD çizgileri toplayan lips - Metraj Lispi

Bir kaç çizginin uzunluklarını toplayarak toplam uzunluğunu verir.

Autocad lisp kodlar

(defun c:UZUNLUK-METRAJ ()
  (setvar "modemacro" "zyapimuhendisi.blogspot.com")
  (vl-load-com)
  (setq secim (ssget '((-4 . "<OR")
       (0 . "LINE")
       (0 . "LWPOLYLINE")
       (0 . "ARC")
       (0 . "ELLIPSE")
       (0 . "SPLINE")
       (0 . "CIRCLE")
       (-4 . "OR>")
      )
      )
  )
  (if (= secim nil)
    (progn
    )
    (progn
      (setq sayim (sslength secim))
      (setq toplami 0
    c 0
      )
      (while (< c sayim)
(setq teksecim (ssname secim c))
(setq tanimi (cdr (assoc 0 (entget teksecim))))
(if (= tanimi "ARC")
  (progn
    (setq data (vlax-ename->vla-object teksecim))
    (setq uz-bul (vla-get-arclength data))
    (setq toplami (+ toplami uz-bul))
  ))
(if (or (= tanimi "LINE")(= tanimi "LWPOLYLINE")(= tanimi "POLYLINE"))
  (progn
    (setq data (vlax-ename->vla-object teksecim))
    (setq uz-bul (vla-get-length data))
    (setq toplami (+ toplami uz-bul))
  )
)
(if (= tanimi "CIRCLE")
  (progn
    (setq data (vlax-ename->vla-object teksecim))
    (setq uz-bul (vla-get-circumference data))
    (setq toplami (+ toplami uz-bul))))
(if (or (= tanimi "ELLIPSE")(= tanimi "SPLINE"))
  (progn
    (command "._area" "e" teksecim)
    (setq uz-bul (getvar "perimeter"))
    (setq toplami (+ toplami uz-bul))))
(setq c (+ c 1))
      )
      (alert (strcat "\nToplam Uzunluk : " (rtos toplami 2 3)))
    )
  )
  (princ)
)

Autocad lisp çalıştırma

Kumanda satırına UZUNLUK-METRAJ yazın ve enter tuşuna basın
Metrajını almak istediğiniz çizgilere ekranda tıklayın veya toplu seçin
Line ve polyline hepsini seçiyorum
Enter tuşuna basın.
Kaç şekil seçildiği kumanda satırında yazar
Toplam uzunluk açılan pencerede yazar

Yukarı çık

🐄 Metraj Lispi 🐊 uzunluk lispleri lisp

AutoCAD toplam alanları satırda gösteren lisp - Metraj Lispi

🍅 Alanlarını bulmak istediğiniz bir veya bir kaç nesneye tıkladığınızda, Toplam alanları komut satırında gösteren lisp.

Autocad lisp kodlar

(defun c:ALAN-SATIRDA-GOSTER (/ olderr oldcmdecho errexit undox restore ss1 nr en tot_area)
  (defun errexit (s)
    (restore)
  )

(defun undox ()
    (command "._undo" "_E")
    (setvar "cmdecho" oldcmdecho)
    (setq *error* olderr)
    (princ)
  )

(setq olderr  *error*
        restore undox
        *error* errexit
  )
  (setq oldcmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (command "._UNDO" "_BE")
  (if (setq ss1 (ssget '((-4 . "<OR")
                         (0 . "POLYLINE")
                         (0 . "LWPOLYLINE")
                         (0 . "CIRCLE")
                         (0 . "ELLIPSE")
                         (0 . "SPLINE")
                         (0 . "REGION")
                         (-4 . "OR>")
                        )
                )
      )
    (progn
      (setq nr 0)
      (setq tot_area 0.0)
      (setq en (ssname ss1 nr))
      (while en
        (command "._area" "_O" en)
        (setq tot_area (+ tot_area (getvar "area")))
        (setq nr (1+ nr))
        (setq en (ssname ss1 nr))
      )
      (princ "\nTotal Area = ")
      (princ tot_area)
    )
  )
  (setq ss1 nil)
  (restore)
)