autocadの autolispマクロの練習 - その2

Help Help

modelレイヤにある直径18の円を17へ変更。

更に付随する寸法線や、円の直情にある断面を表す破線も移動

(defun c:chgcircle ( / dwgdir files f fullpath )
  (princ "\nSTART CHGCIRCLE()")
  ; ActiveX のサポートに関連がある拡張 AutoLISP 関数を読込み
  (vl-load-com)

  (setq dwgdir "c:/Users/end0t/dev/AUTOLISP/DWG2")

  (setq files (vl-directory-files dwgdir "*.dwg" 1))
  (foreach f files
    (setq fullpath (strcat dwgdir "/" f))
    (change-circle-diameter fullpath)
  )

  (princ "\nDONE CHGCIRCLE()")
  (princ)
)

; modelレイヤにある直径18の円を17へ変更.
; 付随する寸法線も 17へ変更
; 円周上部のDASHED垂直線も中心方向へ0.5移動
(defun change-circle-diameter
       ( dwgpath
         / acad docs doc layouts lay blk obj dwgname
           diameter changed-count circle-centers )

  (vl-load-com)
  ; AutoCAD objectと dwg一覧 objectの取得
  (setq acad (vlax-get-acad-object))
  (setq docs (vla-get-Documents acad))

  (setq doc (vla-open docs dwgpath))
  (setq dwgname (vla-get-Name doc))
  (setq changed-count 0)
  (setq circle-centers nil)

  (princ (strcat "\n\nDWG: " dwgname))

  (setq layouts (vla-get-Layouts doc))

  (vlax-for lay layouts
    (if (= (vla-get-Name lay) "Model")
      (progn
        (princ (strcat "\n Layout: " (vla-get-Name lay)))
        (setq blk (vla-get-Block lay))

        (if blk
          (progn
            ; 直径18の円を探して変更し、中心座標を記録
            (vlax-for obj blk
              (if (= (vla-get-ObjectName obj) "AcDbCircle")
                (progn
                  (setq diameter (* 2.0 (vla-get-Radius obj)))
                  (if (< (abs (- diameter 18.0)) 0.001)
                    (progn
                      ; 中心座標を記録し、sizeを17へ変更
                      (setq circle-centers
                        (cons (vlax-get obj 'Center) circle-centers))
                      (vla-put-Radius obj 8.5)
                      (vla-Update obj)
                      (princ "\n    -> Changed to diameter=17")
                      (setq changed-count (1+ changed-count))
                    )
                  )
                )
              )
            )

            ; 円周上部のDASHED垂直線を移動
            (if circle-centers
              (move-dashed-lines-toward-center blk circle-centers 9.0 0.5)
            )
          )
        )
      )
    )
  )

  (princ (strcat "\n  Changed " (itoa changed-count) " circle(s)"))
  (if (> changed-count 0)
    (progn
      (update-dimension-text blk 18.0 "17")

      (vla-save doc)
      (princ "\n  Saved.")
    )
  )

  (vla-close doc :vlax-false)
)

; 円周上部のDASHED垂直線を中心方向へ移動
; blk: ブロック
; circle-centers: 円の中心座標リスト
; radius: 元の半径（円周上のY座標判定用）
; move-dist: 移動距離
(defun move-dashed-lines-toward-center
       ( blk circle-centers radius move-dist
         / obj center cx cy start-pt end-pt sx sy ex ey
           linetype-name is-vertical is-on-circle-top new-x )

  (vlax-for obj blk
    (if (= (vla-get-ObjectName obj) "AcDbLine")
      (progn
        ; 線種名を取得（DASHEDかどうか）
        (setq linetype-name (strcase (vla-get-Linetype obj)))

        (if (wcmatch linetype-name "*DASHED*")
          (progn
            (setq start-pt (vlax-get obj 'StartPoint))
            (setq end-pt (vlax-get obj 'EndPoint))
            (setq sx (car start-pt))
            (setq sy (cadr start-pt))
            (setq ex (car end-pt))
            (setq ey (cadr end-pt))

            ; 垂直線かどうか判定（X座標がほぼ同じ）
            (setq is-vertical (< (abs (- sx ex)) 0.001))

            (if is-vertical
              (progn
                ; 各円の中心に対してチェック
                (foreach center circle-centers
                  (setq cx (car center))
                  (setq cy (cadr center))

                  ; 円周上部にあるかどうか（Y座標が中心+半径付近）
                  (setq is-on-circle-top
                    (and
                      ; 線のX座標が円周上（中心からradius離れている）
                      (< (abs (- (abs (- sx cx)) radius)) 0.5)
                      ; 線のY座標が円の上部（中心より上）
                      (> sy cy)
                    )
                  )

                  (if is-on-circle-top
                    (progn
                      ; 中心方向へ移動（X座標を中心に近づける）
                      (if (> sx cx)
                        ; 線が中心より右にある場合、左へ移動
                        (setq new-x (- sx move-dist))
                        ; 線が中心より左にある場合、右へ移動
                        (setq new-x (+ sx move-dist))
                      )
                      (vla-put-StartPoint obj
                        (vlax-3d-point new-x sy (caddr start-pt)))
                      (vla-put-EndPoint obj
                        (vlax-3d-point new-x ey (caddr end-pt)))
                      (vla-Update obj)
                      (princ (strcat "\n    -> Moved DASHED line toward center by " (rtos move-dist 2 1)))
                    )
                  )
                )
              )
            )
          )
        )
      )
    )
  )
)

; 直径を変更しても、付随する寸法値が、なぜか変更されない為、強制的に置換
(defun update-dimension-text
       ( blk old-meas new-val-str
         / obj meas override new-override )

  (vlax-for obj blk
    (if (wcmatch (vla-get-ObjectName obj) "AcDb*Dimension*")
        (progn
        (setq meas (vla-get-Measurement obj))
        (if (< (abs (- meas old-meas)) 0.001)
          (progn
            (setq override (vla-get-TextOverride obj))
            (princ (strcat "\n  DIM: Measurement=" (rtos meas 2 3)
                           " TextOverride=" override))
            (if (/= override "")
              (progn
                (setq new-override
                  (vl-string-subst
                    (strcat "%%c" new-val-str)
                    "<>"
                    override))
                (vla-put-TextOverride obj new-override)
                (princ (strcat "\n    -> TextOverride=" new-override))
              )
              (progn
                (vla-put-TextOverride obj (strcat "%%c" new-val-str))
                (princ (strcat "\n    -> TextOverride=%%c" new-val-str))
              )
            )
          )
        )
      )
    )
  )
)