標注時自動切換到DIM圖層

[code=lisp](defun xlr-autolayer ()

;??(setvar "cmdecho" 0)

;??(if (null (tblsearch "layer" "text"))

;? ? (set_layer_list "text" 3 "continuous")

;??)

;??(if (null (tblsearch "layer" "dim"))

;? ? (set_layer_list "dim" 3 "continuous")

;??)

(vl-load-com)

;; 圖層初始化列表 內容：commands layers color linetype plottable

(setq *doc (vla-get-activedocument (vlax-get-acad-object)))

(setq *lays (vla-get-layers *doc))

(setq? ? ? ? *laylst

(list (list "DIMANGULAR" "DIM" 3 "continuous" T)

(list "DIMALIGNED" "DIM" 3 "continuous" T)

(list "DIMBASELINE" "DIM" 3 "continuous" T)

(list "DIMCENTER" "DIM" 3 "continuous" T)

(list "DIMCONTINUE" "DIM" 3 "continuous" T)

(list "DIMDIAMETER" "DIM" 3 "continuous" T)

(list "DIMLINEAR" "DIM" 3 "continuous" T)

(list "DIMORDINATE" "DIM" 3 "continuous" T)

(list "DIMRADIUS" "DIM" 3 "continuous" T)

(list "QDIM" "DIM" 3 "continuous" T)

(list "QLEADER" "DIM" 3 "continuous" T)

(list "DTEXT" "TEXT" 3 "continuous" T)

(list "MTEXT" "TEXT" 3 "continuous" T)

(list "TEXT" "TEXT" 3 "continuous" T)

;(list "BHATCH" "填充" 9 "continuous" T)

;(list "HATCH" "填充" 9 "continuous" T)

;(list "POINT" "點" 4 "continuous" T)

;(list "XLINE" "輔助線" 8 "continuous" T)

;(list "LINE" "0" NIL "continuous" T)

;(list "XREF" "引用" 7 "continuous" T)

;(list "pline" "多義線" 2 "center" T)

)

)

(setq OldLayer nil)

(setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))

(mapcar '(lambda (x) (vlr-command-reactor nil x))

(list? ? ? ? '((:vlr-commandWillStart . xlr-start))

'((:vlr-commandEnded . xlr-end))

'((:vlr-commandCancelled . xlr-cancel))

)

)

(vlr-editor-reactor

nil

'((:vlr-commandwillstart . xlr-edit))

)

)

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

(defun xlr-edit? ? ? ? (CALL CALLBACK /)

(foreach N *laylst

(if? ? ? ? (= (strcase (car CALLBACK)) (strcase (car N)))

; 命令反應器返回信息如果與設置的命令相同.

(progn? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ;建立圖層

(apply 'xsetlays (cdr N))

;(setvar "CLAYER" (cadr N));設為當前層.

)

)

)

)

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

(defun xlr-start (calling-reactor xlr-startInfo /)

(foreach N *laylst

(if? ? ? ? (= (strcase (car xlr-startInfo)) (strcase (car N)))

; 命令反應器返回信息如果與設置的命令相同.

(progn? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ;建立圖層

(apply 'xsetlays (cdr N))

;(setvar "CLAYER" (cadr N));設為當前層.

)

)

)

)

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

(defun xlr-end (calling-reactor xlr-endInfo / cmd)

(setq cmd (car xlr-endInfo))

(if (member cmd *cmdlst)

(if (/= oldlayer nil)

(progn

(setvar "CLAYER" OldLayer)

(setq OldLayer nil)

)

)

)

)

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

(defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd)

(setq cmd (car xlr-cancelInfo))

(if (member cmd *cmdlst)

(if (/= oldlayer nil)

(progn

(setvar "CLAYER" OldLayer)

(setq OldLayer nil)

)

)

)

)

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

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

(defun xsetlays? ? ? ? (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ)

(if (tblobjname "layer" LAY-NAM)

(progn

(if (/= (strcase (getvar "CLAYER"))

(strcase LAY-NAM)

)

(setq OldLayer (getvar "CLAYER"))

(progn

(if (= oldlayer nil)

(setq OldLayer LAY-NAM)

)

)

)

(setvar "CLAYER" lay-nam)

)

(progn? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ;添加圖層.

(vl-catch-all-error-p

(vl-catch-all-apply 'vla-add (list *lays LAY-NAM))

)

(setq LAYOBJ (vla-item *lays LAY-NAM))

(if (not (tblobjname "ltype" LTYPE)) ;添加線型.

(progn

(setq LTYPESOBJ (vla-get-linetypes *doc))

(vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))

;>>>　要加強，在多個*.lin尋找

(vlax-release-object LTYPESOBJ)

)

)? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ;解凍(如凍結)，解鎖,設圖層為當前,設圖層顏色，可打印特性.

(vla-put-layeron layobj :vlax-true)

(vla-put-lock layobj :vlax-false)

(if (= (strcase (getvar "CLAYER")) (strcase lay-nam)) ;解凍.

(vla-put-freeze layobj :vlax-false)

)

(vla-put-color layobj color)

(vla-put-linetype layobj LTYPE)

(vla-put-plottable

layobj

(if plotk

:vlax-true

:vlax-false

)

)

)

)

)

(xlr-autolayer)? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ;加載啟動!

(princ "\n ----命令圖層反應器已加載----")

[/code]

總結

以上是生活随笔為你收集整理的lisp调用qleader端点_标注时自动切换到DIM图层 lisp程序的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。