TUTORIAL | TIPS DAN TRIK

"Biasakan meng-copy Program LiSP tanpa menghapus nama penciptanya"

;n.pranyoto@gmail.com 060214 membuat lambang BREAKLINE DAN MELAKUKAN TRIM;
;------------------------------------------------
;------------------------------------------------
(defun C:BRKL (/ dtr #dwgscale old_cmd pt1
pt2 ang_rad pt_mid pt_mid1 pt_mid2
pt_mid_r pt_mid_l
)
(command "-linetype" "load" "dashdot" "acad.lin" "" "")

(defun dtr (angg)
(* pi (/ angg 180.0))
)
(setq #dwgscale (getint "\nMasukan skala gambar 1: "))
(setq old_cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "_UNDO" "_BE")

(initget 1)
(setq pt1 (getpoint "\nBreakline start point: "))
(initget 1)
(setq pt2 (getpoint pt1 "\nBreakline end point: "))

(setq pt1 (trans pt1 1 0)
pt2 (trans pt2 1 0)
)


(setq ang_rad (angle pt1 pt2))
(setq pt_mid (polar pt1 ang_rad (/ (distance pt1 pt2) 2)))
(setq
pt_mid1 (polar pt1
ang_rad
(- (/ (distance pt1 pt2) 2) (* 0.001 #dwgscale))
)
)
(setq
pt_mid2 (polar pt1
ang_rad
(+ (/ (distance pt1 pt2) 2) (* 0.001 #dwgscale))
)
)
(setq
pt_mid_r (polar pt_mid (- ang_rad (dtr 105)) (* 0.002 #dwgscale))
)
(setq
pt_mid_l (polar pt_mid (+ ang_rad (dtr 75)) (* 0.002 #dwgscale))
)


(setq elist
(list
'(0 . "LWPOLYLINE")
;(5 . "57")
'(100 . "AcDbEntity")
;(67 . 0)
; '(8 . "SIZE") ;_ ????
'(100 . "AcDbPolyline")
'(6 . "dashdot")
'(90 . 6) ;_ ?????????? ??????
;(70 . 0)
;(43 . 0.0)
;(38 . 0.0)
;(39 . 0.0)
(cons 10
(polar pt1 (- ang_rad (dtr 180)) (* 0.00197 #dwgscale))
)
;(40 . 0.0)
;(41 . 0.0)
;(42 . 0.0)
(cons 10 pt_mid1)
(cons 10 pt_mid_r)
(cons 10 pt_mid_l)
(cons 10 pt_mid2)
(cons 10 (polar pt2 ang_rad (* 0.00197 #dwgscale)))
;(40 . 0.0)
;(41 . 0.0)
;(42 . 0.0)
;(210 0.0 0.0 1.0) )
)
)

(entmake elist)
(command "_UNDO" "_E")


(if olderr
(setq *error* olderr)
)
(setvar "CMDECHO" old_cmd)
(command "trim" "last" "")
(princ "\nn.pranyoto@gmail.com")
(princ)
)

"Biasakan meng-copy Program LiSP tanpa menghapus nama penciptanya"

;n.pranyoto@gmail.com 060214 membuat lambang elevasi;
;elevation mark creator;
;------------------------------------------------
(defun C:elm (/)

(if (not (tblsearch "LAYER" "ELV_MARK"))
(progn
(entmake (list (cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 2 "ELV_MARK")
)
)
)
)

(if (not (tblsearch "STYLE" "ELV_MARK"))
(progn
(command "_.STYLE" "ELV_MARK" "romans.SHX" "0" "0.75" "0" "" "" "")
)
)
;set skala
(setq SkalaEL (getint "\nMasukan skala gambar: "))


;set datum
(setq datumpoint (getpoint "\nPilih posisi datum: "))
(setq stdatumelev (getstring "\nMasukan Elevasi datum: "))
(setq datumelev (atof stdatumelev))


;bikin garis
(while
(setq pt1 (getpoint "\nstart point: "))
(Setq Tgrs (* SkalaEL 0.002))
(Setq Pgrs (* SkalaEL 0.015))
(setq width1 (* SkalaEL 0.003))

(setq pt2 (LIST (CAR pt1) (+ (CAdR pt1) Tgrs) 0))

(setq pt3 (LIST (+ (CAR pt1) Pgrs) (+ (CAdR pt1) Tgrs) 0))


(setq splvl (list
(cons 0 "LWPOLYLINE")
(cons 8 "ELV_MARK")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 3)
(cons 10 PT1)
(cons 40 0.0)
(cons 41 width1)
(cons 10 PT2)
(cons 40 0.0)
(cons 41 0.0)
(cons 10 PT3)
(cons 40 0.0)
(cons 41 0.0)
)
)

(entmake splvl)

;bikin text
(defun Alpha2Number (Str$ / Num#)
(if (= 0 (setq Num# (strlen Str$)))
0
(+ (* (- (ascii (strcase (substr Str$ 1 1))) 64)
(expt 26 (1- Num#))
)
(Alpha2Number (substr Str$ 2))
) ;+
) ;if
)
(Setq XTptx (* SkalaEL 0.0025))
(Setq YTptx (* SkalaEL 0.015))
(Setq HTptx (* SkalaEL 0.0018))
(setq datumel (- datumelev (CAdR datumpoint)))
(setq postext10 (LIST (+ (CAR pt1) YTptx) (+ (CAdR pt1) XTptx) 0))
(setq postext11 (LIST (CAR pt1) (+ (CAdR pt1) YTptx) 0))
(setq elvtext2 (rtos (+ (CAdR pt1) datumel) 2 3))
(setq elvtextnum (Alpha2Number elvtext2))
(setq elvtext
(cond
((= elvtextnum -7639232) (strcat "EL. %%p" elvtext2))
((and (< elvtextnum -7639231)(> elvtextnum -233385375)) (strcat "EL. " elvtext2))
((> elvtextnum -233385376) (strcat "EL. +" elvtext2))
)
)
(setq TXELV
(entmake
(mapcar 'cons
(list 0 7 8 10 11 40 41 72 73 1)
(list "Text" "ELV_MARK" "ELV_MARK" postext11
postext10 HTptx 0.8 2
0 elvtext
)
)
)
)
)

(entmake
(mapcar 'cons
(list 0 62)
(list "SEQEND" 256)
)
)
(princ "\nn.pranyoto@gmail.com")
(princ)

)

Dalam menggunakan Autocad, kita tidak terpisahkan dengan layer.
akan tetapi membuat layer baru secara manual sangat membosankan dan memakan waktu..
untuk itulah saya menulis Lisp atau lsp untuk membuat layer baru.

"Biasakan meng-copy Program LiSP tanpa menghapus nama penciptanya"

LiSP Untuk membuat Layer baru

;n.pranyoto@gmail.com 280114 membuat layer baru;
;------------------------------------------------
(defun c:nl ()
(vl-load-com)
  (setq layername (getstring T "\nMasukan nama layer baru: "))
  (setq layercolorp
(getstring "\nMasukan warna layer baru: <7>")
 )
 (setq layercolor
(if
  (= layercolorp "") "7" layercolorp
)
 )
  (setq layerltypep
(getstring T "\nMasukan Ltype layer baru:
Continuous HIDDEN CENTER DASHDOT AND OTHER
<Continuous>"
)
  )
  (setq layerltype
(if
  (= layerltypep "") "Continuous" layerltypep
)
 )

  (if (not (tblsearch "LTYPE" layerltype))
; Check to see if linetype exsists
    (if (findfile "acad.lin")
      (command "-Linetype" "Load" layerltype "acad.lin" "")
; if linetype does found
      (setq layerltype "Continuous")
;if not set linetype to Continuous
    )
  )
  (setq layerLweightp
(getstring "\nMasukan Lweight layer baru
0.05 0.09 0.13 0.18 0.2 0.25
0.30 0.35 0.40 0.50 0.53 0.60
0.70 0.80 0.90 1.00 1.06
: <Default>")
 )
  (setq layerLweightitof (atof layerLweightp))
  (setq layerLweightx (* layerLweightitof 100))


  (setq layerLweight
(if
  (= layerLweightp "") -3 layerLweightx
)
 )
   (setq LayerName
       (vl-catch-all-apply
           'vla-add
           (list
               (vla-get-layers
                   (vla-get-activedocument
                       (vlax-get-acad-object)
                   )
               )
               Layername
           )
       )
   )
   (if (vl-catch-all-error-p LayerName)
       nil
       LayerName
   )
  (vla-put-color layername layercolor)
  (vla-put-linetype layername layerltype)
  (vla-put-LineWeight layername layerLweight)
  (vla-put-activelayer
    (vla-get-activedocument
      (vlax-get-acad-object)
    )
    LayerName
  )
(princ "\nn.pranyoto@gmail.com")
(princ)
)

Saya tidak membuat program LiSP di bawah ini. saya hanya meng-copy dari berbagai sumber.

untuk join semua polyline

(defun C:JJ ; = Polyline Join
  (/ *error* pjss cmde peac nextent pjinit inc edata pjent)

  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (setvar 'peditaccept peac)
    (command "_.undo" "_end")
    (setvar 'cmdecho cmde)
    (princ)
  ); defun - *error*

  (princ "\nTo join objects into Polyline(s) [pick 1 to join all possible to it],")
  (setq
    pjss (ssget '((0 . "LINE,ARC,*POLYLINE")))
    cmde (getvar 'cmdecho)
    peac (getvar 'peditaccept)
    nextent (entlast); starting point for checking new entities
  ); setq
  (repeat (setq pjinit (sslength pjss) inc pjinit); PJ INITial-selection quantity & incrementer
    (if
      (and
        (=
          (cdr (assoc 0 (setq edata (entget (setq pjent (ssname pjss (setq inc (1- inc))))))))
          "POLYLINE" ; 2D "heavy" or 3D Polyline
        ); =
        (or
          (= (cdr (assoc 100 (reverse edata))) "AcDb3dPolyline"); 3D
          (member (boole 1 6 (cdr (assoc 70 edata))) '(2 4)); splined or fitted 2D
        ); or
      ); and
      (ssdel pjent pjss); remove 3D, splined/fitted 2D from set
    ); if
  ); repeat
  (setvar 'cmdecho 0)
  (command "_.undo" "_begin")
  (setvar 'peditaccept 1)
  (setvar 'plinetype 2); [just in case; assumes no desire to save and set back if different]
  (if pjss ; selected qualifying object(s)
    (cond ; then
      ( (= pjinit (sslength pjss) 1); selected only one, and it qualifies
        (command "_.pedit" pjss "_join" "_all" "" ""); join everything possible to it
      ); single-selection condition
      ( (> (sslength pjss) 1); more than one qualifying object
        (command "_.pedit" "_multiple" pjss "" "_join" "0.0" "")
      ); multiple qualifying condition
      ((prompt "\nSingle object not viable, or <= 1 of multiple selection viable."))
    ); cond
    (prompt "\nNothing viable selected.")
  ); outer if
  (while (setq nextent (entnext nextent)); start with first newly-created Pline, if any
    (if ; revert any un-joined Lines/Arcs back from Pline conversion
      (and ; newly-created single-segment Pline from unconnected Line/Arc
        (= (cdr (assoc 90 (entget nextent))) 2)
        (not (vlax-curve-isClosed nextent))
      ); and
      (command "_.explode" nextent)
    ); if
  ); while
  (setvar 'peditaccept peac)
  (command "_.undo" "_end")
  (setvar 'cmdecho cmde)
  (princ)
)

untuk menambahkan prefix (huruf atau angka di depan huuruf lain) sufix (huruf atau angka di belakang huuruf lain)

(defun C:TextPS (/ intCount objSelection strPrefix strSuffix ssSelections)
(princ "\nSelect text and mtext: ")
(setq ssSelections (ssget (list (cons 0 "TEXT,MTEXT")))
strPrefix (getstring "\nEnter Prefix: " 't)
strSuffix (getstring "\nEnter Suffix: " 't)
)
(repeat (setq intCount (sslength ssSelections))
(setq intCount (1- intCount)
objSelection (vlax-ename->vla-object
(ssname ssSelections intCount)
)
)
(vla-put-textstring objSelection
(strcat
strPrefix
(vla-get-textstring objSelection)
strSuffix
)
)
)
(prin1)
)