;|***************************************************************************|;
;| Beneficial AutoLisp Functions. Author: M. Şahin Güvercin                  |;
;|___________________________________________________________________________|;
(defun ssv (/) (setvar "cmdecho" 0) (command "_.undo" "group"))
(defun rsv (/) (command "_.undo" "e") (setvar "cmdecho" 1) (prin1))
;|___________________________________________________________________________|;

;|***************************************************************************|;
;| ChCLr: Change CoLor.                                                      |;
;| Seçilen obje gurubunun rengini, seçilen obje rengine çevirir.             |;
;|---------------------------------------------------------------------------|;
(defun C:ChCLr (/ ss e n)
  (ssv) (princ "select objects to be changed: ") (if (setq ss (ssget))
    (if (setq e (entget (car (entsel "\rpick an object to desired color: "))))
      (progn (if (and (setq n (cdr (assoc 62 e))) (= n 0))
               (setq n "BYBLOCK") (setq n "BYLAYER"))
        (command "_.chprop" ss "" "c" n "")))) (rsv))

;|***************************************************************************|;
;| ChCLyr: Change to Current Layer.                                          |;
;| Seçilen Obje Gurubunun layer'ını Current Layer'a çevirir.                 |;
;|---------------------------------------------------------------------------|;
(defun C:ChCLyr (/)
  (ssv) (command "_.chprop" (ssget) "" "layer" (getvar "cLayer") "") (rsv))

;|***************************************************************************|;
;| ChLyr: Change Layer.                                                      |;
;| Seçilen Obje Layer'larını, Seçilen bir Objenin Layer'ına değiştirir.      |;
;|---------------------------------------------------------------------------|;
(defun C:ChLyr (/ ss e)
  (ssv) (princ "select objects to be changed: ")
  (command "_.chprop" (ssget) "" "layer" (cdr (assoc 8 (entget (car (entsel
   "\rpick an object on desired layer: "))))) "") (rsv))

;|***************************************************************************|;
;| DeLLyr: Delete Layer.                                                     |;
;| Seçilen gurup içindeki veya tüm çizim içinde, belirlenen Layer daki       |;
;| tüm Objeleri Siler. Tüm çizim için ALL girilmelidir.                      |;
;|---------------------------------------------------------------------------|;
(defun C:DeLLyr (/ L sLyr Ln)
  (ssv) (setq L (getstring "\nEnter layer to delete: "))
  (if (= L "") (setq L (cdr (assoc 8 (entget (car (entsel
                                   "\rPick an object on desired layer: ")))))))
  (command "_.erase" (ssget"x" (list (cons 8 L))) "") (rsv))

;|***************************************************************************|;
;| SeLLyr: Select Layer.                                                     |;
;| Seçilen gurup içindeki veya tüm çizim içindeki Layer Name ile veya        |;
;| Obje Seçilerek belirlenen Layer'daki Objeleri Seçer. Tüm çizim için ALL   |;
;| girilmelidir.                                                             |;
;|---------------------------------------------------------------------------|;
(defun C:SeLLyr (/ L sLyr Ln)
  (ssv) (setq L (strcase (getstring "\nEnter layer to select: ")))
  (if (= L "") (setq L (cdr (assoc 8 (entget (car (entsel
                                   "\rPick an object on desired layer: ")))))))
  (setq sLyr (ssget (list (cons 8 L)))) (command "_.select" sLyr "") (rsv))

;|***************************************************************************|;
;| MSeLLyr: Multiple Select Layer.                                           |;
;| Layer Name veya Objeler Seçilerek belirlenen Layer'lardaki Objeleri Seçer.|;
;|---------------------------------------------------------------------------|;
(defun C:MSeLLyr (/ LyR La sLyr)
  (ssv) (while (setq La (entsel)) (setq La (cdr (assoc 8 (entget (car La)))))
          (if LyR (setq LyR (strcat LyR "," La)) (setq LyR La))
          (ssget "X" (list (cons 8 LyR)))) (command "_.Select" "p" "") (rsv))

;|***************************************************************************|;
;| SetLyr: Set Current Layer.                                                |;
;| Seçilen Objenin Layer'ını Current Layer yapar.                            |;
;|---------------------------------------------------------------------------|;
(defun C:SetLyr (/ e)
  (ssv) (setvar "clayer" (cdr (assoc 8 (entget (car (entsel
          "\nPick an object on desired layer:")))))) (rsv))

;|***************************************************************************|;
;| FrzLyr: Freeze Layer.                                                     |;
;| Seçilen Objenin bulunduğu Layer'ı Freeze eder.                            |;
;|---------------------------------------------------------------------------|;
(defun C:FrzLyr(/ e)
  (ssv) (if (/= (setq L (cdr (assoc 8 (setq e (entget (car (entsel
                 "\nPick an object on desired layer:"))))))) (getvar "cLayer"))
          (command "_.Layer" "f" (cdr (assoc 8 e)) "")
          (princ "\nCurrent Layer cannot be freeze!")) (rsv))

