[转贴]：搜到的一些 vblibrary 函数

eachy · 发表于 2004-5-27 20:31:46

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;; This file contains VB data conversion functions that are necessary for
;;; the function library functions to work properly.
;;; Available functions are:
;;;
;;; (object? x)
;;; (collection? x)
;;; (safearray? x)
;;; (variant? x)
;;; (VariantArray? x)
;;; (ToObject x)
;;; (pks>obj x)
;;; (ToVB x)
;;; (ToLISP x)
;;; (PtList=>VB ptlst dim)
;;; (TableNames tblobj)
;;; (GetProperty obj prop)
;;; (PutProperty obj prop nval)
;;; (MS-TypeLibraryLoad appname)
(vl-load-com)
;;; This function returns T if x is a VBA object
;;测试是否是 VBA Object
(defun object? (x) (eq 'VLA-OBJECT (type x)))
;;; This function returns T if x is a variant.
;;测试是否是 Variant
(defun variant? (x) (= 'variant (type x)))
;;; This function returns T if x is a variant array.
;;测试是否为 variant array
(defun VariantArray? (x)
(and (variant? x) (>= (vlax-variant-type x) 8192))
)
;;; This function returns T if x is a VBA collection.
;;测试是否为 VBA collection
(defun collection? (x)
(and (object? x) (vlax-property-available-p x 'Count))
)
;;; This function returns T if x is a VBA safearray
;;VBA Saferarray 测试
(defun safearray? (x) (eq 'SAFEARRAY (type x)))
;;; The function attempts to convert it's input into a VBA object.
;;; - the ename of an entget list is returned as an object
;;; - the first ename of a pickset is returned as an object
;;; - an ename is returned as an object
;;; - an object is returned as itself
;;; - the first object in a collection is returned as an object
;;;
;; 转换为 VBA Object
;; 实体名（entsel返回格式）转换为 Object
;; 实体名转换为Object
;; SelectionSet 返回第一个 Object
;; Object 返回自身
;; 选择集返回第一个实体
(defun ToObject (x)
(cond
((and (listp x)
(= (length x) 2)
(nam? (car x))
(Point? (cadr x))
)
(ToObject (car x))
)
((nam? x) (vlax-ename->vla-object x))
((collection? x) (vla-Item x 1))
((object? x) x)
((pks? x) (ToObject (ssname x 0)))
(T nil)
)
)
;;....Convert a PICKSET to a list of OBJECTs
;;选择集转换为 Object 集合
(defun pks>obj (x / cnt lst)
(mapcar 'vlax-ename->vla-object (pks>nam x))
)
;;....convert Lisp data to VB
;;转换Lisp数据为 VB 数据类型，支持点、表（字串、整数、实数、Object、空表）
;; t & nil
;; 整数、实数、字符、实体
(defun ToVB (x / len typ lst)
(cond
((Point? x)
(vlax-3D-point (2D>3Dpt (mapcar 'float x)))
)
((and (listp x) (apply 'eq (mapcar 'type x)))
(setq len (length x)
typ (type (car x))
lst (vlax-make-safearray
(cond
((= typ 'STR) vlax-vbString)
((= typ 'VLA-OBJECT) vlax-vbObject)
((= typ 'INT) vlax-vbInteger)
((= typ 'REAL) vlax-vbDouble)
(T nil)
)
'(0 . (1- len))
)
)
(vlax-safearray-fill lst 'x)
)
((or (= x nil) (= x T) (= x '()))
(vlax-make-variant x vlax-vbBoolean)
)
((= 'INT (type x)) (vlax-make-variant x vbInteger))
((= 'REAL (type x)) (vlax-make-variant x vbDouble))
((= 'STR (type x)) (vlax-make-variant x vbString))
((= 'ENAME (type x)) (vlax-ename->vla-object x))
(T x)
)
)
;;..................Convert VB data to LISP data types
;; VB 数据转换为 Lisp 数据类型
(defun ToLISP (x)
(cond
((safearray? x) (vlax-safearray->list x))
((VariantArray? x)
(vlax-safearray->list (vlax-variant-value x))
)
((variant? x) (vlax-variant-value x))
((= x :vlax-true) T)
((= x :vlax-false) nil)
(T x)
)
)
;;; Take a list of points and convert them to a variant array of doubles suitable
;;; for VB lwpolyline generation. Set the DIM argument to 2 or 3 depending on
;;; whether you need a list for 2D or 3D lwpolylines.
;; 点表转换为 VB variant array 支持 2D 、3D 点
(defun PTLIST=>VB (ptlst dim / vbarr)
(setq ptlst (mapcar '(lambda (x)
(if (= 2 dim)
(xyof X)
(2D>3Dpt X)
)
)
ptlst
)
ptlst (apply 'append ptlst)
vbarr (vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length ptlst)))
) ;dimension the array
)
(vlax-safearray-fill vbarr ptlst) ;fill the array with doubles
(vlax-make-variant vbarr vbDouble) ;return variant array with doubles
)
;;;Return all the name entries in a given table.
;;返回表内实体
(defun TableNames (tableobj / lst cnt)
(setq cnt 0)
(repeat (vla-get-Count tableobj)
(setq lst (cons (vla-get-Name (vla-Item tableobj cnt)) lst)
cnt (1+ cnt)
)
)
(acad_strlsort lst)
)
;;........Retrieve information from an object
;;获取实体特性
(defun GetProperty (obj prop)
(setq obj (ToObject obj))
(if (vlax-property-available-p obj prop)
(ToLISP (vlax-get-property obj prop))
nil
)
)
;;........Modify an object's properties
;;修改 Object 特性 (Object 特性值)
(defun PutProperty (obj prop nval)
(setq obj (ToObject obj)
nval (ToVB nval)
)
(if (vlax-property-available-p obj prop)
(vlax-put-property obj prop nval)
nil
)
)
;;........Load the type library for the specified Microsoft Application
;; "WORD" "EXCEL" "ACCESS" are allowable inputs, more could be added
(defun MS-TypeLibraryLoad (app / mspath)
(setq app (strcase app)
mspath "C:/Program Files/Microsoft Office/Office/"
)
(cond
((= app "WORD")
(if (equal nil docc-wd100Words)
(vlax-import-type-library
:tlb-filename
(strcat mspath "msword8.olb")
:methods-prefix
"docm-"
:properties-prefix
"docp-"
:constants-prefix
"docc-"
)
)
)
((= app "ACCESS")
(vlax-import-type-library
:tlb-filename
(strcat mspath "msacc8.olb")
:methods-prefix
"mdbm-"
:properties-prefix
"mdbp-"
:constants-prefix
"mdbc-"
)
)
((= app "EXCEL")
(vlax-import-type-library
:tlb-filename
(strcat mspath "excel8.olb")
:methods-prefix
"xlsm-"
:properties-prefix
"xlsp-"
:constants-prefix
"xlsc-"
)
)
(T
(prompt
(strcat "\n " app " is an invalid app name to load.")
)
)
)
)
;;******************************************************************
;;**** SUPPORT FUNCTIONS
;;******************************************************************
;;是否选择集
(defun pks? (x) (eq 'PICKSET (type x)))
;;测试实体
(defun nam? (x) (eq 'ENAME (type x)))
;;表测试
(defun lst? (x) (eq 'LIST (type x)))
;;实数表
(defun nbr*? (x)
(and (lst? x)
(apply 'and (mapcar 'numberp x))
)
)
;;点测试
(defun Point? (x)
(and (listp x)
(<= 2 (length x) 3)
(apply 'and (mapcar 'numberp x))
)
)
;;3D -> 2D 点
(defun XYof (x) (list (car x) (cadr x)))
;;2D -> 3D 点
(defun 2D>3Dpt (x)
(if (= 2 (length x))
(append x (list 0.0))
x
)
)
;;....Convert a PICKSET to a list of ENAMES
;; 选择集转换为实体表
(defun pks>nam (x / cnt lst)
(setq cnt 0
lst '()
)
(repeat (pkslength x)
(setq lst (cons (ssname x cnt) lst)
cnt (1+ cnt)
)
)
(reverse lst)
)
;;...get the true length of a PICKSET x
;; 选择集长
(defun pkslength (x)
(if x
(sslength x)
0
)
)

;;; This file contains VB data conversion functions that are necessary for 
;;; the function library functions to work properly. 
;;; Available functions are: 
;;; 
;;; (object? x) 
;;; (collection? x) 
;;; (safearray? x) 
;;; (variant? x) 
;;; (VariantArray? x) 
;;; (ToObject x) 
;;; (pks>obj x) 
;;; (ToVB x) 
;;; (ToLISP x) 
;;; (PtList=>VB ptlst dim) 
;;; (TableNames tblobj) 
;;; (GetProperty obj prop) 
;;; (PutProperty obj prop nval) 
;;; (MS-TypeLibraryLoad appname) 
 
(vl-load-com) 
 
;;; This function returns T if x is a VBA object 
;;测试是否是 VBA  Object 
(defun object? (x) (eq 'VLA-OBJECT (type x))) 
 
;;; This function returns T if x is a variant. 
;;测试是否是 Variant 
(defun variant? (x) (= 'variant (type x))) 
 
;;; This function returns T if x is a variant array. 
;;测试是否为 variant array 
(defun VariantArray? (x) 
  (and (variant? x) (>= (vlax-variant-type x) 8192)) 
) 
 
;;; This function returns T if x is a VBA collection. 
;;测试是否为 VBA collection 
(defun collection? (x) 
  (and (object? x) (vlax-property-available-p x 'Count)) 
) 
 
;;; This function returns T if x is a VBA safearray 
;;VBA Saferarray 测试 
(defun safearray? (x) (eq 'SAFEARRAY (type x))) 
 
 
;;; The function attempts to convert it's input into a VBA object. 
;;; - the ename of an entget list is returned as an object 
;;; - the first ename of a pickset is returned as an object 
;;; - an ename is returned as an object 
;;; - an object is returned as itself 
;;; - the first object in a collection is returned as an object 
;;; 
;; 转换为 VBA Object 
;; 实体名（entsel返回格式）转换为 Object 
;; 实体名 转换为Object 
;; SelectionSet 返回 第一个 Object 
;; Object 返回 自身 
;; 选择集 返回 第一个实体 
(defun ToObject        (x) 
  (cond 
    ((and (listp x) 
          (= (length x) 2) 
          (nam? (car x)) 
          (Point? (cadr x)) 
     ) 
     (ToObject (car x)) 
    ) 
    ((nam? x) (vlax-ename->vla-object x)) 
    ((collection? x) (vla-Item x 1)) 
    ((object? x) x) 
    ((pks? x) (ToObject (ssname x 0))) 
    (T nil) 
  ) 
) 
 
 
;;....Convert a PICKSET to a list of OBJECTs 
;;选择集转换为 Object 集合 
(defun pks>obj (x / cnt lst) 
  (mapcar 'vlax-ename->vla-object (pks>nam x)) 
) 
 
 
;;....convert Lisp data to VB 
;;转换Lisp数据为 VB 数据类型，支持 点、表（字串、整数、实数、Object、空表） 
;;                             t & nil 
;;                             整数、实数、字符、实体 
(defun ToVB (x / len typ lst) 
  (cond 
    ((Point? x) 
     (vlax-3D-point (2D>3Dpt (mapcar 'float x))) 
    ) 
    ((and (listp x) (apply 'eq (mapcar 'type x))) 
     (setq len (length x) 
           typ (type (car x)) 
           lst (vlax-make-safearray 
                 (cond 
                   ((= typ 'STR) vlax-vbString) 
                   ((= typ 'VLA-OBJECT) vlax-vbObject) 
                   ((= typ 'INT) vlax-vbInteger) 
                   ((= typ 'REAL) vlax-vbDouble) 
                   (T nil) 
                 ) 
                 '(0 . (1- len)) 
               ) 
     ) 
     (vlax-safearray-fill lst 'x) 
    ) 
    ((or (= x nil) (= x T) (= x '())) 
     (vlax-make-variant x vlax-vbBoolean) 
    ) 
    ((= 'INT (type x)) (vlax-make-variant x vbInteger)) 
    ((= 'REAL (type x)) (vlax-make-variant x vbDouble)) 
    ((= 'STR (type x)) (vlax-make-variant x vbString)) 
    ((= 'ENAME (type x)) (vlax-ename->vla-object x)) 
    (T x) 
  ) 
) 
 
;;..................Convert VB data to LISP data types 
;; VB 数据转换为 Lisp 数据类型 
(defun ToLISP (x) 
  (cond 
    ((safearray? x) (vlax-safearray->list x)) 
    ((VariantArray? x) 
     (vlax-safearray->list (vlax-variant-value x)) 
    ) 
    ((variant? x) (vlax-variant-value x)) 
    ((= x :vlax-true) T) 
    ((= x :vlax-false) nil) 
    (T x) 
  ) 
) 
 
 
 
;;; Take a list of points and convert them to a variant array of doubles suitable 
;;; for VB lwpolyline generation. Set the DIM argument to 2 or 3 depending on 
;;; whether you need a list for 2D or 3D lwpolylines. 
;; 点表转换为 VB variant array 支持 2D 、3D 点 
(defun PTLIST=>VB (ptlst dim / vbarr) 
  (setq        ptlst (mapcar '(lambda (x) 
                         (if (= 2 dim) 
                           (xyof X) 
                           (2D>3Dpt X) 
                         ) 
                       ) 
                      ptlst 
              ) 
        ptlst (apply 'append ptlst) 
        vbarr (vlax-make-safearray 
                vlax-vbDouble 
                (cons 0 (1- (length ptlst))) 
              )                                ;dimension the array 
  ) 
  (vlax-safearray-fill vbarr ptlst)        ;fill the array with doubles 
  (vlax-make-variant vbarr vbDouble)        ;return variant array with doubles 
) 
 
 
;;;Return all the name entries in a given table. 
;;返回 表内实体 
(defun TableNames (tableobj / lst cnt) 
  (setq cnt 0) 
  (repeat (vla-get-Count tableobj) 
    (setq lst (cons (vla-get-Name (vla-Item tableobj cnt)) lst) 
          cnt (1+ cnt) 
    ) 
  ) 
  (acad_strlsort lst) 
) 
 
 
;;........Retrieve information from an object 
;;获取实体特性 
(defun GetProperty (obj prop) 
  (setq obj (ToObject obj)) 
  (if (vlax-property-available-p obj prop) 
    (ToLISP (vlax-get-property obj prop)) 
    nil 
  ) 
) 
 
;;........Modify an object's properties 
;;修改 Object 特性 (Object 特性 值) 
(defun PutProperty (obj prop nval) 
  (setq        obj  (ToObject obj) 
        nval (ToVB nval) 
  ) 
  (if (vlax-property-available-p obj prop) 
    (vlax-put-property obj prop nval) 
    nil 
  ) 
) 
 
 
;;........Load the type library for the specified Microsoft Application 
;;        "WORD" "EXCEL" "ACCESS" are allowable inputs, more could be added 
(defun MS-TypeLibraryLoad (app / mspath) 
  (setq        app    (strcase app) 
        mspath "C:/Program Files/Microsoft Office/Office/" 
  ) 
  (cond 
    ((= app "WORD") 
     (if (equal nil docc-wd100Words) 
       (vlax-import-type-library 
         :tlb-filename 
         (strcat mspath "msword8.olb") 
         :methods-prefix 
         "docm-" 
         :properties-prefix 
         "docp-" 
         :constants-prefix 
         "docc-" 
       ) 
     ) 
    ) 
    ((= app "ACCESS") 
     (vlax-import-type-library 
       :tlb-filename 
       (strcat mspath "msacc8.olb") 
       :methods-prefix 
       "mdbm-" 
       :properties-prefix 
       "mdbp-" 
       :constants-prefix 
       "mdbc-" 
     ) 
    ) 
    ((= app "EXCEL") 
     (vlax-import-type-library 
       :tlb-filename 
       (strcat mspath "excel8.olb") 
       :methods-prefix 
       "xlsm-" 
       :properties-prefix 
       "xlsp-" 
       :constants-prefix 
       "xlsc-" 
     ) 
    ) 
    (T 
     (prompt 
       (strcat "\n " app " is an invalid app name to load.") 
     ) 
    ) 
  ) 
) 
 
 
 
;;****************************************************************** 
;;****          SUPPORT FUNCTIONS 
;;****************************************************************** 
;;是否选择集 
(defun pks? (x) (eq 'PICKSET (type x))) 
;;测试实体 
(defun nam? (x) (eq 'ENAME (type x))) 
;;表测试 
(defun lst? (x) (eq 'LIST (type x))) 
;;实数表 
(defun nbr*? (x) 
  (and (lst? x) 
       (apply 'and (mapcar 'numberp x)) 
  ) 
) 
;;点测试 
(defun Point? (x) 
  (and (listp x) 
       (<= 2 (length x) 3) 
       (apply 'and (mapcar 'numberp x)) 
  ) 
) 
;;3D -> 2D 点 
(defun XYof (x) (list (car x) (cadr x))) 
;;2D -> 3D 点 
(defun 2D>3Dpt (x) 
  (if (= 2 (length x)) 
    (append x (list 0.0)) 
    x 
  ) 
) 
 
;;....Convert a PICKSET to a list of ENAMES 
;; 选择集转换为实体表 
(defun pks>nam (x / cnt lst) 
  (setq        cnt 0 
        lst '() 
  ) 
  (repeat (pkslength x) 
    (setq lst (cons (ssname x cnt) lst) 
          cnt (1+ cnt) 
    ) 
  ) 
  (reverse lst) 
) 
 
;;...get the true length of a PICKSET x 
;; 选择集长 
(defun pkslength (x) 
  (if x 
    (sslength x) 
    0 
  ) 
)

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

[转贴]：搜到的一些 vblibrary 函数

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子