_

zlecę napisanie LISPa

Forum poświęcone flagowemu produktowi oraz aplikacjom pochodnym Autodesku. To jedyne forum mające w tytule nazwę programu, a to ze względu na jego olbrzymią popularność w Polsce. Można tutaj umieszczać również posty z ogólnie pojętej tematyki "Kreślarskie 2D".

Re: zlecę napisanie LISPa

Postprzez ziele_o2k » maja 15, 2018 10:25

Na kolanie pisane, ale jakoś będzie działać.
Jak ktoś chce niech poprawia.

Kod: Zaznacz cały
(defun c:test1 ( / name lay_set)
  ;1) Audit
  (cd:SYS_UndoBegin)
  (vla-AuditInfo (cd:ACX_ADoc) :vlax-true)
  ;2) purge
  (vla-PurgeAll (cd:ACX_ADoc))
  ;4a) all color by layer
  (c:abl)
  ;4b) all lineweight by layer
  (C:alwbl)
  ;5) usunie typ linii 1, 2_14, 3_14, 4_14, 5_14 do zrobienia
  (vlax-for obj (vla-get-modelspace (cd:ACX_ADoc))
    (if
      (and
        (vlax-property-available-p obj 'linetype)
        (wcmatch (vla-get-linetype obj) "1,1_14,2_14,3_14,4_14,5_14")
      )
      (vla-delete obj)
    )
  )
  (setvar 'Clayer "0")
  (vlax-for lay (cd:ACX_Layers)
    (if
      (and
        (not (wcmatch (setq name (vla-get-name lay)) "*|*,0,Defpoints"))
        (wcmatch (vla-get-linetype lay) "1,1_14,2_14,3_14,4_14,5_14")
      )
      (progn
        (vla-put-lock lay :vlax-false)
        ;(vl-cmdf "_.-laydel" "_N" name "" "_Y")
        (foreach % (cd:SSX_Convert(ssget "_X" (list (cons 8 name))) 0)
          (entdel %)
        )
       
      )
    )
  )
  ;6) kolor white, 250 zmieni na kolor 0,0,0
  (vlax-for obj (cd:ACX_Layers)
    (if (= (vla-get-color obj) 250)
      (pz:settruecolor obj 0 0 0)
    )
  )
  ;7) grubość warstwy 0 ustawi na 0,18
  (cd:ACX_SetProp (tblobjname "layer" "0") '(("LineWeight" . 18)))
  ;8) ustawi ramki wstawionych obrazów, pdfów na wartość 2(_PDFFRAME,_IMAGEFRAME,)
  ;(setvar 'frame 2)
  (setvar 'PDFFRAME 2)
  (setvar 'IMAGEFRAME 2)
  ;3) overkill
  (vl-cmdf "_.-overkill" "_all" "" "_tolerance" 0.0001 "")
  ;9) i na koniec znowu _PURGE
  (vla-PurgeAll (cd:ACX_ADoc))
  (cd:SYS_UndoEnd)
  (princ)
)

(defun pz:settruecolor (@obj @r @g @b / _c)
  (setq _c
    (vlax-create-object
      (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))
    )
  )
  (vla-SetRGB _c @r @g @b)
  (vla-put-TrueColor @obj _c)
  (princ)
)

(defun C:abl ; = All to Color Bylayer
 
  (/ cb ent obj blk subent)

  (defun cb () ; = force Color(s) to Bylayer
    (setq obj (vlax-ename->vla-object ent))
    (vla-put-color obj 256); ByLayer
    (if (wcmatch (vla-get-ObjectName obj) "*Dimension,*Leader")
      (foreach prop '(DimensionLineColor ExtensionLineColor TextColor)
        ;; not all such entity types have all 3 properties, but all have at least one
        (if (vlax-property-available-p obj prop)
          (vlax-put obj prop 256); ByLayer
        ); if
      ); foreach
    ); if
  ); defun -- cb
;;  Top-level entities:
  (setq ent (entnext))
  (while ent
    (cb)
    (setq ent (entnext ent))
  ); while
;;  Nested entities in this drawing's Block definitions:
  (setq blk (tblnext "block" t))
  (while blk
    (if (= (logand 20 (cdr (assoc 70 blk))) 0); not an Xref [4] or Xref-dependent [16]
      (progn
        (setq ent (cdr (assoc -2 blk)))
        (while ent
          (cb)
          (setq ent (entnext ent))
        ); while
      ); progn
    ); if
    (setq blk (tblnext "block"))
  ); while
  (vla-Regen (cd:ACX_ADoc) 1)
  (princ)
); defun

(defun C:alwbl
 
  (/ cb ent obj blk subent)

  (defun clw () ; = force Color(s) to Bylayer
    (setq obj (vlax-ename->vla-object ent))
    (vla-put-lineweight obj -1); ByLayer
    (if (wcmatch (vla-get-ObjectName obj) "*Dimension,*Leader")
      (foreach prop '(DimensionLineWeight ExtensionLineWeight LeaderLineWeight)
        ;; not all such entity types have all 3 properties, but all have at least one
        (if (vlax-property-available-p obj prop)
          (vlax-put obj prop -1); ByLayer
        ); if
      ); foreach
    ); if
  ); defun -- cb
;;  Top-level entities:
  (setq ent (entnext))
  (while ent
    (clw)
    (setq ent (entnext ent))
  ); while
;;  Nested entities in this drawing's Block definitions:
  (setq blk (tblnext "block" t))
  (while blk
    (if (= (logand 20 (cdr (assoc 70 blk))) 0); not an Xref [4] or Xref-dependent [16]
      (progn
        (setq ent (cdr (assoc -2 blk)))
        (while ent
          (clw)
          (setq ent (entnext ent))
        ); while
      ); progn
    ); if
    (setq blk (tblnext "block"))
  ); while
  (vla-Regen (cd:ACX_ADoc) 1)
  (princ)
); defun
Ziele
Avatar użytkownika
ziele_o2k
 
Posty: 678
Dołączył(a): mar 18, 2014 11:33
Lokalizacja: Poznań

Poprzednia strona

Powrót do AutoCAD

Kto przegląda forum

Użytkownicy przeglądający ten dział: Brak zidentyfikowanych użytkowników