【base1.1】創(chuàng)建常用常數

?? (defun __PRD@INITCONST__()
? ? ? (vl-load-com)
? ? ? (setq *En2Obj* vlax-ename->vla-object
? ? ? ? ? ? ?? *Obj2En* vlax-vla-object->ename
? ? ? ? ? ? ?? *ACAD* (vlax-get-acad-object)
? ? ? ? ? ? ?? *ADOC* (vla-get-ActiveDocument *ACAD*);關于跨文件操作lisp另考慮
? ? ? ? ? ? ?? *DOCS* (vla-get-Documents *ACAD*)
? ? ? ? ? ? ?? *ADMS* (vla-get-modelSpace *ADOC*);active doc's model space
? ? ? ? ? ? ?? *ADPS* (vla-get-paperSpace *ADOC*);active? doc's paper space
? ? ? ? ? ? ?? *ABLKS* (vla-get-Blocks *ADOC*);
? ? ? ? ? ? ?? *ALAYS* (vla-get-Layers *ADOC*)
? ? ? ? ? ? ?? *ADICS* (vla-getDictionaries *ADOC*)
? ? ? ? ? ? ?? *ALTPS* (vla-get-Linetypes *ADOC*)
? ? ? ? ? ? ?? *ATXTS* (vla-get-TextStyles *ADOC*)
? ? ? ? ? ? ?? *AGRPS* (vla-get-groups *ADOC*)
? ? ? ? ? ? ?? *ADIMS* (vla-get-DimStyles *ADOC*)
? ? ? ? ? ? ?? *LOUTS* (vla-get-Layouts *ADOC*)
? ? ? ? ? ? ?? *AVWPS* (vla-get-Viewports *ADOC*)
? ? ? ? ? ? ?? *AVIEW* (vla-get-Views *ADOC*)
? ? ? )
? ? ? (setq *PSHELL* (vlax-get-or-create-object "Shell.Application")
? ? ? ? ? ? ?? *REGEXP* (vlax-get-or-create-object "VBScript.RegExp")
? ? ? ? ? ? ?? *WSSHEL*(vlax-get-or-create-object "wscript.shell")
? ? ? ? ? ? ?? *SCPCON* (vlax-get-or-create-object "ScriptControl")
? ? ? ? ? ? ?? *WBEMSL* (vlax-get-or-create-object "WbemScripting.SWbemLocator")
?? );常用外部接口對象 考慮regexp的一類版本判斷

【base1.2】獲取任意對象句柄的所有屬性和方法

(defun VGET_OBJ_CONTENT(obj)
?? (if (= (type obj) 'VLA-OBJECT)
? ?? (if (not (vlax-object-released-p obj));待完善
? ? ?? (vlax-dump-object obj T)
? ? ?? "NaN"
? ?? )
? ?? "NaN"
?? )
)

【base1.3】安全獲取任意對象句柄的屬性

? (defun VGET_PTY_X(obj pty)
? ?? (if (= (type obj) 'VLA-OBJECT)
? ? ?? (if (vlax-property-available-p obj pty)
? ? ? ?? (vlax-get-property obj pty)
? ? ? ?? nil
? ? ?? )
? ? ?? nil
? ?? )?
? )

【base1.4】獲取集合成員的名稱列表

(defun VGET_OBJ_NAME(obj)
?? (if (vlax-property-available-p obj 'Name)
? ?? (vlax-get-property obj 'Name)
? ?? "NaN"
?? )
)??
(defun VGET_COL_ITEM_NAME(collection / out)
? ?? (vlax-for each collection
? ? ? ? (setq out (cons (VGET_OBJ_NAME each) out))
? ?? )
? ?? (reverse out)
)

【base1.4】獲取acad的preferences對象句柄

? (defun __PRD@ADOCPREF__()
? ?? (VGET_PTY_X *ACAD* 'Preferences)
? )

【base1.5】獲取指定的preferences的對象句柄

? (defun GETPREFKEY(tab key / prefs)
? ? ?(setq prefs (__PRD@ADOCPREF__))
? ?? (if perfs
? ? ?? (VGET_PTY_X prefs key)
? ? ?? nil
? ?? )
? )

【base1.6】設置preferences對象中的屬性

? (defun PUTPREFKEY(tab key val)
? ?? (setq prefi?(VGET_PTY_X (__PRD@ADOCPREF__) tab))
? ?? (if prefi
? ? ?? (if (vlax-property-available-p?
? ? ? ? ? ? ? prefi
? ? ? ? ? ? ? key
? ? ? ? ? ? ? T
? ? ? ? ?? )
? ? ? ?? (vlax-put-property prefi key val)
? ? ? ?? "NaN"
? ? ?? )
? ? ?? "NaN"
? ?? )
? )

【base1.7】返回詞典集合成員名稱列表

? (defun )

【base5.1】獲取對象XRECORD

? (defun GETXRECORD(obj name / e dicts xt xd lst _getxrecord)
? ?? (defun _getxrecord(dc / xt xd)
? ? ? ? (if (= (vla-get-objname dc) "AcDbXrecord")
? ? ? ? ? (progn (vla-getxrecorddata dc 'xt 'xd)
? ? ? ? ? ?? (if (and xt xd)
? ? ? ? ? ? ?? (setq lst?
? ? ? ? ? ? ? ? ? (cons?
? ? ? ? ? ? ? ? ? ?? (cons (vla-get-name dc)
? ? ? ? ? ? ? ? ? ? ? ? (mapcar '(lambda (x y) (cons x y))
? ? ? ? ? ? ? ? ? ? ? ? ?? (safearray-value xt)?
? ? ? ? ? ? ? ? ? ? ? ? ?? (mapcar 'variant-value (safearray-value xd))
? ? ? ? ? ? ? ? ? ? ? ? );<end/mapcar>
? ? ? ? ? ? ? ? ? ?? );<end/cons>
? ? ? ? ? ? ? ? ? ?? lst
? ? ? ? ? ? ? ? ? );<end/cons lst>
? ? ? ? ? ? ?? );<end/setq lst>
? ? ? ? ? ? ?? (setq lst (cons (vla-get-name dc) lst))
? ? ? ? ? ?? );<end/if xt xd>
? ? ? ? ? );<end/progn>
? ? ? ? );<end/if =>
? ?? );<end/defun _getxrecord>
? ?? (if (= (vla-get-objectname obj) "AcDbDictionary")
? ? ?? (vlax-for dict obj?
? ? ? ? ? (_getxrecord dict)
? ? ?? )
? ? ?? (if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
? ? ? ?? (progn (setq dicts (vla-getExtensionDictionary obj))
? ? ? ? ? ? (vlax-for dict dicts
? ? ? ? ? ? ?? (_getxrecord dict)
? ? ? ? ? ? )
? ? ? ?? )
? ? ?? )
? ?? )
? ?? (if (= name "*")
? ? ?? lst
? ? ?? (vl-remove-if-not?
? ? ? ? ? '(lambda(x) (= (strcase (car x)) (strcase name)))
? ? ? ? ? lst
? ? ?? )
? ?? )
? )

【base5.2】為對象貼附XRECORD

(defun PUTXRECORD(obj name values / _setxrecord xlst xrec dicts xd xt)
?? (defun _setxrecord(obj lst)
? ? ? (vla-setxrecorddata obj
? ? ? ?? (list->vbarray (mapcar 'car lst) vlax-vbinteger)
? ? ? ?? (list->vbarray (mapcar 'cdr lst) vlax-vbvariant)
? ? ? )
?? )
?? (if (= (vla-get-objectname obj) "AaDbDictionary")
? ?? (progn?
? ? ? ? (vlax-for d obj
? ? ? ? ?? (if (and (= (vla-get-objectname d) "AcDbXrecord")
? ? ? ? ? ? ? ? ? (= (strcase (vla-get-name d)) (strcase name))
? ? ? ? ? ? ?? )
? ? ? ? ? ?? (setq xrec d)
? ? ? ? ?? )
? ? ? ? )
? ? ? ? (if xrec
? ? ? ? ? (progn (vla-getxrecorddata xrec 'xt 'xd)
? ? ? ? ? ?? (if xt
? ? ? ? ? ? ?? (_setxrecord xrec?
? ? ? ? ? ? ? ? ? (append?
? ? ? ? ? ? ? ? ? ?? (mapcar '(lambda (x y) (cons x y))?
? ? ? ? ? ? ? ? ? ? ? ?? (safearray-value xt)
? ? ? ? ? ? ? ? ? ? ? ?? (mapcar 'variant-value (safearray-value xd))
? ? ? ? ? ? ? ? ? ?? )
? ? ? ? ? ? ? ? ? ?? values
? ? ? ? ? ? ? ? ? );<end/append>
? ? ? ? ? ? ?? );<end/_setxrecord>
? ? ? ? ? ? ?? (_setxrecord xrec values)
? ? ? ? ? ?? );<end/if xt>
? ? ? ? ? );<end/progn vla-getxrecord>
? ? ? ? ? (progn (setq xrec (vla-addxrecord obj name))
? ? ? ? ? ?? (_setxrecord xrec values)
? ? ? ? ? )
? ? ? ? );<end/if xrec>
? ?? );<end/progn>
? ?? (if (= (vla-get-hasExtensionDictionary obj) :vlax-true)
? ? ?? (progn
? ? ? ? ? (setq dicts (vla-GetExtensionDictionary obj))
? ? ? ? ? (vlax-for dict dicts
? ? ? ? ? ?? (if (and (= (vla-get-objname dict) "AcDbXrecord")
? ? ? ? ? ? ? ? ? ? (= (strcase (vla-get-name dict)) (strcase name))
? ? ? ? ? ? ? ?? )
? ? ? ? ? ? ?? (setq xrec dict)
? ? ? ? ? ?? )
? ? ? ? ? )
? ? ? ? ? (if xrec
? ? ? ? ? ? (progn (vla-getxrecorddata xrec 'xt 'xd)
? ? ? ? ? ? ?? (_setrecord xrec?
? ? ? ? ? ? ? ? ? (append?
? ? ? ? ? ? ? ? ? ?? (mapcar '(lambda (x y) (cons x y))
? ? ? ? ? ? ? ? ? ? ? ? (safearray-value xt)
? ? ? ? ? ? ? ? ? ? ? ? (mapcar 'variant-value (safearray-value xd))
? ? ? ? ? ? ? ? ? ?? )
? ? ? ? ? ? ? ? ? ?? values
? ? ? ? ? ? ? ? ? )
? ? ? ? ? ? ?? )
? ? ? ? ? ? )
? ? ? ? ? );<end/if xrec>
? ? ?? );<end/progn>
? ? ?? (progn?
? ? ? ? ? (setq dict (vla-getextensiondictionary obj)
? ? ? ? ? ?? xrec (vla-addrecord dict name)
? ? ? ? ? )
? ? ? ? ? (_setxrecord xrec values)
? ? ?? )
? ?? );<end/if hasextesiondict>
?? );<end/if = objname AcDbDict>
);<end/defun PUTXRECORD>

【base5.3】刪除對象的XRECORD （刪除對象是否徹底呢？）

(defun DELXRECORD(obj name /)
?? (if (= (vla-get-objname obj) "AcDbDictionary")
? ?? (vlax-for d obj
? ? ? ? (if (= (vla-get-objname d) "AcDbXrecord")
? ? ? ? ? ;(progn///////?有嗎
? ? ? ? ? ? ? (if (= name "*")
? ? ? ? ? ? ? ? (vla-delete d)
? ? ? ? ? ? ? )
? ? ? ? ? ? ? (if (= (strcase (vla-get-name d)) (strcase name))
? ? ? ? ? ? ? ? (vla-delete d)
? ? ? ? ? ? ? )
? ? ? ? ? ;)////////?有嗎
? ? ? ? )
? ?? )
? ?? (if (vla-get-hasexteinsiondictionary obj)
? ? ?? (vlax-for d (vla-getextensiondictionary obj)
? ? ? ? ? (if (= (vla-get-objectname d) "AcDbXrecord")
? ? ? ? ?? ;(progn////////?有嗎
? ? ? ? ? ? (if (= name "*")
? ? ? ? ? ? ? (vla-delete d)
? ? ? ? ? ? )
? ? ? ? ? ? (if (= (strcase (vla-get-name d)) (strcase name))
? ? ? ? ? ? ? (vla-delete d)
? ? ? ? ? ? )
? ? ? ? ?? ;)//////////有嗎
? ? ? ? ? )
? ? ?? )
? ?? )
?? )
)

【base5.4】替換對象的相同名稱的XRECORD

(defun REPLACEXRECORD(obj name vars / oldvars lst tf)
?? (if (setq lst (GETXRECORD obj name))
? ?? (progn
? ? ? ? (setq oldvars (mapcar 'car vars))
? ? ? ? (setq lst
? ? ? ? ?? (mapcar?
? ? ? ? ? ? ?? '(lambda (x / ll nx)
? ? ? ? ? ? ? ? ? (if (setq ll (vl-member-if '(lambda (a) (equal a x 1e-3)) oldvars))
? ? ? ? ? ? ? ? ? ? (progn
? ? ? ? ? ? ? ? ? ? ?? (setq nx (cons (car x) (cadr (assoc (car ll) vars))))
? ? ? ? ? ? ? ? ? ? ?? (setq tf T)
? ? ? ? ? ? ? ? ? ? ?? (setq vars (vl-remove (car ll) vars))
? ? ? ? ? ? ? ? ? ? ?? nx
? ? ? ? ? ? ? ? ? ? )
? ? ? ? ? ? ? ? ? ? x
? ? ? ? ? ? ? ? ? )
? ? ? ? ? ? ? ? )
? ? ? ? ? ? ? ? lst
? ? ? ? ?? )
? ? ? ? )
? ? ? ? (if tf?
? ? ? ? ? (SETXRECORD obj name lst)
? ? ? ? )
? ? ? ? T
? ?? )
?? )
)