[密技]：VBA与VL的数据传输

lijiao · 发表于 2003-4-29 11:59:05

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

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

×

VBA与VL的数据传输是双向的，这几个函数可以很方便地实现。
1、VL读取：(get_xrdata dicname xrname)
功能：读取XR数据
变量：DICNAME 字典名，为字符串
   XRNAME XRECODER名，为字符串
返回值：读取成功，返回一个列表，如((1 . "asdhf") (10 23.4 432.5 34.0) (40 . 45.2))；读取失败，返回NIL。
2、VL传出：(set_xrdata dicname xrname xrdata YES_or_no)
功能：传出XR数据
变量：DICNAME 字典名，为字符串
   XRNAME XRECODER名，为字符串
   XRDATA 传输的数据，为列表，格式入下
   （数据1 数据2 数据3  ... 数据n）
   有效的数据有如下几种：
   整数
   实数
   字符串
   列表（此时，列表中的元素只能为整数或实数）
   YES_or_no 追加开关，如果为T，则将新数据放在原有数据的前面；如果为NIL，则用新数据覆盖原有数据。
返回值：传出成功，返回T；传出失败，返回NIL。
3、VBA读入：Get_Xrdata
功能：读取XR数据
变量：DICNAME 字典名，为字符串
   XRNAME XRECODER名，为字符串
返回值：读取成功，返回XR数据，为变体；读取失败，返回FALSE。
4、VBA传出：set_XRDATA
功能：传出XR数据
变量：DICNAME 字典名，为字符串
   XRNAME XRECODER名，为字符串
   XRDATA 传输的数据，为数组，数组中的有效数据有如下几种：
   整数和长整型数
   单精度数和双精度数
   字符串
   数组（此时，数组中的元素只能为整数、长整型数、单精度数和双精度数）
   YN 追加开关，如果为TRUE，则将新数据放在原有数据的前面；如果为FALSE，则用新数据覆盖原有数据。
返回值：传出成功，返回T；传出失败，返回NIL。