;|***************************************************************************|;
;| isoLyr: Isolate Layer.                                                    |;
;| Seçilen Objenin bulunduğu Layer dışındaki tüm Layer'lar freeze edilir.    |;
;|---------------------------------------------------------------------------|;
(defun C:isoLyr (/ L)
  (ssv) (setq L (car (entsel "\nPick an object on desired layer:")))
  (setvar "CLayer" (cdr (assoc 8 (entget L))))
  (command "_.Layer" "Freeze" "*" "") (rsv))

;|***************************************************************************|;
;| ChLTyp: Change LineType.                                                  |;
;| Seçilen Obje Gurubunun LineType'ını Seçilen Objeninkine çevirir.          |;
;|---------------------------------------------------------------------------|;
(defun C:ChLTyp (/ ss e n)
  (ssv) (princ "select objects to be changed: ")
  (setq ss (ssget) e (car (entsel "\rpick an object to desired LineType: ")))
  (if (= (setq n (cdr (assoc 6 (entget e)))) nil) (setq n "BYLAYER"))
  (command "_.chprop" ss "" "Lt" n "") (rsv))

;|***************************************************************************|;
;| ChStyL: Change Text StyLe.                                                |;
;| Seçilen Text Objeleri içindeki belirlenen Text Style'a sahip objelerin    |;
;| Text Style'larını Seçilen Objeninkine Degiştirir.                         |;
;|---------------------------------------------------------------------------|;
(defun C:ChStyL (/ chm p ost nst n e)
  (ssv) (if (setq chm 0 p (ssget (list (cons 0 "*Text")))) (progn
      (if (= "" (setq ost (getstring "\nOld style: ")))
        (setq ost (cdr (assoc 7 (entget (car (entsel "pick an object.")))))))
      (if (= "" (setq nst (getstring "\nNew style: ")))
        (setq nst (cdr (assoc 7 (entget (car (entsel "pick an object.")))))))
      (setq n (sslength p))
      (while (not (minusp (setq n (1- n))))
        (if (= ost (cdr (assoc 7 (setq e (entget (ssname p n))))))
          (setq e (subst (cons 7 nst) (assoc 7 e) e) e (entmod e)
                e (entupd (cdr (assoc -1 e))) chm (1+ chm))))))
  (princ (strcat "\nChanged " (itoa chm) " text lines")) (rsv))

;|***************************************************************************|;
;| ChTxh: Change Text Height.                                                |;
;| Seçilen bir Obje Gurubu içindeki belirlenen Yazı Yüksekliğine sahip Text  |;
;| Objelerinin Yüksekliğini Seçilen Text Objesininkine değiştirir.           |;
;|---------------------------------------------------------------------------|;
(defun C:ChTxh (/ chm p otxh tobj ntxh n e)
  (ssv) (princ "\nSelect Text objects...")
  (if (setq chm 0 p (ssget (list (cons 0 "TEXT")))) (progn
      (if (not (setq otxh (getreal "\nOld Height <Enter for Select Object>:")))
        (progn (princ "\nPick an object for Old Text Height...")
          (while (not (setq tobj (ssget ":s" (list (cons 0 "Text")))))
            (princ "\nPlease Select a Text Object"))
          (setq otxh (cdr (assoc 40 (entget (ssname tobj 0)))))))
      (if (not (setq ntxh (getreal "\nNew Height <Enter for Select Object>:")))
        (progn (princ "\nPick an object for New Text Height...")
          (while (not (setq tobj (ssget ":s" (list (cons 0 "Text")))))
            (princ "\nPlease Select a Text Object"))
          (setq ntxh (cdr (assoc 40 (entget (ssname tobj 0)))))
          (setq ntxh (cdr (assoc 40 (entget tobj))))))
      (setq n (sslength p))
      (while (not (minusp (setq n (1- n))))
        (if (= otxh (cdr (assoc 40 (setq e (entget (ssname p n))))))
          (setq e (subst (cons 40 ntxh) (assoc 40 e) e) chm (1+ chm)
                e (entmod e) e (entupd (cdr (assoc -1 e))))))))
  (princ (strcat "\n" (itoa chm) " Text Object(s) Changed ")) (rsv))

