新作的一个工具箱菜单面板预览

newer · 发表于 2014-1-3 10:01:43

st788796 发表于 2014-1-3 09:32
其实用lsp组织是最切合lsp的，看看这个文章
http://m.baidu.com/from=2001a/bd_page_type=1/ssid=0/ui ...

xml数据交换最好

(vlax-create-object "MSXML.DOMDocument")
or
(vlax-create-object "MSXML2.DOMDocument.3.0")
or
(vlax-create-object "MSXML2.DOMDocument.4.0")

st788796 · 发表于 2014-1-3 10:05:43

本帖最后由 st788796 于 2014-1-3 10:07 编辑

控制不动，另写一个将xml转换为要求的lsp表即可，lsp其实读取最快
或者提供两种模式供用户选择自定义

newer · 发表于 2014-1-3 10:05:58

本帖最后由 newer 于 2014-1-3 10:09 编辑

XML-API ,可以把他们整理出来添加到XD LISP函数库里面。

;;;************************************************************************
;;; api-xml.lsp
;;; Prepared by: J. Szewczak
;;; Date: 4 January 2004
;;; Purpose: To provide an API for interfacing with XML files.
;;; Copyright (c) 2004 - AMSEC LLC - All rights reserved
;;;************************************************************************
;;; Version 2004.01.04
;;;************************************************************************
;;;***********************************************************************
;;; MODULE: api-error
;;; DESCRIPTION: wraps a function to trap Active-X errors - if error is found
;;; DESCRIPTION: function returns nil.
;;; ARGS: function to check, list of arguments, boolean (return error message?) T or nil
;;; EXAMPLE: (api-error '/ (list 50 0) T) displays "VLISP Error: divide by zero" & returns 'nil'
;;;***********************************************************************
(defun api-error (func lst bool / trap)
(cond
( (vl-catch-all-error-p
(setq trap (vl-catch-all-apply func lst))
)
(if bool (princ (strcat "\nVLISP XML Error: " (vl-catch-all-error-message trap))))
(setq trap nil)
)
)
trap
)
;;;************************************************************************
;;; MODULE: XML-Get-Document
;;; DESCRIPTION: queries an XML file for the DOM Active-X object
;;; ARGS: XML file (string); a variable to store the DOM object
;;; EXAMPLE:(XML-Get-Document projfile 'XMLDoc) returns vla-object
;;;************************************************************************
(defun XML-Get-Document (file XMLDoc)
(if (findfile file)
(progn
(set XMLDoc (vlax-create-object "MSXML2.DOMDocument.3.0")) ;;create XML-DOM pipeline
(vlax-put-property (eval XMLDoc) "async" :vlax-false)
(cond
( (api-error 'vlax-invoke-method (list (eval XMLDoc) "Load" file) T) ;; Load Project File into XML-DOM pipeline
(eval XMLDoc)
)
)
)
(alert "\nXML Document could not be found.")
)
)
;;;************************************************************************
;;; MODULE: XML-Get-XMLObject
;;; DESCRIPTION: this gets the top-level parent node object in a given XML Document
;;; ARGS: filename (string)
;;; EXAMPLE: (XML-Get-XMLObject filename) returns VLA-OBJECT
;;;************************************************************************
(defun XML-Get-XMLObject (file / docObj xmlTop xmlVer object)
(if (findfile file)
(progn
(setq docObj (XML-Get-Document file 'docObj)
xmlTop (vlax-get-property docObj "childNodes") ;; Get the Top Level of the XML
xmlVer (vlax-invoke-method xmlTop "nextNode") ;; Gets the XML version element
object (vlax-invoke-method xmlTop "nextNode") ;; Gets the Parent element
)
)
)
object
)
;;;************************************************************************
;;; MODULE: XML-Get-ElementKey
;;; DESCRIPTION: returns the requested tags text.
;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name
;;; EXAMPLE: (XML-Get-ElementKey laydef "Name") returns "ANNOTATION"
;;;************************************************************************
(defun XML-Get-ElementKey (parent tag / el desc)
(if (vlax-method-applicable-p parent 'getElementsByTagName)
(progn
(setq el (vlax-invoke-method parent 'getElementsByTagName tag))
(if (> (vlax-get-property el 'Length) 0)
(setq desc (vlax-get-property (vlax-invoke-method el 'nextNode) 'text))
)
(vlax-invoke-method el 'reset)
)
(princ "\nXML Object could not be searched.")
)
(if desc desc nil)
)
;;;************************************************************************
;;; MODULE: XML-Get-ElementKey-Object
;;; DESCRIPTION: returns the requested tags object.
;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name
;;; EXAMPLE: (XML-Get-ElementKey-Object laydef "Name") returns VLA-OBJECT
;;;************************************************************************
(defun XML-Get-ElementKey-Object (parent tag / el desc)
(if (vlax-method-applicable-p parent 'getElementsByTagName)
(progn
(setq el (vlax-invoke-method parent 'getElementsByTagName tag))
(if (> (vlax-get-property el 'Length) 0)
(setq desc (vlax-invoke-method el 'nextNode))
)
(vlax-invoke-method el 'reset)
)
(princ "\nXML Object could not be searched.")
)
(if desc desc nil)
)
;;;************************************************************************
;;; MODULE: XML-Get-Parent
;;; DESCRIPTION: Gets a top level object from the XML object with the given name
;;; ARGS: a valid XML object, the name of the parent level
;;; EXAMPLE: (XML-Get-Parent oXML "Leaders") returns VLA-OBJECT
;;;************************************************************************
(defun XML-Get-Parent (oXML name)
(vlax-invoke-method
(vlax-invoke-method oXML 'GetElementsByTagName name)
'peekNode
)
)
;;;************************************************************************
;;; MODULE: XML-Get-Children
;;; DESCRIPTION: gets the child object from a parent level
;;; ARGS: XML object, Parent name
;;; EXAMPLE: none
;;;************************************************************************
(defun XML-Get-Children (oXML parentName / return)
(cond
( (/= parentName nil)
(if (vlax-invoke-method (XML-Get-Parent oXML parentName) 'hasChildNodes)
(setq return (vlax-get-property (XML-Get-Parent oXML parentName) 'childNodes))
)
)
( T (if (vlax-invoke-method oXML 'hasChildNodes) (setq return (vlax-get-property oXML 'childNodes))))
)
return
)
;;;************************************************************************
;;; MODULE: XML-Get-ChildList
;;; DESCRIPTION: returns a list of all child objects under a parent XML Object
;;; ARGS: XML object
;;; EXAMPLE: (XML-Get-ChildList objXML) returns a list of VLA-Objects
;;;************************************************************************
(defun XML-Get-ChildList (oXML / collection child lst)
(cond
( (vlax-invoke-method oXML 'hasChildNodes)
(setq collection (XML-Get-Children oXML nil))
(while (setq child (vlax-invoke-method collection 'nextNode))
(setq lst (if lst (cons child lst) (list child)))
)
(reverse lst)
)
(princ "\nObject has no children")
)
)
;;;************************************************************************
;;; MODULE: XML-Get-Child
;;; DESCRIPTION: gets a specific child name under the parent level with given name
;;; ARGS: XML object, parent level, child name
;;; EXAMPLE: (setq oPointers (XML-Get-Child oXML "Leaders" "Pointers")) returns VLA-Object
;;; EXAMPLE: (XML-Get-Child oPointers nil "ArrowSize") used you only want to go one deep...
;;;************************************************************************
(defun XML-Get-Child (oXML parentName childName / child target)
(cond
( (/= parentName nil) (setq child (XML-get-Children oXML parentName)))
( T (setq child (vlax-get-property oXML 'childNodes)))
)
(setq target (api-error 'vlax-invoke-method (list child 'nextNode) T))
(while
(and
target
(/= (vlax-get-property target 'tagName) childName)
)
(setq target (api-error 'vlax-invoke-method (list child 'nextNode) T))
)
target
)
;;;************************************************************************
;;; MODULE: XML-Get-Child-ByAttribute
;;; DESCRIPTION: gets a specific child name under the parent level with given attribute and attribute value
;;; ARGS: XML object, parent level, attribute to search by, attribute value to match
;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayers "LayerDefinitions" "Name" "ANNOTATION") returns VLA-OBJECT
;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayerDefs nil "Name" "ANNOTATION") used when you only want to go one deep...
;;;************************************************************************
(defun XML-Get-Child-ByAttribute (oXML parentName attrib attribValue / parent rtn)
(if parentName
(setq parent (XML-Get-Child oXML nil parentName))
(setq parent oXML)
)
(foreach itm (XML-Get-ChildList parent)
(if (= (XML-Get-Attribute itm attrib "") attribValue)
(setq rtn itm)
)
)
rtn
)
;;;************************************************************************
;;; MODULE: XML-Get-Child-Value
;;; DESCRIPTION: Retrieves the value from the 'Text property of a child element
;;; ARGS: XML object, parent Name, Child Name
;;; EXAMPLE: (XML-Get-Child-Value oXML "TaskInfo" "FSCM") returns "4T323"
;;;************************************************************************
(defun XML-Get-Child-Value (oXML parentName childName)
(if (XML-Get-Child oXML parentName childName)
(vlax-get-property (XML-Get-Child oXML parentName childName) 'text)
nil
)
)
;;;************************************************************************
;;; MODULE: XML-Put-Child
;;; DESCRIPTION: updates the text in a given child node
;;; ARGS: XML object, parent node name, child node to change, value to change to
;;; EXAMPLE: (XML-Put-Child oXML "DrawingSetup" "DrawingMode" "MicroScale")
;;;************************************************************************
(defun XML-Put-Child (oXML parentName childName valu / child return)
(if
(and
valu
(setq valu (vl-princ-to-string valu))
(setq child (XML-Get-Child oXML parentName childName))
)
(api-error 'vlax-put-property (list child 'text valu) T)
)
)
;;;************************************************************************
;;; MODULE: XML-Remove-Child
;;; DESCRIPTION: removes the specified child object node
;;; ARGS: XML node object
;;; EXAMPLE: (XML-Remove-Child oXML)
;;;************************************************************************
(defun XML-Remove-Child (rmvChild / parent)
(setq parent (vlax-get-property rmvChild 'parentNode))
(api-error 'vlax-invoke-method (list parent 'removeChild rmvChild) T)
)
;;;************************************************************************
;;; MODULE: XML-Add-Child
;;; DESCRIPTION: adds a Child element to the given parent object
;;; ARGS: Parent Level VLA-Object, name of new child
;;; EXAMPLE: (XML-Add-Child oXML "LayerKey") returns the newly created child node object
;;;************************************************************************
(defun XML-Add-Child (parent name / xmlDoc newElement return)
(setq xmlDoc (vlax-get-property parent 'ownerDocument))
(if (not parent) (setq parent xmlDoc))
(if (setq newElement (api-error 'vlax-invoke-method (list xmlDoc 'createElement name) T))
(setq return (api-error 'vlax-invoke-method (list parent 'appendChild newElement) T))
)
return
)
;;;************************************************************************
;;; MODULE: XML-Get-Attribute
;;; DESCRIPTION: returns an XML object's named attribute value
;;; ARGS: XML object, attribute name (string), a default value to return if there is no value found in the XML object
;;; EXAMPLE: (XML-Get-Attribute oXML "Name" "Default") might return "ANNOTATION"
;;;************************************************************************
(defun XML-Get-Attribute (oXML name default / att return)
(if (setq att (api-error 'vlax-invoke-method (list oXML 'getAttributeNode name) T))
(if att
;; due to the fact that the Text property strips trailing and leading white characters
;; when using the 'get' method. the Value property has been used instead.
(vlax-variant-value (vlax-get-Property att "Value"))
default
)
)
)
;;;************************************************************************
;;; MODULE: XML-Get-Attribute-List
;;; DESCRIPTION: returns a list of strings corresponding to the names of the XML object's attributes
;;; ARGS: XML object
;;; EXAMPLE: (XML-Get-Attribute-List oXML) might return ("Name" "Color" "LineType" "LineWeight" "Plottable" "Comment")
;;;************************************************************************
(defun XML-Get-Attribute-List (oXML / lst attCollection count)
(if (setq attCollection (vlax-get-property oXML 'attributes))
(progn
(setq count 0)
(while (< count (vlax-get-property attCollection 'length))
(setq lst (append lst (list (vlax-get-property (vlax-get-property attCollection 'item count) 'Name)))
count (1+ count)
)
)
)
)
lst
)
;;;************************************************************************
;;; MODULE: XML-Put-Attribute
;;; DESCRIPTION: function to put an XML attribute value -- will add the attribute if not already there
;;; ARGS: XML object, attribute name (string), a value to change the attribute to
;;; EXAMPLE: (XML-Put-Attribute oXML "Name" "Default") might return vla-object
;;;************************************************************************
(defun XML-Put-Attribute (oXML name valu / att return)
(cond
( valu (setq valu (vl-princ-to-string valu)))
( (not valu) (setq valu ""))
)
(if (not (XML-Get-Attribute oXML name nil))
(XML-Add-Attribute oXML name "")
)
(api-error 'vlax-invoke-method (list oXML 'setAttribute name valu) T)
)
;;;************************************************************************
;;; MODULE: XML-Add-Attribute
;;; DESCRIPTION: adds an attribute to the Parent Object with given name, and the optional value
;;; ARGS: Parent Level VLA-Object, name of new attribute, value (optional)
;;; EXAMPLE: (XML-Add-Attribute oXML "Name" "Default") returns the newly created attribute XML object.
;;;************************************************************************
(defun XML-Add-Attribute (parent name valu / xmlDoc newAttribute newAtt)
(setq xmlDoc (vlax-get-property parent 'ownerDocument))
(if (setq newAttribute (api-error 'vlax-invoke-method (list xmlDoc 'createAttribute name) T))
(progn
(setq attNodeMap (vlax-get-property parent 'attributes)
newAtt (api-error 'vlax-invoke-method (list attNodeMap 'setNamedItem newAttribute) T)
)
(if valu (vlax-put-property newAtt 'Text valu))
)
)
newAtt
)
;;;************************************************************************
;;; MODULE: XML-Get-Value
;;; DESCRIPTION: Retrieves the value from the 'Text property of the supplied XML Element object
;;; ARGS: XML object
;;; EXAMPLE: (XML-Get-Value oXML) returns "4T323"
;;;************************************************************************
(defun XML-Get-Value (oXML)
(api-error 'vlax-get-property (list oXML 'text) T)
)
;;;************************************************************************
;;; MODULE: XML-Put-Value
;;; DESCRIPTION: Puts a text value into the 'Text property of the supplied XML Element object
;;; ARGS: XML object, text string
;;; EXAMPLE: (XML-Put-Value oXML "4T323") returns T if successful nil if not.
;;;************************************************************************
(defun XML-Put-Value (oXML str)
(api-error 'vlax-put-property (list oXML 'text str) T)
(if (= (XML-Get-Value oXML) str)
T
nil
)
)
;;;************************************************************************
;;; MODULE: XML-SaveAs
;;; DESCRIPTION: Writes the parsed XML object out to the given file
;;; ARGS: XML document object or XML element object, fully qualified filename to save to
;;; EXAMPLE: (XML-SaveAs oXML "C:\\projects\\npy structure.swp")
;;;************************************************************************
(defun XML-SaveAs (oXML file)
(cond
( (= (vlax-get-property oXML 'nodeTypeString) "element")
(api-error 'vlax-invoke-method (list (vlax-get-property oXML 'ownerDocument) 'save file) T)
)
( T (api-error 'vlax-invoke-method (list oXML 'save file) T))
)
)
;;;************************************************************************
;;; MODULE: XML-Save
;;; DESCRIPTION: Writes the parsed XML object out to its parent file
;;; ARGS: XML document object or XML element object
;;; EXAMPLE: (XML-Save oXML)
;;;************************************************************************
(defun XML-Save (oXML / doc file)
(cond
( (= (vlax-get-property oXML 'nodeTypeString) "element")
(setq doc (vlax-get-property oXML 'ownerDocument))
)
( T (setq doc oXML))
)
(setq file (vl-string-subst "\\" "/" (vl-string-left-trim "file:///" (vlax-get-property doc 'url))))
(api-error 'vlax-invoke-method (list doc 'save file) T)
)
;;;************************************************************************
(princ)

;;;************************************************************************ 
;;; api-xml.lsp 
;;; Prepared by: J. Szewczak 
;;; Date: 4 January 2004 
;;; Purpose: To provide an API for interfacing with XML files. 
;;; Copyright (c) 2004 - AMSEC LLC - All rights reserved 
;;;************************************************************************ 
;;; Version 2004.01.04 
;;;************************************************************************ 
 
;;;*********************************************************************** 
;;; MODULE: api-error 
;;; DESCRIPTION: wraps a function to trap Active-X errors - if error is found 
;;; DESCRIPTION: function returns nil. 
;;; ARGS: function to check, list of arguments, boolean (return error message?) T or nil 
;;; EXAMPLE: (api-error '/ (list 50 0) T) displays "VLISP Error: divide by zero" & returns 'nil' 
;;;*********************************************************************** 
 
(defun api-error (func lst bool / trap) 
  (cond 
    ( (vl-catch-all-error-p 
        (setq trap (vl-catch-all-apply func lst)) 
      ) 
      (if bool (princ (strcat "\nVLISP XML Error: " (vl-catch-all-error-message trap)))) 
      (setq trap nil) 
    ) 
  ) 
  trap 
) 
 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Document 
;;; DESCRIPTION: queries an XML file for the DOM Active-X object 
;;; ARGS: XML file (string); a variable to store the DOM object 
;;; EXAMPLE:(XML-Get-Document projfile 'XMLDoc) returns vla-object 
;;;************************************************************************ 
 
(defun XML-Get-Document (file XMLDoc) 
  (if (findfile file) 
    (progn 
      (set XMLDoc (vlax-create-object "MSXML2.DOMDocument.3.0")) ;;create XML-DOM pipeline 
      (vlax-put-property (eval XMLDoc) "async" :vlax-false) 
      (cond 
        ( (api-error 'vlax-invoke-method (list (eval XMLDoc) "Load" file) T) ;; Load Project File into XML-DOM pipeline 
          (eval XMLDoc) 
        ) 
      ) 
    ) 
    (alert "\nXML Document could not be found.") 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-XMLObject 
;;; DESCRIPTION: this gets the top-level parent node object in a given XML Document 
;;; ARGS: filename (string) 
;;; EXAMPLE: (XML-Get-XMLObject filename) returns VLA-OBJECT 
;;;************************************************************************ 
 
(defun XML-Get-XMLObject (file / docObj xmlTop xmlVer object) 
  (if (findfile file) 
    (progn 
      (setq docObj (XML-Get-Document file 'docObj) 
            xmlTop (vlax-get-property docObj "childNodes") ;; Get the Top Level of the XML 
            xmlVer (vlax-invoke-method xmlTop "nextNode")  ;; Gets the XML version element 
            object (vlax-invoke-method xmlTop "nextNode")  ;; Gets the Parent element 
      ) 
    ) 
  ) 
  object 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-ElementKey 
;;; DESCRIPTION: returns the requested tags text. 
;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name 
;;; EXAMPLE: (XML-Get-ElementKey laydef "Name") returns "ANNOTATION" 
;;;************************************************************************ 
 
(defun XML-Get-ElementKey (parent tag / el desc) 
  (if (vlax-method-applicable-p parent 'getElementsByTagName) 
    (progn 
      (setq el (vlax-invoke-method parent 'getElementsByTagName tag)) 
      (if (> (vlax-get-property el 'Length) 0) 
        (setq desc (vlax-get-property (vlax-invoke-method el 'nextNode) 'text)) 
      ) 
      (vlax-invoke-method el 'reset) 
    ) 
    (princ "\nXML Object could not be searched.") 
  ) 
  (if desc desc nil) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-ElementKey-Object 
;;; DESCRIPTION: returns the requested tags object. 
;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name 
;;; EXAMPLE: (XML-Get-ElementKey-Object laydef "Name") returns VLA-OBJECT 
;;;************************************************************************ 
 
(defun XML-Get-ElementKey-Object (parent tag / el desc) 
  (if (vlax-method-applicable-p parent 'getElementsByTagName) 
    (progn 
      (setq el (vlax-invoke-method parent 'getElementsByTagName tag)) 
      (if (> (vlax-get-property el 'Length) 0) 
        (setq desc (vlax-invoke-method el 'nextNode)) 
      ) 
      (vlax-invoke-method el 'reset) 
    ) 
    (princ "\nXML Object could not be searched.") 
  ) 
  (if desc desc nil) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Parent 
;;; DESCRIPTION: Gets a top level object from the XML object with the given name 
;;; ARGS: a valid XML object, the name of the parent level 
;;; EXAMPLE: (XML-Get-Parent oXML "Leaders") returns VLA-OBJECT 
;;;************************************************************************ 
 
(defun XML-Get-Parent (oXML name) 
  (vlax-invoke-method 
    (vlax-invoke-method oXML 'GetElementsByTagName name) 
   'peekNode 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Children 
;;; DESCRIPTION: gets the child object from a parent level 
;;; ARGS: XML object, Parent name 
;;; EXAMPLE: none 
;;;************************************************************************ 
 
(defun XML-Get-Children (oXML parentName / return) 
  (cond 
    ( (/= parentName nil) 
      (if (vlax-invoke-method (XML-Get-Parent oXML parentName) 'hasChildNodes) 
        (setq return (vlax-get-property (XML-Get-Parent oXML parentName) 'childNodes)) 
      ) 
    ) 
    ( T (if (vlax-invoke-method oXML 'hasChildNodes) (setq return (vlax-get-property oXML 'childNodes)))) 
  ) 
  return 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-ChildList 
;;; DESCRIPTION: returns a list of all child objects under a parent XML Object 
;;; ARGS: XML object 
;;; EXAMPLE: (XML-Get-ChildList objXML) returns a list of VLA-Objects 
;;;************************************************************************ 
 
(defun XML-Get-ChildList (oXML / collection child lst) 
  (cond 
    ( (vlax-invoke-method oXML 'hasChildNodes) 
      (setq collection (XML-Get-Children oXML nil)) 
      (while (setq child (vlax-invoke-method collection 'nextNode)) 
        (setq lst (if lst (cons child lst) (list child))) 
      ) 
      (reverse lst) 
    ) 
    (princ "\nObject has no children") 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Child 
;;; DESCRIPTION: gets a specific child name under the parent level with given name 
;;; ARGS: XML object, parent level, child name 
;;; EXAMPLE: (setq oPointers (XML-Get-Child oXML "Leaders" "Pointers")) returns VLA-Object 
;;; EXAMPLE: (XML-Get-Child oPointers nil "ArrowSize") used you only want to go one deep... 
;;;************************************************************************ 
 
(defun XML-Get-Child (oXML parentName childName / child target) 
  (cond 
    ( (/= parentName nil) (setq child (XML-get-Children oXML parentName))) 
    ( T (setq child (vlax-get-property oXML 'childNodes))) 
  ) 
  (setq target (api-error 'vlax-invoke-method (list child 'nextNode) T)) 
  (while 
    (and 
      target 
      (/= (vlax-get-property target 'tagName) childName) 
    ) 
    (setq target (api-error 'vlax-invoke-method (list child 'nextNode) T)) 
  ) 
  target 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Child-ByAttribute 
;;; DESCRIPTION: gets a specific child name under the parent level with given attribute and attribute value 
;;; ARGS: XML object, parent level, attribute to search by, attribute value to match 
;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayers "LayerDefinitions" "Name" "ANNOTATION") returns VLA-OBJECT 
;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayerDefs nil "Name" "ANNOTATION") used when you only want to go one deep... 
;;;************************************************************************ 
 
(defun XML-Get-Child-ByAttribute (oXML parentName attrib attribValue / parent rtn) 
  (if parentName 
    (setq parent (XML-Get-Child oXML nil parentName)) 
    (setq parent oXML) 
  ) 
  (foreach itm (XML-Get-ChildList parent) 
    (if (= (XML-Get-Attribute itm attrib "") attribValue) 
      (setq rtn itm) 
    ) 
  ) 
  rtn 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Child-Value 
;;; DESCRIPTION: Retrieves the value from the 'Text property of a child element 
;;; ARGS: XML object, parent Name, Child Name 
;;; EXAMPLE: (XML-Get-Child-Value oXML "TaskInfo" "FSCM") returns "4T323" 
;;;************************************************************************ 
 
(defun XML-Get-Child-Value (oXML parentName childName) 
  (if (XML-Get-Child oXML parentName childName) 
    (vlax-get-property (XML-Get-Child oXML parentName childName) 'text) 
    nil 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Put-Child 
;;; DESCRIPTION: updates the text in a given child node 
;;; ARGS: XML object, parent node name, child node to change, value to change to 
;;; EXAMPLE: (XML-Put-Child oXML "DrawingSetup" "DrawingMode" "MicroScale") 
;;;************************************************************************ 
 
(defun XML-Put-Child (oXML parentName childName valu / child return) 
  (if 
    (and 
      valu 
      (setq valu (vl-princ-to-string valu)) 
      (setq child (XML-Get-Child oXML parentName childName)) 
    ) 
    (api-error 'vlax-put-property (list child 'text valu) T) 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Remove-Child 
;;; DESCRIPTION: removes the specified child object node 
;;; ARGS: XML node object 
;;; EXAMPLE: (XML-Remove-Child oXML) 
;;;************************************************************************ 
 
(defun XML-Remove-Child (rmvChild / parent) 
  (setq parent (vlax-get-property rmvChild 'parentNode)) 
  (api-error 'vlax-invoke-method (list parent 'removeChild rmvChild) T) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Add-Child 
;;; DESCRIPTION: adds a Child element to the given parent object 
;;; ARGS: Parent Level VLA-Object, name of new child 
;;; EXAMPLE: (XML-Add-Child oXML "LayerKey") returns the newly created child node object 
;;;************************************************************************ 
 
(defun XML-Add-Child (parent name / xmlDoc newElement return) 
  (setq xmlDoc (vlax-get-property parent 'ownerDocument)) 
  (if (not parent) (setq parent xmlDoc)) 
  (if (setq newElement (api-error 'vlax-invoke-method (list xmlDoc 'createElement name) T)) 
    (setq return (api-error 'vlax-invoke-method (list parent 'appendChild newElement) T)) 
  ) 
  return 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Attribute 
;;; DESCRIPTION: returns an XML object's named attribute value 
;;; ARGS: XML object, attribute name (string), a default value to return if there is no value found in the XML object 
;;; EXAMPLE: (XML-Get-Attribute oXML "Name" "Default") might return "ANNOTATION" 
;;;************************************************************************ 
 
(defun XML-Get-Attribute (oXML name default / att return) 
  (if (setq att (api-error 'vlax-invoke-method (list oXML 'getAttributeNode name) T)) 
    (if att 
      ;; due to the fact that the Text property strips trailing and leading white characters 
      ;; when using the 'get' method.  the Value property has been used instead. 
      (vlax-variant-value (vlax-get-Property att "Value")) 
      default 
    ) 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Attribute-List 
;;; DESCRIPTION: returns a list of strings corresponding to the names of the XML object's attributes 
;;; ARGS: XML object 
;;; EXAMPLE: (XML-Get-Attribute-List oXML) might return ("Name" "Color" "LineType" "LineWeight" "Plottable" "Comment") 
;;;************************************************************************ 
 
(defun XML-Get-Attribute-List (oXML / lst attCollection count) 
  (if (setq attCollection (vlax-get-property oXML 'attributes)) 
    (progn 
      (setq count 0) 
      (while (< count (vlax-get-property attCollection 'length)) 
        (setq lst (append lst (list (vlax-get-property (vlax-get-property attCollection 'item count) 'Name))) 
              count (1+ count) 
        ) 
      ) 
    ) 
  ) 
  lst 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Put-Attribute 
;;; DESCRIPTION: function to put an XML attribute value -- will add the attribute if not already there 
;;; ARGS: XML object, attribute name (string), a value to change the attribute to 
;;; EXAMPLE: (XML-Put-Attribute oXML "Name" "Default") might return vla-object 
;;;************************************************************************ 
 
(defun XML-Put-Attribute (oXML name valu / att return) 
  (cond 
    ( valu (setq valu (vl-princ-to-string valu))) 
    ( (not valu) (setq valu "")) 
  ) 
  (if (not (XML-Get-Attribute oXML name nil)) 
    (XML-Add-Attribute oXML name "") 
  ) 
  (api-error 'vlax-invoke-method (list oXML 'setAttribute name valu) T) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Add-Attribute 
;;; DESCRIPTION: adds an attribute to the Parent Object with given name, and the optional value 
;;; ARGS: Parent Level VLA-Object, name of new attribute, value (optional) 
;;; EXAMPLE: (XML-Add-Attribute oXML "Name" "Default") returns the newly created attribute XML object. 
;;;************************************************************************ 
 
(defun XML-Add-Attribute (parent name valu / xmlDoc newAttribute newAtt) 
  (setq xmlDoc (vlax-get-property parent 'ownerDocument)) 
  (if (setq newAttribute (api-error 'vlax-invoke-method (list xmlDoc 'createAttribute name) T)) 
    (progn 
      (setq attNodeMap (vlax-get-property parent 'attributes) 
            newAtt (api-error 'vlax-invoke-method (list attNodeMap 'setNamedItem newAttribute) T) 
      ) 
      (if valu (vlax-put-property newAtt 'Text valu)) 
    ) 
  ) 
  newAtt 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Get-Value 
;;; DESCRIPTION: Retrieves the value from the 'Text property of the supplied XML Element object 
;;; ARGS: XML object 
;;; EXAMPLE: (XML-Get-Value oXML) returns "4T323" 
;;;************************************************************************ 
 
(defun XML-Get-Value (oXML) 
  (api-error 'vlax-get-property (list oXML 'text) T) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Put-Value 
;;; DESCRIPTION: Puts a text value into the 'Text property of the supplied XML Element object 
;;; ARGS: XML object, text string 
;;; EXAMPLE: (XML-Put-Value oXML "4T323") returns T if successful nil if not. 
;;;************************************************************************ 
 
(defun XML-Put-Value (oXML str) 
  (api-error 'vlax-put-property (list oXML 'text str) T) 
  (if (= (XML-Get-Value oXML) str) 
    T 
    nil 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-SaveAs 
;;; DESCRIPTION: Writes the parsed XML object out to the given file 
;;; ARGS: XML document object or XML element object, fully qualified filename to save to 
;;; EXAMPLE: (XML-SaveAs oXML "C:\\projects\\npy structure.swp") 
;;;************************************************************************ 
 
(defun XML-SaveAs (oXML file) 
  (cond 
    ( (= (vlax-get-property oXML 'nodeTypeString) "element") 
      (api-error 'vlax-invoke-method (list (vlax-get-property oXML 'ownerDocument) 'save file) T) 
    ) 
    ( T (api-error 'vlax-invoke-method (list oXML 'save file) T)) 
  ) 
) 
 
;;;************************************************************************ 
;;; MODULE: XML-Save 
;;; DESCRIPTION: Writes the parsed XML object out to its parent file 
;;; ARGS: XML document object or XML element object 
;;; EXAMPLE: (XML-Save oXML) 
;;;************************************************************************ 
 
(defun XML-Save (oXML / doc file) 
  (cond 
    ( (= (vlax-get-property oXML 'nodeTypeString) "element") 
      (setq doc (vlax-get-property oXML 'ownerDocument)) 
    ) 
    ( T (setq doc oXML)) 
  ) 
  (setq file (vl-string-subst "\\" "/" (vl-string-left-trim "file:///" (vlax-get-property doc 'url)))) 
  (api-error 'vlax-invoke-method (list doc 'save file) T) 
) 
 
;;;************************************************************************ 
(princ)

st788796 · 发表于 2014-1-3 10:11:42

newer 发表于 2014-1-3 10:05
XML-API

呵呵，可以用ODCL的Tree控件写一个编辑xml菜单命令
或者用TREE控件加xml做菜单

newer · 发表于 2014-1-3 10:11:56

;; Load the VisualLISP stuff
(vl-load-com)
;; Store an Active-X object to the main node ("Settings") of the XML data file.
(setq oSettings (XML-Get-XMLObject "C:\\dwgset.xml"))
;; Store an Active-X object to the "DrawingVars" node of the XML file.
(setq oDwgVars (XML-Get-Child oSettings nil "DrawingVars"))
;; The following two lines return the exact same thing.
;; An string object representing the value stored in the RegenAuto child node of the DrawingVars node.
(setq sRegenValue (XML-Get-Child-Value oDwgVars nil "RegenAuto"))
(setq sRegenValue (XML-Get-Child-Value oSettings "DrawingVars" "RegenAuto"))
;; Return the value that is stored inside a "Color" attribute from the child node of Layers whose "Name" attribute = "Walls"
(setq color
(read
(XML-Get-Attribute
(XML-Get-Child-ByAttribute oSettings "Layers" "Name" "Walls") "Color" "-1")
)
)
)
;; if the value for 'color' that we got above is less than the zero (our supplied default argument was -1).
;; then we'll set that attribute to 2.
(if (< color 0)
(progn
(XML-Put-Attribute (XML-Get-Child-ByAttribute oSettings "Layers" "Name" "Walls") "Color" 2)
;; After changing the Active-X object that is resident in memory,
;; we have to save all of our changes back to the XML file.
(XML-Save oSettings)
)
)
;; release the objects
(vlax-release-object oSettings)
(vlax-release-object oDwgVars)

;; Load the VisualLISP stuff 
(vl-load-com) 
 
;; Store an Active-X object to the main node ("Settings") of the XML data file. 
(setq oSettings (XML-Get-XMLObject "C:\\dwgset.xml")) 
 
;; Store an Active-X object to the "DrawingVars" node of the XML file. 
(setq oDwgVars (XML-Get-Child oSettings nil "DrawingVars")) 
 
;; The following two lines return the exact same thing. 
;; An string object representing the value stored in the RegenAuto child node of the DrawingVars node. 
(setq sRegenValue (XML-Get-Child-Value oDwgVars nil "RegenAuto")) 
(setq sRegenValue (XML-Get-Child-Value oSettings "DrawingVars" "RegenAuto")) 
 
;; Return the value that is stored inside a "Color" attribute from the child node of Layers whose "Name" attribute = "Walls" 
(setq color 
  (read 
    (XML-Get-Attribute 
      (XML-Get-Child-ByAttribute oSettings "Layers" "Name" "Walls") "Color" "-1") 
    ) 
  ) 
) 
 
;; if the value for 'color' that we got above is less than the zero (our supplied default argument was -1). 
;; then we'll set that attribute to 2. 
(if (< color 0) 
  (progn 
    (XML-Put-Attribute (XML-Get-Child-ByAttribute oSettings "Layers" "Name" "Walls") "Color" 2) 
 
    ;; After changing the Active-X object that is resident in memory, 
    ;; we have to save all of our changes back to the XML file. 
    (XML-Save oSettings) 
  ) 
) 
 
;; release the objects 
(vlax-release-object oSettings) 
(vlax-release-object oDwgVars)

上面这段代码执行完后，会生成这样的文件。

<?xml version="1.0"?>
<Settings>
 <Layers>
<Layer Name="Walls" Color="2" LineType="continuous"/>
<Layer Name="Furniture" Color="3" LineType="HIDDEN"/>
 </Layers>
 <DrawingVars>
<RegenAuto>1</RegenAuto>
<EdgeMode>0</EdgeMode>
<Osmode>383</Osmode>
 </DrawingVars>
</Settings>

st788796 · 发表于 2014-1-3 11:45:22

尝试下这个xml读写

神秘将军 · 发表于 2014-1-3 20:48:31

E老师，期待你的开源dcl学习

st788796 · 发表于 2014-1-3 21:14:31

神秘将军发表于 2014-1-3 20:48
E老师，期待你的开源dcl学习

有什么作品发上来共同学习下

chxl5878 · 发表于 2014-1-20 14:06:50

看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看看

liuchong1988 · 发表于 2014-6-18 09:23:43

工具发布没有啊？

liuchong1988 · 发表于 2014-7-4 09:46:10

有什么作品发上来共同学习下

fengdedaan · 发表于 2021-3-5 22:02:48

一直在找面板相关的程序

nochao · 发表于 2021-5-5 13:10:21

一个工具箱菜单面板

i3ku · 发表于 2021-5-11 07:28:14

好多年了也没见发布呢

QRWY · 发表于 2022-4-11 10:17:10

账号		自动登录	找回密码
密码			立即注册

[分享] 新作的一个工具箱菜单面板预览