在ACAd图形文件中建立数据库

南子 · 发表于 2002-2-16 20:24:00

我们可以在ACAD图形文件中建立数据库，方法是利用字典DICTIONARY和扩展纪录Xrecord，
一个dictionary就是一个表，一个Xrecord就是一条纪录。然后我们再做一个类似SQL的查询程序。这仅仅是一个设想，年后我会试着做一个测试版，欢迎大家来参与或者提出宝贵意见。
请与我联络 pxzzz@21cn.com

mccad · 发表于 2002-2-17 12:20:00

最好能做成通用的函数来写数据及读数据，再复杂一点就是把数据读到外部形成mdb类型的数据库。

南子 · 发表于 2002-2-18 21:57:00

(setq ZDictDbConst '((ZasString . 1)
      ;;1-9
      (ZasPoint . 10)
      ;;10-59]
      (ZasLong . 70)
      ;;60-79
      (Zasint32 . 90)
      ;;90-99
      (ZasDouble . 40)
      ;;140-147
      (Zasint16 . 170)
      ;;170-175
      (ZasInt8 . 280)
      ;;280-289
      (ZasText . 300)
      ;;300-309
      (ZasHandleValue . 320)
      ;;320-329
      (ZasHandleOfChunk . 310)
      ;;310-319
      (ZasObjectID . 330)
      ;;330-369
      (ZasDistance . 40)
      (ZasColor . 70)
      (ZasStartAngle . 40)
      (ZasEndAngle . 40)
      (ZasScale . 40)
      (ZasLineType . 1)
      (ZasLayer . 1)
      (ZasSpace . 70)
      (ZasOption . 70)
      (ZasHeight . 40)
      (ZasThickness . 40)
      (ZasFactor . 40)
      (ZasTextStyle . 1)
      (ZasLabel . 1)
      (ZasPrompt . 1)
      (ZasAdjust . 10)
      (ZasClosed . 70)
      (ZasBulge . 70)
      (ZasPtsCount . 90)
      (ZasVisible . 70)
      (ZasDescription . 1)
      )
)
(mapcar '(lambda (x) (set (car x) (cdr x))) ZDictDbConst)

(defun isHexP (string / error exitsub num str)
  (setq error nil
num 0
exitsub nil
  )
  (setq string (strcase string))
  (if (/= "" string)
(while (and (not error) (not exitsub))
   (setq str (substr string (setq num (1+ num)) 1))
   (if (or (and (>= (ascii str) (ascii "0"))
   (<= (ascii str) (ascii "9"))
      )
      (and (>= (ascii str) (ascii "A"))
   (<= (ascii str) (ascii "F"))
      )
   )
(not (setq error t))
   )
   (if (= num (strlen string))
(setq exitsub t)
   )
)
(setq error t)
  )
  (not error)
)
(defun zDataTypeCheck (value ztype)
  (if (= 'INT (type ztype))
(cond
   ((= zasString ztype)
   (if (= 'STR (type Value))
   (if (< (strlen value) 256)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现文字长度超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= zasdouble ztype)
   (if (= 'REAL (type value))
   t
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((or (= zasint16 ztype) (= zaslong ztype))
   (if (= 'INT (type value))
   (if (< (abs value) 65536)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现整数数值超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= zasint32 ztype)
   (if (= 'INT (type value))
   (if (< (abs value) 4228250626)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现整数数值超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= zasInt8 ztype)
   (if (= 'INT (type value))
   (if (< (abs value) 256)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现整数数值超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasText ztype)
   (if (= 'STR (type Value))
   t
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasHandleOfChunk ztype)
   (if (= 'STR (type Value))
   (if (ishexp Value)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，该值不是十六进制")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasHandleValue ztype)
   (if (= 'STR (type Value))
   (if (ishexp Value)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，该值不是十六进制")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasObjectID ztype)
   (if (= 'STR (type Value))
   (if (ishexp Value)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，该值不是十六进制")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
)
(progn (prompt "在zDataTypeCheck类型检查函数中，类型参数输入错误")
   (exit)
)
  )
)

;;;0?9 String. (With the introduction of extended symbol names in AutoCAD 2000, the 255 character limit has been lifted. There is no explicit limit to the number of bytes per line, although most lines should fall within 2049 bytes.)
;;;10?59 Double precision 3D point
;;;60?9 16-bit integer value
;;;90?9 32-bit integer value
;;;100 String (255-character maximum; less for Unicode strings)
;;;102 String (255-character maximum; less for Unicode strings)
;;;140?147 Double precision scalar floating-point value
;;;170?175 16-bit integer value
;;;280?289 8-bit integer value
;;;300?309 Arbitrary text string
;;;310?319 String representing hex value of binary chunk
;;;320?329 String representing hex handle value
;;;330?369 String representing hex object IDs

(defun zMkTable (DictName / objectDict)
  (setq objectDict (namedobjdict))
  (if (dictsearch objectDict dictname)
(dictremove (namedobjdict) dictname)
  )
  (dictadd objectDict
   Dictname
   (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))
  )
)

;;;(setq field-types '(("name" .  ZasString)("age" .  ZasInt8)("weight" . ZasDouble)))
(defun zMkfields (DictName field-Types)
  (if (not
(setq table (cdar (dictsearch (namedobjdict) dictname)))
   )
(setq table (zMKtable DICTNAME))
  )
  (if (dictsearch table "Fields")
(dictremove table "Fields")
  )
  (DICTADD
table
"Fields"
(ENTMAKEX
   (append
(list '(0 . "XRECORD")
      '(100 . "AcDbXrecord")
)
(apply (function append)
         (mapcar
   (function
   (lambda (x)
      (list (cons 1 (car x)) (cons 70 (eval (cdr x))))
   )
   )
   field-types
         )
)
   )
)
  )
)
;;;(zMkfields "Test3" field-types)

;;;(setq field-Values '(("name" . "南子")
;;;       ("age" . 38)
;;;       ("weight" . 140.0)))

(defun ZXrecordInsert (dictname       field-Values /
         ERROR       ERRORNAME    ERRORVALUE
         EXITSUB       field-TYPES    field-VALUES
         fieldNAME fieldS    fieldTYPE
         NUM       RECORDID    TABLE
      )
  (setq table (dictsearch (namedobjdict) dictname))
  (if table
(if (setq fields (dictsearch (cdar table) "Fields"))
   (progn
(setq
   fieldname (mapcar (function cdr)
      (vl-remove-if
      (function (lambda (x) (/= 1 (car x))))
      fields
      )
      )
)
(setq
   fieldtype (mapcar (function cdr)
      (vl-remove-if
      (function (lambda (x) (/= 70 (car x))))
      fields
      )
      )
)
(setq field-types (mapcar (function cons) fieldname fieldtype))
;;; 检查字名
(setq error nil
      exitsub nil
      num -1
)
(while (and (not error) (not exitsub))
   (if (not (member (setq errorname
   (car (nth (setq num (1+ num)) field-values))
   )
   fieldname
   )
      )
      (setq error (not (alert (strcat errorname
      " 字段名在 "
      dictname
      " 表中不存在"
      )
      )
)
      )
      (if (= num (- (length field-values) 1))
      (setq exitsub t)
      )
   )
)
(setq field-values
         (mapcar
   (function
   (lambda (x) (assoc (car x) field-values))
   )
   field-types
         )
)
;;; 检查字段值
(if (not error)
   (progn
      (setq error nil
   exitsub nil
   num -1
      )
      (while (and (not error) (not exitsub))
      (setq
errorname (car (nth (setq num (1+ num)) field-values))
      )
      (setq errorvalue (cdr (nth num field-values)))
      (if
(not
   (zDataTypeCheck
      errorvalue
      (cdr
      (assoc errorname
      field-types
      )
      )
   )
)
   (setq error t)
   (if (= num (- (length field-values) 1))
   (setq exitsub t)
   )
      )
      )
   )
)
(if (not error)
   (progn
      (setq table (cdar (dictsearch (namedobjdict) dictname)))
      (setq num
   (vlax-get (vlax-ename->vla-object
         (cdar (dictsearch (namedobjdict) dictname))
      )
      'count
   )
      )
      (if (not (dictsearch table (strcat "record" (itoa num))))
      (setq recordID (strcat "record" (itoa num)))
      (while (dictsearch
         table
         (setq recordid (strcat "record"
      (itoa (setq num (1+ num)))
      )
         )
      )
      )
      )
      (DICTADD
      table
      recordID
      (ENTMAKEX
(append
   (list '(0 . "XRECORD")
'(100 . "AcDbXrecord")
   )
   (apply (function append)
   (mapcar
   (function
      (lambda (x y)
         (list (cons (cdr x) (cdr y)))
      )
   )
   field-types
   field-values
   )
   )
)
      )
      )
   )

)
   )
)
  )
)

;;;(setq filter '((= "age" 38) (> "weight" 138.0)))
(defun ZGroupItems (code lst)
  (mapcar (function cdr)
   (vl-remove-if-not
      (function (lambda (x) (= code (car x))))
      lst
   )
  )
)

(defun ZXrecordAll (dictname    /       FIELD-TYPES  RECORDENT
      RECORDNAMES    RECORDOBJ RECORDTMP    X
   )
  (if (dictsearch (namedobjdict) dictname)
(progn
   (setq recordobj (dictsearch (namedobjdict) dictname))
   (setq recordent (cdar recordobj))
   (setq recordnames (vl-remove "Fields" (zgroupitems 3 recordobj)))
   (setq field-types
      (mapcar
         (function cons)
         (ZGroupItems 1 (dictsearch recordent "Fields"))
         (ZGroupItems 70 (dictsearch recordent "Fields"))
      )
   )
   (append
(list (mapcar (function car) field-types))
(mapcar (function
   (lambda (x / recordtmp)
      (setq recordtmp (dictsearch recordent x))
      (mapcar '(lambda (x) (cdr (assoc (cdr x) recordtmp)))
      field-types
      )
   )
)
recordnames
)
   )
)
  )
)

;;;(setq condition '((= "age" 1) (> "weight" 138.0)))
(defun ZXrecordSelect (dictname    condition /    ALLRECORD
         CONDTMP    FIELDNAME FIELDNAMES  FIELDPOS
         FIELDVALUE  METHOD    NUM    RECORDS
      )
  (setq allrecord (ZXrecordAll dictname))
  (setq records (cdr allrecord))
  (setq fieldnames (car allrecord))
  (setq num 0)
  (repeat (length condition)
(setq condtmp (nth num condition))
(setq method (car condtmp))
(setq fieldname (cadr condtmp))
(setq fieldvalue (last condtmp))
(setq FieldPos (vl-position fieldname fieldnames))
(setq
   records
   (vl-remove-if-not
   (function (lambda (x)
      ((eval method) (nth fieldpos x) fieldvalue)
   )
   )
   records
   )
)
(setq num (1+ num))
  )
)

龙龙仔 · 发表于 2002-2-19 10:31:00

本来我也想做一个记录3DSOLID的资料,方便统计零件、机台重量….等等,那是用xdata做的,但发现用xdata做起来执行速度非常的慢(3DSOLID组合图约50~70MB),所以只做了部份,想到执行速度那幺慢人就懒起来(现暂停了), 希望大家提出宝贵意见(XDATA使用上漏了1002{},以后再研究!!!!)
lai_wan_lung@pchome.com.tw

测试版程序如下:

;;;--------------------主程序3DXD.LSP------------------
(defun APP (APPNAME /)
  (if (tblsearch "appid" APPNAME)
(prompt (strcat
      "\n"
      APPNAME
      " 已经注册!! "
      )
)
(if (= (regapp APPNAME) NIL)
   (princ (strcat
         "\n不能注册XDATA在:"
         APPNAME
      )
   )
)
  )
)
(if (= (tblsearch "appid" "3DSOLID_DATA") NIL)
  (APP "3DSOLID_DATA")
)
(defun LAI (/ DCL_FILE DCL_FLAG EXDATA NEWENT NEWENT1)
  (setq DCL_FILE "3dxd"
DCL_NAME "data"
  )
  (setq DCL_FLAG (load_dialog DCL_FILE))
  (if (< DCL_FLAG 0)
(exit)
  )
  (if (not (new_dialog DCL_NAME DCL_FLAG))
(exit)
  )
  (set_tile "HEAVEN" (rtos A1))
  (set_tile "MATERIAL" MATERIAL)
  (set_tile "FACE" FACE)
  (mode_tile "HEAVEN" 1)
  (action_tile "HEAVEN" "(setq HEAVEN (get_tile $key))")
  (action_tile
"MATERIAL"
"(setq MATERIAL (get_tile $key))(A22)(A11)"
  )
  (action_tile "FACE" "(SETQ FACE (GET_TILE $KEY))")
  (action_tile
"cancel"
"(done_dialog 5)"
  )
  (action_tile
"accept"
"(done_dialog 3)"
  )
  (setq WHAT_NEXT (start_dialog))
  (unload_dialog DCL_FLAG)
  (A22)
  (A11)
  (A33)
  (if (= WHAT_NEXT 3)
(progn
   (setq EXDATA (cons -3
   (list (cons "3DSOLID_DATA"
      (append (list (cons 1040 A1))
      (list (cons 1000 A2))
      (list (cons 1000 A3))
      )
         )
   )
   )
   )
   (setq NEWENT1 (entget SS '("3DSOLID_DATA")))
   (setq NEWENT (subst EXDATA (assoc -3 NEWENT1) NEWENT1))
   (entmod NEWENT)
   (entmod NEWNET1)
)
  )
)
(defun A11 ()
  (cond
((wcmatch A2 "*S*")
   (setq A1 7.85)
)
((wcmatch A2 "*FC*")
   (setq A1 7.25)
)
((wcmatch A2 "铜")
   (setq A1 8.9)
)
((wcmatch A2 "*铝*")
   (setq A1 2.7)
)
((or (= A2 "青铜") (= A2 "黄铜"))
   (setq A1 8.6)
)
(t
   (setq A1 (distof HEAVEN))
)
  )
  (set_tile "HEAVEN" (rtos A1))
)
(defun A22 ()
  (cond
((= MATERIAL "0")
   (setq A2 "SS41")
)
((= MATERIAL "1")
   (setq A2 "S45C")
)
((= MATERIAL "2")
   (setq A2 "SUS304")
)
((= MATERIAL "3")
   (setq A2 "FC25")
)
((= MATERIAL "4")
   (setq A2 "FC30")
)
(t
   (setq A2 "SS41")
)
  )
)
(defun A33 ()
  (cond
((= FACE "0")
   (setq A3 "染黑")
)
((= FACE "1")
   (setq A3 "阳极处理")
)
((= FACE "2")
   (setq A3 "硬阳处理")
)
((= FACE "3")
   (setq A3 "镀硬铬")
)
((= FACE "4")
   (setq A3 "烤漆")
)
(t
   (setq A3 "染黑")
)
  )
)
(defun C:3DXD (/ AA SS SS1 WW EXDATA NEWNET)
  (while (= SS NIL)
(prompt "\n选择3DSOLID对象: ")
(setq SS (car (entsel)))
(if (/= SS NIL)
   (progn
(setq SS1 (cdr (assoc 0 (entget SS))))
(if (/= "3DSOLID" SS1)
   (setq SS NIL)
)
   )
)
  )
  (if (= (assoc -3 (entget SS '("3DSOLID_DATA"))) NIL)
(progn
   (setq WW (getstring "\n无附加资料,要加注吗?<Yes>: "))
   (if (= WW "")
(progn
   (setq EXDATA
   '((-3
      ("3DSOLID_DATA" (1040 . 7.85) (1000 . "SS41") (1000 . ""))
   )
   )
   )
   (setq NEWENT (append (entget SS) EXDATA))
   (entmod NEWENT)
)
(exit)
   )
)
  )
  (setq AA (cdadr (assoc -3 (entget SS '("3DSOLID_DATA")))))
  (setq A1 (cdr (nth 0 AA)))
  (setq A2 (cdr (nth 1 AA)))
  (setq A3 (cdr (nth 2 AA)))
  (cond
((= A2 "SS41")
   (setq MATERIAL "0")
)
((= A2 "S45C")
   (setq MATERIAL "1")
)
((= A2 "SUS304")
   (setq MATERIAL "2")
)
((= A2 "FC25")
   (setq MATERIAL "3")
)
((= A2 "FC30")
   (setq MATERIAL "4")
)
(t
   (setq MATERIAL "0")
)
  )
  (cond
((= A3 "染黑")
   (setq FACE "0")
)
((= A3 "阳极处理")
   (setq FACE "1")
)
((= A3 "硬阳处理")
   (setq FACE "2")
)
((= A3 "镀硬铬")
   (setq FACE "3")
)
((= A3 "烤漆")
   (setq FACE "4")
)
(t
   (setq FACE "0")
)
  )
  (LAI)
  (if (= WHAT_NEXT 3)
(prompt (strcat "\n1.比重: "
      (rtos A1)
      " 2.材质: "
      A2
      " 3.表面处理: "
      A3
      )
)
  )
  (setq HEAVEN NIL
MATERIAL NIL
FACE NIL
A1 NIL
A2 NIL
A3 NIL
  )
  (princ)
)

(defun C:C3DXD (/ SS N SSL AA A1 A2 A3 A4 A5 FILE_ID LL)
  (while (= SS NIL)
(prompt "\n选择要计算重量的3DSOLID对象: ")
(setq SS (ssget '((0 . "3DSOLID") (-3 ("3DSOLID_DATA")))))
  )
  (setq SSL (sslength SS))
  (setq N 0)
  (setq A5 0)
  (repeat SSL
(setq
   AA (cdadr (assoc -3 (entget (ssname SS N) '("3DSOLID_DATA"))))
)
(setq A1 (cdr (nth 0 AA)))
(setq A2 (cdr (nth 1 AA)))
(setq A3 (cdr (nth 2 AA)))
(setvar "cmdecho" 0)
(command "_.MASSPROP" (ssname SS N) "" "Y" "C3DXD")
;;;(command ".delay" 20000)
(setq FILE_ID (open (findfile "C3DXD.MPR") "r"))
(repeat 5
   (setq LL (read-line FILE_ID))
)
(close FILE_ID)
(setq A4 (/ (* A1 (distof (substr LL 8) 2)) 1000000))
(setq A5 (+ A4 A5))
(prompt (strcat "\n1.比重: "
      (rtos A1)
      " 2.材质: "
      A2
      " 3.表面处理: "
      A3
      " 4.重量: "
      (rtos A4)
      "公斤"
      " 5.累绩总重量: "
      (rtos A5)
      "公斤"
      )
)
(setq N (1+ N))
  )
  (princ)
)
(princ)

(defun C:C3DXD1 (/ SS A1 A4 FILE_ID LL)
  (while (= SS NIL)
(prompt "\n选择要计算重量的3DSOLID对象: ")
(setq SS (ssget '((0 . "3DSOLID"))))
  )
  (command "_.MASSPROP" SS "" "Y" "C3DXD")
  (setq FILE_ID (open (findfile "C3DXD.MPR") "r"))
  (repeat 5
(setq LL (read-line FILE_ID))
  )
  (close FILE_ID)
  (setq A1 (getreal "\n材料比重: "))
  (setq A4 (/ (* A1 (distof (substr LL 8) 2)) 1000000))
  (prompt (strcat "\n 重量: "
   (rtos A4)
   "公斤"
   )
  )
  (princ)
)
(princ)

(defun C:3DXD_ALL
   (/ N AA SS SS1 WW DCL_FILE DCL_FLAG EXDATA NEWENT NEWENT1)
  (while (= SS NIL)
(prompt "\n选择3DSOLID对象: ")
(setq SS (ssget '((0 . "3DSOLID"))))
  )
  (setq N 0)
  (repeat (sslength SS)
(setq EXDATA
   '((-3
      ("3DSOLID_DATA" (1040 . 7.85) (1000 . "SS41") (1000 . ""))
      )
      )
)
(setq NEWENT (append (entget (ssname SS N)) EXDATA))
(entmod NEWENT)
(setq N (1+ N))
  )
  (setq AA (cdadr (assoc -3 (entget (ssname SS 0) '("3DSOLID_DATA")))))
  (setq A1 (cdr (nth 0 AA)))
  (setq A2 (cdr (nth 1 AA)))
  (setq A3 (cdr (nth 2 AA)))
  (cond
((= A2 "SS41")
   (setq MATERIAL "0")
)
((= A2 "S45C")
   (setq MATERIAL "1")
)
((= A2 "SUS304")
   (setq MATERIAL "2")
)
((= A2 "FC25")
   (setq MATERIAL "3")
)
((= A2 "FC30")
   (setq MATERIAL "4")
)
(t
   (setq MATERIAL "0")
)
  )
  (cond
((= A3 "染黑")
   (setq FACE "0")
)
((= A3 "阳极处理")
   (setq FACE "1")
)
((= A3 "硬阳处理")
   (setq FACE "2")
)
((= A3 "镀硬铬")
   (setq FACE "3")
)
((= A3 "烤漆")
   (setq FACE "4")
)
(t
   (setq FACE "0")
)
  )

  (setq DCL_FILE "3dxd"
DCL_NAME "data"
  )
  (setq DCL_FLAG (load_dialog DCL_FILE))
  (if (< DCL_FLAG 0)
(exit)
  )
  (if (not (new_dialog DCL_NAME DCL_FLAG))
(exit)
  )
  (set_tile "HEAVEN" (rtos A1))
  (set_tile "MATERIAL" MATERIAL)
  (set_tile "FACE" FACE)
  (mode_tile "HEAVEN" 1)
  (action_tile "HEAVEN" "(setq HEAVEN (get_tile $key))")
  (action_tile
"MATERIAL"
"(setq MATERIAL (get_tile $key))(A22)(A11)"
  )
  (action_tile "FACE" "(SETQ FACE (GET_TILE $KEY))")
  (action_tile
"cancel"
"(done_dialog 5)"
  )
  (action_tile
"accept"
"(done_dialog 3)"
  )
  (setq WHAT_NEXT (start_dialog))
  (unload_dialog DCL_FLAG)
  (A22)
  (A11)
  (A33)
  (setq N 0)
  (repeat (sslength SS)
(if (= WHAT_NEXT 3)
   (progn
(setq EXDATA (cons -3
   (list (cons "3DSOLID_DATA"
         (append (list (cons 1040 A1))
         (list (cons 1000 A2))
         (list (cons 1000 A3))
         )
   )
   )
      )
)
(setq NEWENT1 (entget (ssname SS N) '("3DSOLID_DATA")))
(setq NEWENT (subst EXDATA (assoc -3 NEWENT1) NEWENT1))
(entmod NEWENT)
(entmod NEWNET1)
   )
)
(setq N (1+ N))
  )
  (if (= WHAT_NEXT 3)
(prompt (strcat "\n1.比重: "
      (rtos A1)
      " 2.材质: "
      A2
      " 3.表面处理: "
      A3
      )
)
  )
  (setq HEAVEN NIL
MATERIAL NIL
FACE NIL
A1 NIL
A2 NIL
A3 NIL
  )
  (princ)
)
(prompt
  "\nTYPE 3DXD FOR 修改及加注.......TYPE 3DXD_ALL FOR 大量修改及加注"
)
(prompt
  "\nTYPE C3DXD FOR 重量.....TYPE C3DXD1 FOR 无XDATA之\"3DSOLID\"重量"
)
(princ)

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

;;;--------------3DXD.DCL-----------------------------------
dcl_settings : default_dcl_settings { audit_level = 3; }

data : dialog {
label = "零件备注";
: edit_box {
      label = "比重(H)";
      mnemonic = "H";
      key = "HEAVEN";
      alignment = left;
      allow_accept = true;
      edit_limit = 20;
      edit_width = 15;
      height = 1;
      width = 2;
}
: popup_list {
      label = "材质[M]";
      mnemonic = "M";
      key = "MATERIAL";
      alignment = left;
      edit_width = 14;
      height = 1;
      list = "\nSS41\nS45C\nSUS304\nFC25\nFC30";
      width = 2;
}
: popup_list {
      label = "表面处理[F]";
      mnemonic = "F";
      key = "FACE";
      alignment = left;
      edit_width = 14;
      height = 1;
      list = "\染黑\n阳极处理\n硬阳处理\n镀硬铬\n烤漆";
      width = 2;
}
ok_cancel;
}
;;;------------------------------------------------------------------------

goldenshin · 发表于 2002-2-19 11:29:00

是很好的IDear,我在一些Arx中虽然也做过一些,但都不能通用;最好是能做成通用的,然后提供接口[br]是很好的IDear,我在一些Arx中虽然也做过一些,但都不能通用;最好是能做成通用的,然后提供接口

南子 · 发表于 2002-2-19 20:16:00

//dictdb.dcl
dcl_settings : default_dcl_settings { audit_level = 3; }

dictdb : dialog {
label = "创建数据表";
: boxed_row {
      fixed_width = true;
      fixed_height = true;
      : edit_box {
         label = "表名&T";
         key = "table";
         mnemonic = "T";
         edit_width = 20;
         width = 30;
         fixed_width = true;
      }
      : button {
         label = "创建&C";
         key = "create";
         mnemonic = "C";
         fixed_width = true;
      }
}
: boxed_row {
      children_fixed_width = true;
      fixed_width = true;
      fixed_height = true;
      : row {
         children_fixed_width = true;
         fixed_width = true;
         fixed_height = true;
         alignment = centered;
         : list_box {
            label = "字段列表&S";
            key = "fields";
            tabs = "22 30";
            width = 30;
            fixed_width = true;
         }
         : column {
            : column {
                  : text {
                     label = "字段名称:";
                     fixed_width = true;
                     alignment = centered;
                  }
                  : edit_box {
                     key = "fieldname";
                     edit_width = 10;
                     edit_limit = 30;
                  }
            }
            : column {
                  : text {
                     label = "字段类型:";
                     fixed_width = true;
                     alignment = centered;
                  }
                  : popup_list {
                     value = "ZasString";
                     key = "datatype";
                     list = "STRING\nTEXT\nINT16\nLONG\nREAL\nBOOLEAN";
                     edit_width = 10;
                  }
            }
            : button {
                  label = "添加&A";
                  key = "add";
                  mnemonic = "A";
                  fixed_width = true;
            }
            : button {
                  label = "修改&G";
                  key = "change";
                  mnemonic = "G";
                  fixed_width = true;
            }
            : button {
                  label = "删除&D";
                  key = "del";
                  mnemonic = "D";
                  fixed_width = true;
            }
            : button {
                  label = "关闭&E";
                  key = "cancel";
                  is_cancel = true;
                  fixed_width = true;
            }
         }
      }
}
}

//dictdb.lsp
(setq ZDictDbConst '((ZasString . 1)
      (ZasBoolean . 70)
      ;;60-79
      (ZasLong . 90)
      ;;90-99
      (ZasReal . 40)
      ;;140-147
      (Zasint16 . 170)
      ;;170-175
      (ZasText . 300)
      )
)
(mapcar '(lambda (x) (set (car x) (cdr x))) ZDictDbConst)

(defun isHexP (string / error exitsub num str)
  (setq error nil
num 0
exitsub nil
  )
  (setq string (strcase string))
  (if (/= "" string)
(while (and (not error) (not exitsub))
   (setq str (substr string (setq num (1+ num)) 1))
   (if (or (and (>= (ascii str) (ascii "0"))
   (<= (ascii str) (ascii "9"))
      )
      (and (>= (ascii str) (ascii "A"))
   (<= (ascii str) (ascii "F"))
      )
   )
(not (setq error t))
   )
   (if (= num (strlen string))
(setq exitsub t)
   )
)
(setq error t)
  )
  (not error)
)
(defun zDataTypeCheck (value ztype)
  (if (= 'INT (type ztype))
(cond
   ((= zasString ztype)
   (if (= 'STR (type Value))
   (if (< (strlen value) 256)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现文字长度超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= zasreal ztype)
   (if (= 'REAL (type value))
   t
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((or (= zasint16 ztype) (= zaslong ztype))
   (if (= 'INT (type value))
   (if (< (abs value) 65536)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现整数数值超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= zaslong ztype)
   (if (= 'INT (type value))
   (if (< (abs value) 4228250626)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现整数数值超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= zasInt8 ztype)
   (if (= 'INT (type value))
   (if (< (abs value) 256)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，发现整数数值超限")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasText ztype)
   (if (= 'STR (type Value))
   t
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasHandleOfChunk ztype)
   (if (= 'STR (type Value))
   (if (ishexp Value)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，该值不是十六进制")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasHandleValue ztype)
   (if (= 'STR (type Value))
   (if (ishexp Value)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，该值不是十六进制")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
   ((= ZasObjectID ztype)
   (if (= 'STR (type Value))
   (if (ishexp Value)
   t
   (progn
      (prompt "在zDataTypeCheck类型检查函数中，该值不是十六进制")
      (exit)
   )
   )
   (progn
   (prompt "在zDataTypeCheck类型检查函数中，值与字段类型不符")
   (exit)
   )
   )
   )
)
(progn (prompt "在zDataTypeCheck类型检查函数中，类型参数输入错误")
   (exit)
)
  )
)
(defun zMkTable (DictName / objectDict)
  (setq objectDict (namedobjdict))
  (if (dictsearch objectDict dictname)
(dictremove (namedobjdict) dictname)
  )
  (dictadd objectDict
   Dictname
   (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))
  )
)

;;;(setq field-types '(("name" .  ZasString)("age" .  ZasInt16)("weight" . ZasDouble)))
(defun zMkfields (DictName field-Types)
  (if (not
(setq table (cdar (dictsearch (namedobjdict) dictname)))
   )
(setq table (zMKtable DICTNAME))
  )
  (if (dictsearch table "Fields")
(dictremove table "Fields")
  )
  (DICTADD
table
"Fields"
(ENTMAKEX
   (append
(list '(0 . "XRECORD")
      '(100 . "AcDbXrecord")
)
(apply (function append)
         (mapcar
   (function
   (lambda (x)
      (list (cons 1 (car x)) (cons 70 (eval (cdr x))))
   )
   )
   field-types
         )
)
   )
)
  )
)
;;;(zMkfields "Test" field-types)

;;;(setq field-Values '(("name" . "南子") ("age" . 39) ("weight" . 120.0)))
;;;(zxrecordinsert dictname field-values)
(defun ZXrecordInsert (dictname       field-Values /
         ERROR       ERRORNAME    ERRORVALUE
         EXITSUB       field-TYPES    field-VALUES
         fieldNAME fieldS    fieldTYPE
         NUM       RECORDID    TABLE
      )
  (setq table (dictsearch (namedobjdict) dictname))
  (if table
(if (setq fields (dictsearch (cdar table) "Fields"))
   (progn
(setq
   fieldname (mapcar (function cdr)
      (vl-remove-if
      (function (lambda (x) (/= 1 (car x))))
      fields
      )
      )
)
(setq
   fieldtype (mapcar (function cdr)
      (vl-remove-if
      (function (lambda (x) (/= 70 (car x))))
      fields
      )
      )
)
(setq field-types (mapcar (function cons) fieldname fieldtype))
;;; 检查字名
(setq error nil
      exitsub nil
      num -1
)
(while (and (not error) (not exitsub))
   (if (not (member (setq errorname
   (car (nth (setq num (1+ num)) field-values))
   )
   fieldname
   )
      )
      (setq error (not (alert (strcat errorname
      " 字段名在 "
      dictname
      " 表中不存在"
      )
      )
)
      )
      (if (= num (- (length field-values) 1))
      (setq exitsub t)
      )
   )
)
(setq field-values
         (mapcar
   (function
   (lambda (x) (assoc (car x) field-values))
   )
   field-types
         )
)
;;; 检查字段值
(if (not error)
   (progn
      (setq error nil
   exitsub nil
   num -1
      )
      (while (and (not error) (not exitsub))
      (setq
errorname (car (nth (setq num (1+ num)) field-values))
      )
      (setq errorvalue (cdr (nth num field-values)))
      (if
(not
   (zDataTypeCheck
      errorvalue
      (cdr
      (assoc errorname
      field-types
      )
      )
   )
)
   (setq error t)
   (if (= num (- (length field-values) 1))
   (setq exitsub t)
   )
      )
      )
   )
)
(if (not error)
   (progn
      (setq table (cdar (dictsearch (namedobjdict) dictname)))
      (setq num
   (vlax-get (vlax-ename->vla-object
         (cdar (dictsearch (namedobjdict) dictname))
      )
      'count
   )
      )
      (if (not (dictsearch table (strcat "record" (itoa num))))
      (setq recordID (strcat "record" (itoa num)))
      (while (dictsearch
         table
         (setq recordid (strcat "record"
      (itoa (setq num (1+ num)))
      )
         )
      )
      )
      )
      (DICTADD
      table
      recordID
      (ENTMAKEX
(append
   (list '(0 . "XRECORD")
'(100 . "AcDbXrecord")
   )
   (apply (function append)
   (mapcar
   (function
      (lambda (x y)
         (list (cons (cdr x) (cdr y)))
      )
   )
   field-types
   field-values
   )
   )
)
      )
      )
   )

)
   )
)
  )
)

;;;(setq filter '((= "age" 38) (> "weight" 138.0)))
(defun ZGroupItems (code lst)
  (mapcar (function cdr)
   (vl-remove-if-not
      (function (lambda (x) (= code (car x))))
      lst
   )
  )
)

;;;(zxrecordall "test")
(defun ZXrecordAll (dictname    /       FIELD-TYPES  RECORDENT
      RECORDNAMES    RECORDOBJ RECORDTMP    X
   )
  (if (dictsearch (namedobjdict) dictname)
(progn
   (setq recordobj (dictsearch (namedobjdict) dictname))
   (setq recordent (cdar recordobj))
   (setq recordnames (vl-remove "Fields" (zgroupitems 3 recordobj)))
   (setq field-types
      (mapcar
         (function cons)
         (ZGroupItems 1 (dictsearch recordent "Fields"))
         (ZGroupItems 70 (dictsearch recordent "Fields"))
      )
   )
   (append
(list (cons "Fields" (mapcar (function car) field-types)))
(mapcar (function
   (lambda (x / recordtmp)
      (setq recordtmp (dictsearch recordent x))
      (cons x (mapcar '(lambda (x) (cdr (assoc (cdr x) recordtmp)))
      field-types
      )
      )
   )
)
recordnames
)
   )
)
  )
)

;;;(setq condition '((> "age" 37) (> "weight" 119.0)))
;;;(zxrecordselect "test" condition)
(defun ZXrecordSelect (dictname    condition /    ALLRECORD
         CONDTMP    FIELDNAME FIELDNAMES  FIELDPOS
         FIELDVALUE  METHOD    NUM    RECORDS
      )
  (setq allrecord (ZXrecordAll dictname))
  (setq records (cdr allrecord))
  (setq fieldnames (car allrecord))
  (setq num 0)
  (repeat (length condition)
(setq condtmp (nth num condition))
(setq method (car condtmp))
(setq fieldname (cadr condtmp))
(setq fieldvalue (last condtmp))
(setq FieldPos (vl-position fieldname fieldnames))
(setq
   records
   (vl-remove-if-not
   (function (lambda (x)
      ((eval method) (nth fieldpos x) fieldvalue)
   )
   )
   records
   )
)
(setq num (1+ num))
  )
  (cons fieldnames records)
)
;;;(ZXrecordDelete dictname condition)
(defun ZXrecordDelete (dictname condition / xrecordnames xrecord)
  (setq xrecordnames
   (cdr (mapcar (function car)
      (zxrecordselect dictname condition)
      )
   )
  )
  (foreach x xrecordnames
(if (setq xrecord (cdar (dictsearch (namedobjdict) dictname)))
   (if (dictsearch xrecord x)
(dictremove xrecord x)
   )
)
  )
  (princ)
)

(defun c:mkDB (/ $KEY       $VALUE    DATATYPE    DATATYPE_VALUES
         DCL_ID       FIELDNAME    FIELDS_VALUES TABLE
         WHAT_NEXT
      )
  (defun dictdb_table (key value)
(if (snvalid value 0)
   (setq table (strcase value))
   (progn (mode_tile key 2) (mode_tile key 3))
)
  )
  (defun dictdb_fieldname (key value)
(if (snvalid value 0)
   (setq fieldname (strcase value))
   (progn (mode_tile key 2) (mode_tile key 3))
)
  )
  (defun dictdb_fields (key value)
(setq
   fieldname (vl-symbol-name
   (read (nth (read value) (REVERSE fields_values)))
)
)
(setq datatype (vl-string-left-trim
      (strcat fieldname "\t")
      (nth (read value) (REVERSE fields_values))
   )
)
(set_tile "fieldname" fieldname)
(set_tile "datatype" (ITOA (- (LENGTH DATATYPE_VALUES) (LENGTH (MEMBER datatype DATATYPE_VALUES)))))

  )

  (defun dictdb_add (/ DATATYPE)
(if (and (/= "" (vl-string-trim " " fieldname))
      (not
         (member (vl-string-trim " " fieldname)
         (mapcar (function (lambda (x) (strcase (car (strtab x)))))
         fields_values
         )
         )
      )
)
   (progn
      (setq datatype (nth (read (get_tile "datatype")) datatype_values))
(setq fields_values
      (cons (strcat fieldname "\t" datatype) fields_values)
      )

      (start_list "fields" 2)
      (add_list (strcat fieldname "\t" datatype))
      (end_list)
   )
)
  )
  (defun dictdb_change (/ DATATYPE)
(if (and (/= "" (get_tile "fields")) (/= "-1" (get_tile "fields")))
   (progn
(setq datatype (nth (read (get_tile "datatype")) datatype_values))
(setq fields_values (subst (strcat fieldname "\t" datatype) (nth (read (get_tile "fields")) (reverse fields_values)) fields_values))
(start_list "fields" 1 (read (get_tile "fields")))
(add_list (strcat fieldname "\t" datatype))
(end_list)))
  )
  (defun dictdb_del ()
(if (/= "-1" (get_tile "fields"))
   (progn
(setq fields_values (vl-remove (nth (read (get_tile "fields")) (reverse fields_values)) fields_values))
(start_list "fields" 3)
(mapcar (function add_list) fields_values)
(end_list)))
  )
  (defun dictdb_create (/ table)
(if (snvalid (get_tile "table") 0)
   (progn
(setq table (strcase (get_tile "table")))
(if
   (zMkfields
      table
      (mapcar
      (function
(lambda (x)
   (cons (car x) (eval (read (strcat "Zas" (cadr x)))))
)
      )
      (mapcar (function strtab) fields_values)
      )
   )
   (progn

      (alert (strcat "\n  "
      (strcase (get_tile "table"))
      " 数据库已成功创建!\n"
      )
      )
      (done_dialog 1)
   )
)
   )
)
  )


  (setq fields_values nil)
  (setq datatype_values '("STRING" "TEXT" "INT16" "LONG" "REAL" "BOOLEAN"))
  (setq dcl_id (load_dialog "dictdb.dcl"))
  (if (not (new_dialog "dictdb" dcl_id))
(exit)
  )

  (set_tile "table"
      (if table
      table
      ""
      )
  )
  (set_tile "fieldname"
      (if fieldname
      fieldname
      ""
      )
  )

  (set_tile "datatype"
      (if datatype
      datatype
      (setq datatype (car datatype_values))
      )
  )

  (start_list "fields")
  (mapcar 'add_list fields_values)
  (end_list)
;;;  (action_tile "datatype" "(dictdb_datatype $key $value)")
  (action_tile "table" "(dictdb_table  $key $value)")
  (action_tile "fields" "(dictdb_fields $key $value)")
  (action_tile "fieldname" "(dictdb_fieldname $key $value)")
;;;  (action_tile "datatype" "(dictdb_datatype  $key $value)")
  (action_tile "add" "(dictdb_add)")
  (action_tile "del" "(dictdb_del)")
  (action_tile "change" "(dictdb_change)")
  (action_tile "create" "(dictdb_create)")
  (action_tile "cancel" "(done_dialog 0)")
  (start_dialog)
)

(prompt "\n创建数据库命令: mkdb\n")

南子 · 发表于 2002-2-21 20:51:00

我已完成该建议的测试版，欢迎大家下载。程序名：dictdb.vlx 命令:dictdb

bjlyk · 发表于 2006-9-6 13:22:00

看来我真是一只井底之蛙呀

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

在ACAd图形文件中建立数据库

这个想法不错

acad内部数据库，我的第一个实验

是很好的IDear,我在一些Arx中虽然也做过一些,但都不能通用;最好是能做成通用的,然后

请测试我的一个测试 mkdb

我已完成该建议的测试版，欢迎大家下载。