;|***************************************************************************|;
;| ChCrr: Change CircLe Radius.                                              |;
;| Seçilen Gurup içindeki belirlenen Radius değerine sahip Çember çaplarını  |;
;| seçilecek başka bir çemberin Çapına çevirir.                              |;
;|---------------------------------------------------------------------------|;
(defun C:ChCrr (/ chm p ocr ncr n e)
  (ssv) (if (setq chm 0 p (ssget (list (cons 0 "CircLe"))))
    (progn (if (not (setq ocr (getreal "\nOld radius: ")))
        (setq ocr (cdr (assoc 40 (entget (car (entsel "\npick an object")))))))
      (if (not (setq ncr (getreal "\nNew radius: ")))
        (setq ncr (cdr (assoc 40 (entget (car (entsel "\npick an object")))))))
      (setq n (sslength p))
        (while (not (minusp (setq n (1- n)))) (setq e (entget (ssname p n)))
          (if (= ocr (cdr (assoc 40 e)))
            (setq e (subst (cons 40 ncr) (assoc 40 e) e) chm (1+ chm)
                  e (entmod e) e (entupd (cdr (assoc -1 e))))))))
  (princ (strcat "\nChanged " (itoa chm) " Circile(s)")) (rsv))

;|***************************************************************************|;
;| ChTxT: Change Text.                                                       |;
;| Seçilen Text ve MText Gurubu içinde belirlenen Karakter Dizisi'ni içeren  |;
;| Objelerde, Mevcut Karakter Dizisi, Yeni Karakter Dizisi ile değiştirilir. |;
;| Mevcut ve Yeni Karakter Dizilerinde Boşluk Karakteri bulunabilir.         |;
;|---------------------------------------------------------------------------|;
(defun C:ChTxT (/ chm p os ns n e as)
  (ssv) (if (setq chm 0 p (ssget (list (cons 0 "*Text"))))
    (progn (if (not oso) (initget 1))
      (setq os (getstring T (strcat "\nOld string <" (if oso oso "") ">:")))
      (if (= "" os) (setq os oso) (setq  oso os))
      (setq ns (getstring T "\nNew string: ") n (sslength p))
      (while (not (minusp (setq n (1- n)))) (setq e (entget (ssname p n)))
        (while (vl-string-search os (setq as (cdr (assoc 1 e)))
          (setq as (vl-string-subst ns os as)
                e (subst (cons 1 as) (assoc 1 e) e)))
        (setq e (entmod e) e (entupd (cdr (assoc -1 e))) chm (1+ chm))))))
  (princ (strcat "\nChanged " (itoa chm) " text line(s).")) (rsv))

;|***************************************************************************|;
;| dOffsT: Double Offset.                                                    |;
;| Seçilen objenin her iki yanına offset yapar. Obje seçmeye devam edildikçe |;
;| işleme devam edilir.                                                      |;
;|---------------------------------------------------------------------------|;
(defun C:dOffsT (/ oos ood ms eL e1 an p1 p2)
  (ssv) (setq oos (getvar "osmode") ood (getvar "OffsetDist")
              ms (getdist "\nOffset distance <")) (setvar "osmode" 0)
  (while (setq eL (entsel))
    (setq e1  (entget (car eL))
          an (angle (cdr (assoc 10 e1)) (cdr (assoc 11 e1)))
          p1 (polar (cdr (assoc 10 e1)) (+ an (/ pi 2)) 100.00)
          p2 (polar (cdr (assoc 11 e1)) (+ an (* 1.5 pi)) 100.00))
    (command "_.Offset" ms eL p1 eL p2 ""))
  (setvar "osmode" oos) (setvar "OffsetDist" ood) (rsv))