[FONT=courier new]
Public Sub set_XRDATA(DicName As String, XrName As String, Xrdata As Variant, YN As Boolean)
Dim cs_i As Long
Dim XrType As Variant
Dim MyXr As AcadXRecord
Dim cs_J As Long
If VarType(Xrdata) And vbArray = vbArray Then
ReDim XrType(LBound(Xrdata) To UBound(Xrdata)) As Integer
For cs_i = LBound(Xrdata) To UBound(Xrdata)
If VarType(Xrdata(cs_i)) > 8000 Then
For cs_J = LBound(Xrdata(cs_i)) To UBound(Xrdata(cs_i))
Select Case VarType(Xrdata(cs_i)(cs_J))
Case vbInteger, vbLong, vbSingle, vbDouble
Case Else
Exit Sub
End Select
Next cs_J
XrType(cs_i) = 10
Else
Select Case VarType(Xrdata(cs_i))
Case vbInteger, vbLong
XrType(cs_i) = 90
Case vbSingle, vbDouble
XrType(cs_i) = 40
Case vbString
Case Else
Exit Sub
End Select
End If
Next cs_i
Dim XrData1 As Variant
XrData1 = Xrdata
Set MyXr = GetXr(DicName, XrName)
If YN = True Then
Dim OldType As Variant
Dim OldData As Variant
On Error Resume Next
MyXr.GetXRecordData OldType, OldData
If VarType(OldType) <> vbEmpty Then
For cs_i = 0 To UBound(OldType)
ReDim Preserve XrType(UBound(XrType) + 1)
ReDim Preserve XrData1(UBound(XrData1) + 1)
XrType(UBound(XrType)) = OldType(cs_i)
XrData1(UBound(XrData1)) = OldData(cs_i)
Next cs_i
End If
End If
MyXr.SetXRecordData XrType, XrData1
End If
End Sub
Public Function GetDic(DicName As String) As AcadDictionary
Dim MyDic As AcadDictionary
On Error Resume Next
Set MyDic = ThisDrawing.Dictionaries.Item(DicName)
If Err <> 0 Then
Err.Clear
Set MyDic = ThisDrawing.Dictionaries.Add(DicName)
End If
Set GetDic = MyDic
End Function
Public Function GetXr(DicName As String, XrName As String) As AcadXRecord
Dim MyDic As AcadDictionary
Set MyDic = GetDic(DicName)
Dim MyXr As AcadXRecord
On Error Resume Next
Set MyXr = MyDic.GetObject(XrName)
If Err <> 0 Then
Err.Clear
Set MyXr = MyDic.AddXRecord(XrName)
End If
Set GetXr = MyXr
End Function
Public Function Get_Xrdata(DicName As String, XrName As String) As Variant
Dim MyXr As AcadXRecord
Dim XrType As Variant
Dim Xrdata As Variant
Set MyXr = GetXr(DicName, XrName)
MyXr.GetXRecordData XrType, Xrdata
Get_Xrdata = Xrdata
End Function
(defun CADAPP ( / ) (vlax-get-acad-object))
(defun caddoc ( / ) (vla-get-ActiveDocument (cadapp)))
(defun list_to_dxf (lst / biaoji mytype mydata element subelement)
(if (= (type lst) 'list)
(progn
(setq biaoji t
mytype '()
mydata '()
)
(foreach element lst
(cond
((= (type element) 'INT)
(setq mytype (cons 90 mytype))
)
((= (type element) 'real)
(setq mytype (cons 40 mytype))
)
((= (type element) 'STR)
(setq mytype (cons 1 mytype))
)
((= (type element) 'list)
(setq mytype (cons 10 mytype))
(foreach subelement element
(if (and (/= (type subelement) 'int)
(/= (type subelement) 'real)
)
(setq biaoji nil)
)
)
(if biaoji
(setq element (vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length element) 1))
)
element
)
)
)
)
(t (setq biaoji nil))
)
(if biaoji
(setq mydata (cons (vlax-make-variant element) mydata))
)
)
(if biaoji
(setq lst (list (reverse mytype) (reverse mydata)))
)
)
)
)
(defun get_dic (dicname / )
(if (not (caddic dicname))
(vla-add (vla-get-Dictionaries (caddoc)) dicname)
(caddic dicname)
)
)
(defun get_xr (dicname xrname / mydic myxr)
(setq mydic (get_dic dicname))
(if (vl-catch-all-error-p (setq myxr (vl-catch-all-apply 'vla-GetObject (list mydic xrname))))
(setq myxr (vla-AddXRecord mydic xrname))
)
(eval myxr)
)
(defun set_xrdata (dicname xrname xrdata YES_or_no / mytype olddata x)
(if (setq xrdata (list_to_dxf xrdata))
(progn
(setq mytype (car xrdata) xrdata (cadr xrdata))
(if (and (setq olddata (get_xrdata dicname xrname)) yes_or_no)
(progn
(setq olddata (list_to_dxf (mapcar '(lambda (x) (cdr x)) olddata)))
(setq oldtype (reverse (car olddata)) olddata (reverse (cadr olddata)))
(foreach x oldtype (setq mytype (cons x mytype)))
(foreach x olddata (setq xrdata (cons x xrdata)))
)
)
(setq mytype (vlax-safearray-fill (vlax-make-safearray vlax-vbInteger (cons 0 (- (length mytype) 1))) mytype)
xrdata (vlax-safearray-fill (vlax-make-safearray vlax-vbVariant (cons 0 (- (length xrdata) 1))) xrdata)
)
(vla-SetXRecordData (get_xr dicname xrname) mytype xrdata)
(eval t)
)
)
)
(defun get_xrdata (dicname xrname / mytype mydata mydatatemp element x y)
(vla-GetXRecordData (get_xr dicname xrname) 'mytype 'mydata)
(if mytype
(progn
(setq mytype (vlax-safearray->list mytype)
mydata (vlax-safearray->list mydata)
)
(setq mydatatemp '())
(foreach element mydata
(setq mydatatemp (cons (vlax-variant-value element) mydatatemp))
)
(setq mydata mydatatemp
mydatatemp '()
)
(foreach element mydata
(if (= (type element) 'safearray)
(setq mydatatemp
(cons (vlax-safearray->list element) mydatatemp)
)
(setq mydatatemp (cons element mydatatemp))
)
)
(setq mydata mydatatemp)
(mapcar '(lambda (x y) (cons x y)) mytype mydata)
)
)
)
[/FONT]

[FONT=courier new] 
Public Sub set_XRDATA(DicName As String, XrName As String, Xrdata As Variant, YN As Boolean) 
Dim cs_i As Long 
Dim XrType As Variant 
Dim MyXr As AcadXRecord 
Dim cs_J As Long 
 
 
   If VarType(Xrdata) And vbArray = vbArray Then 
      ReDim XrType(LBound(Xrdata) To UBound(Xrdata)) As Integer 
      For cs_i = LBound(Xrdata) To UBound(Xrdata) 
      If VarType(Xrdata(cs_i)) > 8000 Then 
         For cs_J = LBound(Xrdata(cs_i)) To UBound(Xrdata(cs_i)) 
            Select Case VarType(Xrdata(cs_i)(cs_J)) 
               Case vbInteger, vbLong, vbSingle, vbDouble 
               Case Else 
                  Exit Sub 
            End Select 
         Next cs_J 
         XrType(cs_i) = 10 
      Else 
         Select Case VarType(Xrdata(cs_i)) 
         Case vbInteger, vbLong 
            XrType(cs_i) = 90 
         Case vbSingle, vbDouble 
            XrType(cs_i) = 40 
         Case vbString 
         Case Else 
            Exit Sub 
         End Select 
      End If 
      Next cs_i 
      Dim XrData1 As Variant 
      XrData1 = Xrdata 
      Set MyXr = GetXr(DicName, XrName) 
      If YN = True Then 
         Dim OldType As Variant 
         Dim OldData As Variant 
         On Error Resume Next 
          
         MyXr.GetXRecordData OldType, OldData 
         If VarType(OldType) <> vbEmpty Then 
            For cs_i = 0 To UBound(OldType) 
               ReDim Preserve XrType(UBound(XrType) + 1) 
               ReDim Preserve XrData1(UBound(XrData1) + 1) 
               XrType(UBound(XrType)) = OldType(cs_i) 
               XrData1(UBound(XrData1)) = OldData(cs_i) 
            Next cs_i 
         End If 
      End If 
      MyXr.SetXRecordData XrType, XrData1 
    End If 
End Sub 
 
 
Public Function GetDic(DicName As String) As AcadDictionary 
   Dim MyDic As AcadDictionary 
   On Error Resume Next 
   Set MyDic = ThisDrawing.Dictionaries.Item(DicName) 
   If Err <> 0 Then 
      Err.Clear 
      Set MyDic = ThisDrawing.Dictionaries.Add(DicName) 
   End If 
   Set GetDic = MyDic 
End Function 
Public Function GetXr(DicName As String, XrName As String) As AcadXRecord 
   Dim MyDic As AcadDictionary 
   Set MyDic = GetDic(DicName) 
   Dim MyXr As AcadXRecord 
   On Error Resume Next 
   Set MyXr = MyDic.GetObject(XrName) 
   If Err <> 0 Then 
      Err.Clear 
      Set MyXr = MyDic.AddXRecord(XrName) 
   End If 
   Set GetXr = MyXr 
End Function 
 
 
Public Function Get_Xrdata(DicName As String, XrName As String) As Variant 
   Dim MyXr As AcadXRecord 
   Dim XrType As Variant 
   Dim Xrdata As Variant 
   Set MyXr = GetXr(DicName, XrName) 
   MyXr.GetXRecordData XrType, Xrdata 
   Get_Xrdata = Xrdata 
End Function 
 
 
(defun CADAPP ( / )  (vlax-get-acad-object)) 
(defun caddoc ( / ) (vla-get-ActiveDocument (cadapp))) 
 
 
(defun list_to_dxf (lst / biaoji mytype mydata element subelement) 
  (if (= (type lst) 'list) 
    (progn 
      (setq biaoji t 
            mytype '() 
            mydata '() 
      ) 
      (foreach element lst 
        (cond 
          ((= (type element) 'INT) 
           (setq mytype (cons 90 mytype)) 
          ) 
          ((= (type element) 'real) 
           (setq mytype (cons 40 mytype)) 
          ) 
          ((= (type element) 'STR) 
           (setq mytype (cons 1 mytype)) 
          ) 
          ((= (type element) 'list) 
           (setq mytype (cons 10 mytype)) 
           (foreach subelement element 
             (if (and (/= (type subelement) 'int) 
                      (/= (type subelement) 'real) 
                 ) 
               (setq biaoji nil) 
             ) 
           ) 
           (if biaoji 
             (setq element (vlax-safearray-fill 
                             (vlax-make-safearray 
                               vlax-vbDouble 
                               (cons 0 (- (length element) 1)) 
                             ) 
                             element 
                           ) 
             ) 
           ) 
          ) 
          (t (setq biaoji nil)) 
        ) 
        (if biaoji 
          (setq mydata (cons (vlax-make-variant element) mydata)) 
        ) 
      ) 
      (if biaoji 
        (setq lst (list (reverse mytype) (reverse mydata))) 
      ) 
    ) 
  ) 
) 
 
(defun get_dic (dicname / ) 
  (if (not  (caddic dicname)) 
     (vla-add (vla-get-Dictionaries (caddoc)) dicname) 
    (caddic dicname) 
    ) 
  ) 
(defun get_xr (dicname xrname / mydic myxr) 
  (setq mydic (get_dic dicname)) 
  (if (vl-catch-all-error-p (setq myxr (vl-catch-all-apply 'vla-GetObject (list mydic xrname)))) 
    (setq myxr (vla-AddXRecord mydic xrname)) 
    ) 
  (eval myxr) 
  ) 
(defun set_xrdata (dicname xrname xrdata YES_or_no / mytype olddata x) 
  (if (setq xrdata (list_to_dxf xrdata)) 
    (progn 
      (setq mytype (car xrdata) xrdata (cadr xrdata)) 
      (if (and (setq olddata (get_xrdata dicname xrname)) yes_or_no) 
        (progn 
          (setq olddata (list_to_dxf (mapcar '(lambda (x) (cdr x)) olddata))) 
          (setq oldtype (reverse (car olddata)) olddata (reverse (cadr olddata))) 
          (foreach x  oldtype (setq mytype (cons x mytype))) 
          (foreach x  olddata (setq xrdata (cons x xrdata))) 
          ) 
        ) 
      (setq mytype (vlax-safearray-fill (vlax-make-safearray vlax-vbInteger  (cons 0 (- (length mytype) 1)))  mytype) 
            xrdata (vlax-safearray-fill (vlax-make-safearray vlax-vbVariant   (cons 0 (- (length xrdata) 1)))  xrdata) 
            ) 
      (vla-SetXRecordData (get_xr dicname xrname) mytype xrdata) 
      (eval t) 
      ) 
    ) 
  ) 
(defun get_xrdata (dicname xrname / mytype mydata mydatatemp element x y) 
  (vla-GetXRecordData (get_xr dicname xrname) 'mytype 'mydata) 
  (if mytype 
    (progn 
      (setq mytype (vlax-safearray->list mytype) 
            mydata (vlax-safearray->list mydata) 
      ) 
      (setq mydatatemp '()) 
      (foreach element mydata 
        (setq mydatatemp (cons (vlax-variant-value element) mydatatemp)) 
      ) 
      (setq mydata     mydatatemp 
            mydatatemp '() 
      ) 
      (foreach element mydata 
        (if (= (type element) 'safearray) 
          (setq        mydatatemp 
                 (cons (vlax-safearray->list element) mydatatemp) 
          ) 
          (setq mydatatemp (cons element mydatatemp)) 
        ) 
      ) 
      (setq mydata mydatatemp) 
      (mapcar '(lambda (x y) (cons x y)) mytype mydata) 
    ) 
  ) 
) 
 
 
  [/FONT]

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

[密技]：VBA与VL的数据传输

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

浏览过的版块