;|***************************************************************************|;
;| LtCrt: LineType Create.                                                   |;
;| Kesik, Aks, Noktali ve Kesciz isimli Çizgi Tiplerini oluşturur.           |;
;| Oluşturulan Çizgi tipleri için, kağıt üzerindeki boyut esas alınmıştır.   |;
;| LtScaLe sistem değişkeni PLot Scale'e eşitlenerek kullanılmalıdır.        |;
;|---------------------------------------------------------------------------|;
(defun c:LtCrt (/)
  (entmake '((0 . "LTYPE") (100 . "AcDbSymbolTableRecord")
   (100 . "AcDbLinetypeTableRecord") (2 . "Kesik") (70 . 0) (3 . "Kesik")
   (72 . 65) (73 . 2) (40 . 3.25) (49 . 2.00) (74 . 0) (49 . -1.25) (74 . 0)))
  (entmake '((0 . "LTYPE") (100 . "AcDbSymbolTableRecord")
   (100 . "AcDbLinetypeTableRecord") (2 . "Aks") (70 . 0) (3 . "Aks")
   (72 . 65) (73 . 5) (40 . 52.50) (49 . 25.0) (74 . 0) (49 . -1.25) (74 . 0)
   (49 . 0.0) (74 . 0) (49 . -1.25) (74 . 0) (49 . 25.0) (74 . 0)))
  (entmake '((0 . "LTYPE") (100 . "AcDbSymbolTableRecord")
   (100 . "AcDbLinetypeTableRecord") (2 . "Noktali") (70 . 0) (3 . "Noktalı")
   (72 . 65) (73 . 2) (40 . 1.0) (49 . 0.0) (74 . 0) (49 . -1.0) (74 . 0)))
  (entmake '((0 . "LTYPE") (100 . "AcDbSymbolTableRecord")
   (100 . "AcDbLinetypeTableRecord") (2 . "Kesit") (70 . 0) (3 . "Kesit")
   (72 . 65) (73 . 7) (40 . 18.0) (49 . 7.125) (74 . 0) (49 . -1.25) (74 . 0)
   (49 . 0.0) (74 . 0) (49 . -1.25) (74 . 0) (49 . 0.0) (74 . 0) (49 . -1.25)
   (74 . 0) (49 . 7.125) '(74 . 0))) (prin1))

;|***************************************************************************|;
;|  Seçilen PoLyLine objesinin parça boyları üzerine yazılarak, gösterilen   |;
;|  yere toplam boy yazılır. PoLyLine segmentleri doğrusal kabul edilir.     |;
;|---------------------------------------------------------------------------|;
(defun C:DB (/ *error* Luf dp L ds tx sTy pLL cRd n1 n2 bn ms ac)
  (ssv) (vl-load-com) (defun *error* (er) (princ (strcat "\n" er))
                        (setq Lufo Luf dpo dp) (command "undo" "e") (prin1))
  (if (= Lufo nil) (setq Lufo 1)) (if (= dpo nil) (setq dpo 2))
  (setq Luf (getreal (strcat "\nÇizilen/Yazılan oranı <" (rtos Lufo) ">:"))
        dp (getint (strcat "\rOndalık basamak sayısı <" (itoa dpo) ">: ")))
  (if (= nil Luf) (setq Luf Lufo)) (if (= nil dp) (setq dp dpo))
  (setq L 0 ds (* (getvar "dimscale") (getvar "dimgap"))
        tx (*(getvar "dimscale")(getvar "dimtxt")) sTy(getvar "TextStyle"))
  (princ "\rÖlçülendirmek istediğiniz PoLyLine'ı seçiniz: ")
  (while (not (setq pLL (ssget ":s" (list (cons 0 "LWPOLYLINE"))))))
  (setq pLL (ssname pLL 0) cRd (vlax-safearray->list (vlax-variant-value
              (vlax-get-property (vlax-ename->vla-object pLL) 'Coordinates))))
  (if (= (cdr (assoc 70 (entget pLL))) 1)
    (setq cRd (append (append cRd (nth 0 cRd)) (nth 1 cRd))))
  (setq n (- (length cRd) 2))
  (while (not (minusp (setq n (- n 2))))
    (setq n1 (list (nth n cRd) (nth (1+ n) cRd))
          n2 (list (nth (+ n 2) cRd) (nth (+ n 3) cRd))
          bn (mapcar '(lambda (p1 p2) (/ (+ p1 p2) 2.0)) n1 n2)
          ac (angle n1 n2)) (while (>= ac pi) (setq ac (- ac pi)))
    (if (> ac (/ pi 2.0))
      (setq bn (polar bn (- ac (/ pi 2.0)) ds) ac (+ ac pi))
      (setq bn (polar bn (+ ac (/ pi 2.0)) ds)))
    (setq ms (rtos (* Luf (distance n1 n2)) 2 dp) L (+ L (atof ms)))
    (entmake (list (cons 0 "TEXT") (cons 7 sTy) (cons 10 bn) (cons 40 tx)
                   (cons 1 ms) (cons 50 ac) (cons 72 1) (cons 11 bn))))
  (setq L (strcat "L=" (rtos L 2 dp)))
  (entmake (list (cons 0 "TEXT") (cons 7 sTy) '(10 0.0 0.0 0.0)(cons 40 tx)
                 (cons 1 L) (cons 50 0.0) (cons 72 1) '( 11 0.0 0.0 0.0)))
  (princ "\rToplam Boy için yer seçiniz: ") (setq n1 (list 0.0 0.0 0.0))
  (while (and (/= 3 (car (setq n2 (grread T 4 3)))) (/= (car n2) 25))
    (vla-transformby (vlax-ename->vla-object (entlast))
      (vlax-tmatrix (list (list 1 0 0 (- (car (cadr n2)) (car n1)))
                          (list 0 1 0 (- (cadr (cadr n2)) (cadr n1)))
                          (list 0 0 1 (- (caddr (cadr n2)) (caddr n1)))
                          (list 0 0 0 1)))) (setq n1 (cadr n2)))
  (if (= (car n2) 25) (entdel (entlast)))
  (setq Lufo Luf dpo dp) (command "undo" "e") (prin1))

;|===========================================================================|;
;| Mevcut ölçüden seçilen tarafa doğru dimdli x dimscale kadar mesafede      |;
;| bir nokta belirler. Ölçü araliklarinin düzenli olması sağlanır.           |;
;| (ndy) yazılarak çalıştırılır.                                             |;
;|---------------------------------------------------------------------------|;
(defun ndy (/ om rdim aci p1 p2 p3 p4 p5)
  (setq om (* (getvar "dimscale") (getvar "dimdli")))
  (princ "\nSelect Reference dimension.....")
  (setq rdim (entget (ssname (ssget ":s" (list (cons 0 "Dimension,Line"))) 0)))
  (if (= (cdr (assoc 0 rdim)) "LINE")
    (setq aci (angle (cdr (assoc 10 rdim)) (cdr (assoc 11 rdim))))
    (if (= (- (cdr (assoc 70 rdim)) 32) 0) (setq aci (cdr (assoc 50 rdim)))
      (if (= (- (cdr (assoc 70 rdim)) 32) 1)
        (setq aci (angle (cdr (assoc 13 rdim)) (cdr (assoc 14 rdim)))))))
  (setq p1 (cdr (assoc 10 rdim)) p2 (polar p1 aci 1)
        p3 (getpoint "\nPick point at new dimesion side")
        p4 (polar p3 (+ aci (/ pi 2)) 1) p5 (inters p1 p2 p3 p4 nil)
        rpnt (polar p5 (angle p5 p3) om)))

;;;=========================================================================;;;
;;; DimInT: Plan benzeri çizimlerde sürekli ölçü verme işlemini yapar       ;;;
;;;         Hazırlayan: M. Ş. Güvercin  www.autocadokulu.com  06.10.2011    ;;;
;;;=========================================================================;;;
(defun C:DimInT (/ n1 n2 n3 n4 n5 n6 ang oLcob nLyr L m onsec nks noks dims)
  (setvar "cmdecho" 0) (vl-load-com) (command "undo" "group")
  (setq n1 (getpoint "\n                 Başlangıç Noktası...")
        n2 (getpoint n1 "\n                     Bitiş Noktası...")
        ang (angle n1 n2) n3 (polar n1 (+ ang (/ pi 2.0)) 1) oLcob (ssadd))
  (while (setq nLyr (car (entsel "\nLayer belirlemek için obje seçiniz...")))
    (setq onsec (ssget "C" n1 n2 (list (cons 0 "*LINE,ARC,ELLIPSE,CIRCLE")
              (cons 8 (cdr (assoc 8 (entget nLyr)))))) L (sslength onsec) m -1)
    (while (< (setq m (1+ m)) L) (if (ssmemb (ssname onsec m) oLcob)
        (progn (ssdel (ssname onsec m) oLcob) (redraw (ssname onsec m) 4))
        (progn (ssadd (ssname onsec m) oLcob) (redraw (ssname onsec m) 3)))))
  (if (= (sslength oLcob) 0) (progn (princ "\n**** Obje seçilmedi!") (exit)))
  (entmake (list (cons 0 "LINE") (cons 10 n1) (cons 11 n2)))
  (setq L (sslength oLcob) m -1)
  (while (< (setq m (1+ m)) L) (redraw (ssname oLcob m) 4))
  (setq L (sslength oLcob) m -1 nks nil)
  (while (< (setq m (1+ m)) L) (setq nks (append nks (vlax-safearray->list
             (vlax-variant-value (vla-intersectwith (vlax-ename->vla-object
                   (entlast)) (vlax-ename->vla-object (ssname oLcob m)) 0))))))
  (entdel (entlast)) (setq L (length nks) m -3 noks nil)
  (while (< (setq m (+ m 3)) L) (setq noks (cons
                 (list (nth m nks) (nth (+ m 1) nks) (nth (+ m 2) nks)) noks)))
  (setq L (length noks) m -1 nks nil)
  (while (< (setq m (1+ m)) L)
    (setq nks (cons (distance n1 (nth m noks)) nks)))
  (setq L (length nks) m -1)
  (while (< (setq m (1+ m)) L)
    (setq nks (append (vl-remove (setq tmp (nth m nks)) nks) (list tmp))
          L (length nks)))
  (setq noks (vl-sort nks '<) dims (ssadd) L (length noks) m -1)
  (if (< L 2) (progn (princ "\n**** Ölçü için en az 2 nokta gerekir!") (exit)))
  (while (< (setq m (1+ m)) (1- L))
    (entmake (list (cons 0 "DIMENSION") (cons 100 "AcDbEntity") (cons 67 0)
        (cons 100 "AcDbDimension") (cons 10 n1) (cons 70 32)
        (cons 100 "AcDbAlignedDimension") (cons 13 (polar n1 ang (nth m noks)))
        (cons 14 (polar n1 ang (nth (1+ m) noks))) (cons 50 ang)
        (cons 100 "AcDbRotatedDimension"))) (setq dims (ssadd (entlast) dims)))
  (setq L (sslength dims)) (princ "\n     Ölçülerin yerini belirleyiniz...")
  (while (/= 3 (car (setq n4 (grread T 4 0)))) (setq n4 (cadr n4)
            n5 (polar n4 (+ ang pi) 1) n6 (inters n1 n3 n4 n5 nil) m -1)
    (while (< (setq m (1+ m)) L) (setq pvt (entget (ssname dims m))
                                  pvt (subst (cons 10 n6) (assoc 10 pvt) pvt))
      (entmod pvt) (entupd (cdr (assoc -1 pvt))))) (command "undo" "e") (prin1)
) (princ "\nHazırlayan: M. Şahin Güvercin - www.autocadokulu.com")(princ)


;|===========================================================================|;
;| DIMHOR: Horizontal Dimension                                              |;
;| Horizontal (yatay) doğrultuda seri ve kolay ölçülendirme.                 |;
;| Ölçülendirmek için seçilen obje Line veya Polyline ise seçerken tıklanan  |;
;| noktaya en yakın çizgi ucu veya Polyline vertext noktası, seçilen obje    |;
;| bLock ise Insertion Point, Circle ise Center Point alınıp ölçülendirilir. |;
;| Ölçülerin yeri ve Referans noktalarının yeri belirlenirken, Enter girilip |;
;| Referans Obje seçilebilir.                                                |;
;|---------------------------------------------------------------------------|;
(defun C:DIMHOR (/ onk rfn rd n2 e nn nks n vn n0 n1)
  (ssv) (vl-load-com)
  (if (not (setq onk (getpoint "\nÖlçülerin yeri: "))) (setq onok (ndy)))
  (if (not (setq rfn (getpoint "\rReferans noktalarının yeri: ")))
    (progn (princ "\rReferans Ölçüsünü seçiniz: ")
      (while (not (setq rd (ssget ":s" (list (cons 0 "DIMENSION"))))))
      (setq rfn (cdr (assoc 14 (entget (ssname rd 0)))))))
  (setq onk (cadr onk) rfn (cadr rfn) n2 nil)
  (while (setq e (entsel "\rNokta için Obje seçiniz.... :"))
    (setq nn (cadr e) e (car e) dst 1.0E+16)
    (cond ((= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
           (setq nks (vlax-safearray->list (vlax-variant-value
                  (vlax-get-property (vlax-ename->vla-object e) 'Coordinates)))
                 n (length nks))
           (while (not (minusp (setq n (- n 2))))
             (setq vn (list (nth n nks) (nth (1+ n) nks)))
             (if (< (distance nn vn) dst)
               (setq n0 (car vn) dst (distance nn vn)))))
          ((= (cdr (assoc 0 (entget e))) "LINE")
             (if (< (distance (cdr (assoc 10 (entget e))) nn)
                    (distance (cdr (assoc 11 (entget e))) nn))
               (setq n0 (cadr (assoc 10 (entget e))))
               (setq n0 (cadr (assoc 11 (entget e))))))
           ((or (= (cdr (assoc 0 (entget e))) "INSERT")
                (= (cdr (assoc 0 (entget e))) "CIRCLE"))
             (setq n0 (cadr (assoc 10 (entget e))))))
     (setq n1 (list n0 rfn (getvar "Elevation"))
           n0 (list n0 onk (getvar "Elevation")))
     (if n2 (entmake (list (cons 0 "DIMENSION") (cons 100 "AcDbEntity")
             (cons 67 0) (cons 100 "AcDbDimension") (cons 10 n0) (cons 70 32)
             (cons 100 "AcDbAlignedDimension") (cons 13 n2) (cons 14 n1)
             (cons 50 (angle n2 n1)) (cons 100 "AcDbRotatedDimension"))))
    (setq n2 n1)) (rsv))

;|===========================================================================|;
;| DIMVER: Vertical Dimension                                                |;
;| Düşey (vertical) doğrultuda seri ve kolay ölçülendirme.                   |;
;| Ölçülendirmek için seçilen obje Line veya Polyline ise seçerken tıklanan  |;
;| noktaya en yakın çizgi ucu veya Polyline vertext noktası, seçilen obje    |;
;| bLock ise Insertion Point, Circle ise Center Point alınıp ölçülendirilir. |;
;| Ölçülerin yeri ve Referans noktalarının yeri belirlenirken, Enter girilip |;
;| Referans Obje seçilebilir.                                                |;
;|---------------------------------------------------------------------------|;
(defun C:DIMVER (/ onk rfn rd n2 e nn nks n vn n0 n1)
  (ssv) (vl-load-com)
  (if (not (setq onk (getpoint "\nÖlçülerin yeri: "))) (setq onok (ndy)))
  (if (not (setq rfn (getpoint "\rReferans noktalarının yeri: ")))
    (progn (princ "\rReferans Ölçüsünü seçiniz: ")
      (while (not (setq rd (ssget ":s" (list (cons 0 "DIMENSION"))))))
      (setq rfn (cdr (assoc 14 (entget (ssname rd 0)))))))
  (setq onk (car onk) rfn (car rfn) n2 nil)
  (while (setq e (entsel "\rNokta için Obje seçiniz.... :"))
    (setq nn (cadr e) e (car e) dst 1.0E+16)
    (cond ((= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
           (setq nks (vlax-safearray->list (vlax-variant-value
                  (vlax-get-property (vlax-ename->vla-object e) 'Coordinates)))
                 n (length nks))
           (while (not (minusp (setq n (- n 2))))
             (setq vn (list (nth n nks) (nth (1+ n) nks)))
             (if (< (distance nn vn) dst)
               (setq n0 (cadr vn) dst (distance nn vn)))))
          ((= (cdr (assoc 0 (entget e))) "LINE")
             (if (< (distance (cdr (assoc 10 (entget e))) nn)
                    (distance (cdr (assoc 11 (entget e))) nn))
               (setq n0 (caddr (assoc 10 (entget e))))
               (setq n0 (caddr (assoc 11 (entget e))))))
           ((or (= (cdr (assoc 0 (entget e))) "INSERT")
                (= (cdr (assoc 0 (entget e))) "CIRCLE"))
             (setq n0 (caddr (assoc 10 (entget e))))))
     (setq n1 (list rfn n0 (getvar "Elevation"))
           n0 (list onk n0 (getvar "Elevation")))
     (if n2 (entmake (list (cons 0 "DIMENSION") (cons 100 "AcDbEntity")
             (cons 67 0) (cons 100 "AcDbDimension") (cons 10 n0) (cons 70 32)
             (cons 100 "AcDbAlignedDimension") (cons 13 n2) (cons 14 n1)
             (cons 50 (angle n2 n1)) (cons 100 "AcDbRotatedDimension"))))
    (setq n2 n1)) (rsv))

;|===========================================================================|;
;| DIMYER: Dimension Yeri                                                    |;
;| Seçilen Dimension Objelerini Aynı yere getirip sürekliliklerini sağlar.   |;
;|---------------------------------------------------------------------------|;
(defun C:DIMYER (/ ydd n1 L n rd)
  (ssv) (princ "\nYeri Değiştirilecek ölçüleri seçiniz ")
  (setq ydd (ssget (list (cons 0 "DIMENSION")))
        n1 (getpoint "\nYeni yer... ")
        n (sslength ydd)) (if (not n1) (setq n1 (ndy)))
  (while (not (minusp (setq n (1- n))))
    (setq rd (entget (ssname ydd n))
          rd (subst (cons 10 n1) (assoc 10 rd) rd) rd (entmod rd)
          rd (entupd (cdr (assoc -1 rd))))) (rsv))

;|===========================================================================|;
;| DIMHIZ: Dimension Hizalama                                                |;
;| Seçilen Dimension'ların definition point'lerini seçilen noktaya hizalar.  |;
;|---------------------------------------------------------------------------|;
(defun C:DIMHIZ (/ ydd n n0 rd n1 n2 rd70 a1 a2 n3 n4 n5 nn1 nn2)
  (ssv) (princ "\nDefinition Point'leri düzenlenecek ölçüleri seçiniz ")
  (setq ydd (ssget (list (cons 0 "DIMENSION"))) n (sslength ydd))
  (initget 1) (setq n0 (getpoint "\nDefinition Point için yeni yer..."))
  (while (not (minusp (setq n (1- n))))
    (setq rd (entget (ssname ydd n)) a2 nil
          n1 (cdr (assoc 13 rd)) n2 (cdr (assoc 14 rd))
          n0 (list (car n0) (cadr n0) (caddr n1))
          n2 (list (car n2) (cadr n2) (caddr n1)) rd70 (cdr (assoc 70 rd)))
    (while (>= rd70 32) (setq rd70 (- rd70 32)))
    (cond ((= rd70 0) (setq a1 (cdr (assoc 50 rd)) a2 (+ a1 (/ pi 2))))
          ((= rd70 1) (setq a1 (angle n1 n2) a2 (+ a1 (/ pi 2)))))
    (if a2 (setq n3 (polar n1 a2 1) n4 (polar n2 a2 1) n5 (polar n0 a1 1)
                 nn1 (inters n1 n3 n0 n5 nil) nn2 (inters n2 n4 n0 n5 nil)
                 rd (subst (cons 13 nn1) (assoc 13 rd) rd)
                 rd (subst (cons 14 nn2) (assoc 14 rd) rd) rd (entmod rd)
                 rd (entupd (cdr (assoc -1 rd)))))) (rsv))

;|===========================================================================|;
;| CLP: CLip Line                                                            |;
;| Seçilen doğrunun her iki ucundan belirlenen miktar kadar kırpar. Kırpma   |;
;| miktarı negatif olabilir, bu durumda doğru belirlenen miktar kadar        |;
;| her iki ucundan uzatılır                                                  |;
;|---------------------------------------------------------------------------|;
(defun C:CLP (/ km e n1 n2 aci)
   (ssv) (if (= ekm nil) (setq ekm 5))
   (if (not (setq km (getreal (strcat "\nKirpma miktarı <" (rtos ekm) ">:"))))
     (setq km ekm)) (setq e (car (entsel "\nKırpılacak doğruyu seçiniz...")))
   (while e (setq e (entget e) n1 (cdr (assoc 10 e)) n2 (cdr (assoc 11 e))
                  aci (angle n1 n2)
                  n1 (polar n1 aci km) n2 (polar n2 (+ pi aci) km)
                  e (subst (cons 10 n1) (assoc 10 e) e)
                  e (subst (cons 11 n2) (assoc 11 e) e)
                  e (entmod e) e (entupd (cdr (assoc -1 e)))
                  e (car (entsel "\rYeni doğru seçiniz..."))))
  (setq ekm km) (rsv))

;|===========================================================================|;
;| DATE: Tarih                                                               |;
;| Belirlenen noktaya günün tarihini yazar.                                  |;
;|---------------------------------------------------------------------------|;
(defun C:DATE (/ Dt)
  (ssv) (setq Dt (rtos (getvar "cdate") 2 0)
          Dt (strcat (substr Dt 7 2) "/" (substr Dt 5 2) "/" (substr Dt 1 4)))
  (entmake (list (cons 0 "Text") (cons 10 (getpoint "\Yer seçiniz: "))
                 (cons 1 Dt) (cons 40 (getvar "TextSize")) (cons 50 0)
                 (cons 72 0))) (rsv))

;|===========================================================================|;
;| BRK: Break Single Point                                                   |;
;| Seçilen Objeyi belirlenen noktadan ikiye ayırır.                          |;
;|---------------------------------------------------------------------------|;
(defun C:BRK (/ e n) (ssv)
  (redraw (setq e (car (entsel))) 3) (command "break" e (setq n (getpoint)) n)
  (rerdaw e 1) (redraw entlast 1) (rsv))

;|---------------------------------------------------------------------------|;
(ssv) (setvar "modemacro" "M. Şahin Güvercin")
(princ "\n"MSG Lisp Functions" Loaded... Author: M. Şahin Guvercin\n") (rsv)
;|---------------------------------------------------------------------------|;

;|---------------------------------------------------------------------------|
| Seçilen Text Objeleri içinde belirlenen yüksekliteki Text'lerin           |
| yüksekliklerini, belirlenen farklı bir Yüksekliğine çevirir.              |
| Mevcut ve yeni yazı yükseklikleri nümerik olarak girilebileceği gibi,     |
| referans text objeleri seçilerek te belirlenebilir.                       |
|                 M. Şahin Güvercin - www.autocadokulu.com - 16.04.2012     |
|---------------------------------------------------------------------------|;
(write-line "\n M. Şahin Güvercin - www.autocadokulu.com")
(defun C:CHTXH (/ cHm p oTxH ToBj nTxH n e)
  (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com)
  (princ "\nSelect Text objects to be changed Height...")
  (setq  cHm 0 p (ssget (list (cons 0 "TEXT"))))
  (if (not (setq oTxH (getreal "\nOld Text Height <Enter to select Text>:")))
    (setq ToBj (ssname (ssget ":s" (list (cons 0 "TEXT"))) 0)
          oTxH (cdr (assoc 40 (entget ToBj)))))
  (if (not (setq nTxH (getreal "\nNew Text Height <Enter to Select Text>: ")))
    (setq ToBj (ssname (ssget ":s" (list (cons 0 "TEXT"))) 0)
          nTxH (cdr (assoc 40 (entget ToBj))))) (setq n (sslength p))
  (while (not (minusp (setq n (1- n))))
    (setq e (vlax-ename->vla-object (ssname p n)))
    (if (= oTxH (vlax-get-property e 'Height))
      (setq e (vlax-put-property e 'Height nTxH) chm (1+ cHm))))
  (princ (strcat "\n" (itoa cHm) " Text Object(s) Height Changed "))
  (command "undo" "e") (prin1)
)