找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 7186|回复: 8

[文章]:关于VB和VBA开发CAD的一些知识

  [复制链接]

已领礼包: 181个

财富等级: 日进斗金

发表于 2003-4-29 11:55:10 | 显示全部楼层 |阅读模式

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

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

×
关于VB和VBA开发CAD的一些知识(一)
编者:尹凡(efan2000)  时间:2003年4月

1、如何在 VB 中连接 AutoCAD。
启动 VB ,引用 AutoCAD 类型库。操作步骤:从“工程”菜单中选择“引用”选项,启动“引用”对话框。在“引用”对话框中,选择 AutoCAD 类型库,然后单击“确定”。
定义模块级变量 AutoCAD 应用程序 (acadApp) 和当前的文档 (acadDoc)。
如果 AutoCAD 正在运行,使用 GetObject 函数将检索 AutoCAD Application 对象。如果 AutoCAD 没有运行,使用 CreateObject 函数试图创建一个 AutoCAD Application 对象。如果创建成功,会启动 AutoCAD;如果失败,则会发生错误。
同时运行多个 AutoCAD 任务时,GetObject 函数会返回 Windows 运行对象表中的第一个 AutoCAD 实例。
要显示 AutoCAD 图形窗口,需要将 AutoCAD 应用程序的 Visible 特性设置为 TRUE。  
使用 acadDoc 变量引用当前的 AutoCAD 图形。
示例:
Dim acadApp As AcadApplication
Dim acadDoc as AcadDocument
Sub ConnectToAcad()
   
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    If Err Then
        Err.Clear
        Set acadApp = CreateObject("AutoCAD.Application")
        If Err Then End
End If
acadApp.Visible = True
    Set acadDoc = acadApp.ActiveDocument
End Sub

2、如何使 VB 开发的程序不依赖于 AutoCAD 的版本。
启动 VB ,定义模块级变量 AutoCAD 应用程序 (acadApp) 和当前的文档 (acadDoc)。
如果 AutoCAD 正在运行,使用 GetObject 函数将检索 AutoCAD Application 对象。如果 AutoCAD 没有运行,使用 CreateObject 函数试图创建一个 AutoCAD Application 对象。如果创建成功,会启动 AutoCAD;如果失败,则会发生错误。
同时运行多个 AutoCAD 任务时,GetObject 函数会返回 Windows 运行对象表中的第一个 AutoCAD 实例。
要显示 AutoCAD 图形窗口,需要将 AutoCAD 应用程序的 Visible 特性设置为 TRUE。  
使用 acadDoc 变量引用当前的 AutoCAD 图形。
示例:
Dim acadApp As Object
Dim acadDoc as Object
Sub ConnectToAcad()
   
    On Error Resume Next
    Set acadApp = GetObject(, "AutoCAD.Application")
    If Err Then
        Err.Clear
        Set acadApp = CreateObject("AutoCAD.Application")
        If Err Then End
End If
acadApp.Visible = True
    Set acadDoc = acadApp.ActiveDocument
End Sub
与第一个问题相比较,可以看出,不引用具体的类型库以及使用通用的对象类型就可以达到通用性。

3、前期绑定和后期绑定
要创建一个使用前期绑定方式的对象变量,也就是说,在程序编译时就完成绑定,则对象变量在声明时应指定类 ID,如:Dim acadApp As AcadApplication。
使用 As Object 子句声明对象变量,可以创建一个能包含任何类型对象引用的变量。不过,该变量访问对象是后期绑定的,也就是说,绑定在程序运行时才进行,如:Dim acadApp As Object。
前期绑定的变量引用可以提供更好的性能,但该变量只能存放声明中所指定的类的引用。
而后期绑定的变量引用可以提供更好的通用性。

4、依赖于版本和独立于版本
如果 CreateObject 或 GetObject 函数使用的 ProgID 没有附加版本号,那么是独立于版本的,否则是依赖于版本的。例如,如果使用的是 CreateObject,则 CreateObject ("AutoCAD.Application") 是独立于版本的,而 CreateObject ("AutoCAD.Application.15") 是依赖于版本的。

5、VB 代码到 VBA 代码的转换
在 VBA 的 IDE 环境中,使用“导入文件”将要转换的 VB 工程的模块、类模块以及窗体文件一一导入。接着将 VB 代码中所有的当前的文档 (acadDoc) 变量替换为 ThisDrawing,而AutoCAD 应用程序 (acadApp) 变量替换为 Application。同时删除定义的 AutoCAD 应用程序 (acadApp) 和当前的文档 (acadDoc) 变量,删除与 AutoCAD 应用程序连接的代码。注意:要转换 VB 代码的窗体部分,则窗体必须是用 UserForm 创建的。

6、图形对象和非图形对象
图形对象(也称为图元、实体对象)是组成图形的可见对象(例如直线、圆、光栅图像等)。非图形对象是指属于图形的一部分但不可见的(提示性的)对象,例如 Layers、 Linetypes、 DimStyles、 SelectionSets 等等。要创建这些对象,可使用 Add 方法。每一个对象都有用于特定目的的方法和特性,都有设置和检索扩展数据以及删除自己的方法。

(未完待续)
如果大家有什么好的建议和要求,可以提出来,也希望大家来共同完善和改进。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 181个

财富等级: 日进斗金

 楼主| 发表于 2003-4-30 11:36:34 | 显示全部楼层

[文章]:关于VB和VBA开发CAD的一些知识(二)

关于VB和VBA开发CAD的一些知识(二)
编者:尹凡(efan2000)  时间:2003年4月

7、创建图形对象
图形对象是在 ModelSpace 集合、 PaperSpace 集合或 Block 对象中创建的。
使用变量 moSpace 设置为当前模型空间。
本例使用 AddLightweightPolyline 方法创建一条分为两段的简单多段线,其端点坐标值分别是 (2,4)、(4,2) 和 (6,4)。
Dim moSpace As AcadModelSpace
Set moSpace = acadDoc.ModelSpace
Sub AddLightWeightPolyline()
    Dim plineObj As AcadLWPolyline
    Dim points(0 To 5) As Double
   
    ' 定义二维多段线的点
    points(0) = 2: points(1) = 4
    points(2) = 4: points(3) = 2
    points(4) = 6: points(5) = 4
   
    ' 在模型空间中创建一个优化多段线对象
    Set plineObj = moSpace.AddLightWeightPolyline(points)
End Sub

8、变体型变量(Variant)和数组
变体型变量是一种特殊的数据类型,可以包含任何类型的数据,固定长度的字符串数据和用户定义的类型除外。变量还可以包含特殊值 Empty、Error、Nothing 和 NULL。可以使用 VarType 或 TypeName 函数来确定如何处理变量中的数据。
变体型变量用于和 AutoCAD 传递数组数据。这表示使用对象的属性和方法时,如果输入数组作为参数,那么 VBA 自动将数组转换为变体型变量。此外,从函数或者对象的属性返回的数组数据也将自动转换为变体型变量进行处理。
对第七个问题进行分析:points数组作为参数时,将自动转换成变体型变量,然后才进行生成多段线的操作。同时,如果返回点坐标的数组时,必须先定义一个变体型变量。
示例:
Dim moSpace As AcadModelSpace
Set moSpace = acadDoc.ModelSpace
Sub AddLightWeightPolyline()
    Dim plineObj As AcadLWPolyline
    Dim points(0 To 5) As Double
   
    ' 定义二维多段线的点
    points(0) = 2: points(1) = 4
    points(2) = 4: points(3) = 2
    points(4) = 6: points(5) = 4
   
    ' 在模型空间中创建一个优化多段线对象
Set plineObj = moSpace.AddLightWeightPolyline(points)

‘ 等效于
‘Dim vpoints As Variant
‘Vpoints=points
‘Set plineObj = moSpace.AddLightWeightPolyline(vpoints)

‘ 返回多段线的从标数组
‘Dim vpoints As Variant
‘vpoints = plineObj.Coordinates

‘ 比较 vpoints 和 points,它们的维数相同,元素个数相同,值也相同。
End Sub

9、系统变量
Document 对象提供了 SetVariable 和 GetVariable 方法,分别用于设置和检索 AutoCAD 系统变量。例如,要将某个整数指定给 MAXSORT 系统变量,可设置为:acadDoc.SetVariable "MAXSORT", 100。
针对第七个问题,如果想让多段线的起点从上一次绘图的终点开始。那么可以检索 LASTPOINT系统变量。
示例:
Dim moSpace As AcadModelSpace
Set moSpace = acadDoc.ModelSpace
Sub AddLightWeightPolyline()
Dim plineObj As AcadLWPolyline

‘ 返回上一次给图最后输入的点坐标
Dim pt as Variant
Pt=acadDoc.GetVariable(“LASTPOINT”)

    Dim points(0 To 5) As Double
   
    ' 定义二维多段线的点
    points(0) = pt(0): points(1) = pt(1)
    points(2) = 4: points(3) = 2
    points(4) = 6: points(5) = 4
   
    ' 在模型空间中创建一个优化多段线对象
    Set plineObj = moSpace.AddLightWeightPolyline(points)
End Sub

(未完待续)
如果大家有什么好的建议和要求,可以提出来,也希望大家来共同完善和改进。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 181个

财富等级: 日进斗金

 楼主| 发表于 2003-5-6 11:37:12 | 显示全部楼层

[文章]:关于VB和VBA开发CAD的一些知识(三)

关于VB和VBA开发CAD的一些知识(三)
编者:尹凡(efan2000) 时间:2003年5月

10、图形数据和属性数据
图形对象(也称为图元)是组成图形的可见对象(例如直线、圆、光栅图像等)。属性数据是保存图形对象的信息,比如圆可以代表电杆,那么圆就要保存电杆的信息如类型、地址、高度等。

11、随图形一起保存于文件的内部属性数据和保存于数据库的外部属性数据
属性数据可以保存于文件内部,比如扩展数据和扩展记录数据,它是随图形对象一起保存的,删除图形对象,将自动清除属性数据,因而管理方便。属性数据也可以保存于外部数据库,常见的有文件,如文本文件、Excel文件等,还有数据库,如Access、Oracle等,它需要人工手动进行管理,但数据的存取高效,通常是通过句柄来实现它们之间的联结。

12、图形对象的句柄和ID号
图形对象的句柄在一个文档内是唯一的、递增的、永久的,保存于图形数据库,而图形对象的ID号在当前打开的应用程序的多文档内是唯一的,但是是暂时的、变化的,它不保存于图形数据库,而是每次打开时重新生成一次,因而每次打开时的值也是不一样的。
对于单文档的操作,可以使用Handle来返回图形对象的句柄,而用HandleToObject来获取图形对象。而对于多文档的操作,可以使用ObjectID来返回图形对象的ID号,而用ObjectIDToObject来获取图形对象。

13、扩展数据和扩展记录数据
可以将扩展数据(XData)和扩展记录数据(XRecordData)用作链接信息与图形中对象的方式。扩展数据和扩展记录数据的区别是:扩展数据有16K存储空间的限制,并且使用1000及以上的组码值,而扩展记录数据则没有空间和顺序的限制,并且组码在1000以下。还有一个不同之处是可以在选择集中操作扩展数据。ACAD提供了SetXData和GetXData的函数来设置和返回扩展数据,通常扩展数据需要提供一个已经注册的应用程序(RegisteredApplication)名称作为不同程序之间的数据区分。ACAD也提供了SetXRecordData和GetXRecordData的函数来设置和返回扩展记录数据,但是由于扩展记录数据是保存于扩展词典(ExtensionDictionary)中的,因而要用HasExtensionDictionary来判断是否包含扩展词典,而用GetExtensionDictionary来返回扩展词典,如不存在,它就会创建一个。再通过扩展词典的GetObject来返回扩展记录对象,AddXRecord添加一个扩展记录对象。


  1.   [FONT=courier new]
  2. 示例:
  3. Sub Example_XData()
  4.     ' 这个例子创建一条直线,并且添加扩展数据
  5.     ' 创建直线
  6.     Dim lineObj As AcadLine
  7.     Dim startPt(0 To 2) As Double, endPt(0 To 2) As Double
  8.     startPt(0) = 1#: startPt(1) = 1#: startPt(2) = 0#
  9.     endPt(0) = 5#: endPt(1) = 5#: endPt(2) = 0#
  10.     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
  11.     ' 初始化所有的扩展数据。注意第一个值必须是应用程序名称,而它的组码必须是1001。
  12.     Dim DataType(0 To 9) As Integer
  13.     Dim Data(0 To 9) As Variant
  14.     Dim reals3(0 To 2) As Double
  15.     Dim worldPos(0 To 2) As Double
  16.    
  17.     DataType(0) = 1001: Data(0) = "Test_Application"
  18.     DataType(1) = 1000: Data(1) = "This is a test for xdata"
  19.     DataType(2) = 1003: Data(2) = "0"                   ' 层
  20.     DataType(3) = 1040: Data(3) = 1.23479137438413E+40  ' 实数
  21.     DataType(4) = 1041: Data(4) = 1237324938            ' 距离
  22.     DataType(5) = 1070: Data(5) = 32767                 ' 16位整数
  23.     DataType(6) = 1071: Data(6) = 32767                 ' 32位整数
  24.     DataType(7) = 1042: Data(7) = 10                    ' 比例因子
  25.     reals3(0) = -2.95: reals3(1) = 100: reals3(2) = -20
  26.     DataType(8) = 1010: Data(8) = reals3                ' 实数
  27.     worldPos(0) = 4: worldPos(1) = 400.99999999: worldPos(2) = 2.798989
  28.     DataType(9) = 1011: Data(9) = worldPos              ' world space position
  29.     ' 在直线上附着扩展数据
  30.     lineObj.SetXData DataType, Data
  31.    
  32.     ' 返回直线的扩展数据
  33.     Dim xdataOut As Variant
  34.     Dim xtypeOut As Variant
  35.     lineObj.GetXData "", xtypeOut, xdataOut
  36. End Sub

  37. 示例:
  38. Sub Example_XRecordData()
  39.     ' 这个例子当扩展记录对象不存在时创建一个新的扩展记录对象,并且添加扩展记录数据。
  40.     Dim TrackingDictionary As AcadDictionary, TrackingXRecord As AcadXRecord
  41.     Dim XRecordDataType As Variant, XRecordData As Variant
  42.     Dim ArraySize As Long, iCount As Long
  43.     Dim DataType As Integer, Data As String, msg As String
  44.     ' Unique identifiers to distinguish our XRecordData from other XRecordData
  45.     Const TYPE_STRING = 1
  46.     Const TAG_DICTIONARY_NAME = "ObjectTrackerDictionary"
  47.     Const TAG_XRECORD_NAME = "ObjectTrackerXRecord"
  48.     ' 连接扩展词典
  49.     On Error GoTo CREATE
  50.     Set TrackingDictionary = ThisDrawing.Dictionaries(TAG_DICTIONARY_NAME)
  51.     Set TrackingXRecord = TrackingDictionary.GetObject(TAG_XRECORD_NAME)
  52.     On Error GoTo 0
  53.     ' 返回当前的扩展记录数据
  54.     TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
  55.     ' If we don't have an array already then create one
  56.     If VarType(XRecordDataType) And vbArray = vbArray Then
  57.         ArraySize = UBound(XRecordDataType) + 1       ' 返回扩展记录数据的元素个数
  58.         ArraySize = ArraySize + 1                        ' Increase to hold new data
  59.         ReDim Preserve XRecordDataType(0 To ArraySize)
  60.         ReDim Preserve XRecordData(0 To ArraySize)
  61.     Else
  62.         ArraySize = 0
  63.         ReDim XRecordDataType(0 To ArraySize) As Integer
  64.         ReDim XRecordData(0 To ArraySize) As Variant
  65.     End If
  66.     ' 添加新的扩展记录数据
  67.     ' For this sample we only append the current time to the XRecord
  68.     XRecordDataType(ArraySize) = TYPE_STRING: XRecordData(ArraySize) = CStr(Now)
  69.     TrackingXRecord.SetXRecordData XRecordDataType, XRecordData
  70.     ' Read back all XRecordData entries
  71.     TrackingXRecord.GetXRecordData XRecordDataType, XRecordData
  72.     ArraySize = UBound(XRecordDataType)
  73.     ' Retrieve and display stored XRecordData
  74.     For iCount = 0 To ArraySize
  75.         ' Get information for this element
  76.         DataType = XRecordDataType(iCount)
  77.         Data = XRecordData(iCount)
  78.         If DataType = TYPE_STRING Then
  79.             msg = msg & Data & vbCrLf
  80.         End If
  81.     Next
  82.     MsgBox "The data in the XRecord is: " & vbCrLf & vbCrLf & msg, vbInformation
  83.     Exit Sub

  84. CREATE:
  85.     ' Create the entities that hold our XRecordData
  86.     If TrackingDictionary Is Nothing Then  ' Make sure we have our tracking object
  87.         Set TrackingDictionary = ThisDrawing.Dictionaries.Add(TAG_DICTIONARY_NAME)
  88.         Set TrackingXRecord = TrackingDictionary.AddXRecord(TAG_XRECORD_NAME)
  89.    End If
  90.      Resume
  91. End Sub
  92.   [/FONT]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 181个

财富等级: 日进斗金

 楼主| 发表于 2003-5-6 11:48:34 | 显示全部楼层
以下是一些在开发人员手册中的关于扩展数据的示例。

  1.   [FONT=courier new]

  2. 将扩展数据指定给选择集中的所有对象

  3. 本例提示用户选择图形中的对象,然后将选定的对象置于选择集中,并且指定的扩展数据将附着到该选择集中的所有对象。

  4. Sub Ch10_AttachXDataToSelectionSetObjects()
  5.     ' 创建选择集
  6.     Dim sset As Object
  7.     Set sset = ThisDrawing.SelectionSets.Add("SS1")
  8.    
  9.     ' 提示用户选择对象
  10.     sset.SelectOnScreen
  11.    
  12.     ' 定义扩展数据
  13.     Dim appName As String, xdataStr As String
  14.     appName = "MY_APP"
  15.     xdataStr = "This is some xdata"
  16.     Dim xdataType(0 To 1) As Integer
  17.     Dim xdata(0 To 1) As Variant
  18.    
  19.     ' 为每个数组定义值
  20.     '1001 指示 appName
  21.     xdataType(0) = 1001
  22.     xdata(0) = appName
  23.     '1000 指示字符串值
  24.     xdataType(1) = 1000
  25.     xdata(1) = xdataStr
  26.    
  27.     ' 遍历选择集中的所有图元
  28.     ' 将扩展数据设置和指定给每个图元
  29.     Dim ent As Object
  30.     For Each ent In sset
  31.         ent.SetXData xdataType, xdata
  32.     Next ent
  33. End Sub

  34. 查看选择集中所有对象的扩展数据

  35. 本例显示上例所附着的扩展数据。如果附着的扩展数据不是字符串(类型 1000)类型,则需要修改此代码。

  36. Sub Ch10_ViewXData()
  37.     ' 查找上例中创建的选择集
  38.     Dim sset As Object
  39.     Set sset = ThisDrawing.SelectionSets.Item("SS1")
  40.    
  41.     ' 定义扩展数据变量以保存扩展数据信息
  42.     Dim xdataType As Variant
  43.     Dim xdata As Variant
  44.     Dim xd As Variant
  45.    
  46.     '定义索引计数器
  47.     Dim xdi As Integer
  48.     xdi = 0
  49.    
  50.     ' 遍历选择集中的对象
  51.     ' 并检索对象的扩展数据
  52.     Dim msgstr As String
  53.     Dim appName As String
  54.     Dim ent As AcadEntity
  55.     appName = "MY_APP"
  56.     For Each ent In sset
  57.         msgstr = ""
  58.         xdi = 0
  59.         
  60.         ' 检索 appName 扩展数据类型和值
  61.         ent.GetXData appName, xdataType, xdata
  62.         
  63.         ' 如果未初始化 xdataType 变量,
  64.         ' 则没有可供该图元检索的 appName 扩展数据
  65.         If VarType(xdataType) <> vbEmpty Then
  66.             For Each xd In xdata
  67.                 msgstr = msgstr & vbCrLf & xdataType(xdi) _
  68.                          & ": " & xd
  69.                 xdi = xdi + 1
  70.             Next xd
  71.         End If
  72.         
  73.         ' 如果 msgstr 变量为 NULL,则没有扩展数据
  74.         If msgstr = "" Then msgstr = vbCrLf & "NONE"
  75.         MsgBox appName & " xdata on " & ent.ObjectName & _
  76.                                       ":" & vbCrLf & msgstr
  77.     Next ent
  78. End Sub

  79. 选择包含扩展数据的圆

  80. 下例过滤包含由“MY_APP”应用程序添加的扩展数据的圆:

  81. Sub Ch4_FilterXdata()
  82.    Dim sstext As AcadSelectionSet
  83.    Dim mode As Integer
  84.    Dim pointsArray(0 To 11) As Double
  85.    mode = acSelectionSetWindowPolygon
  86.    pointsArray(0) = -12#: pointsArray(1) = -7#: pointsArray(2) = 0
  87.    pointsArray(3) = -12#: pointsArray(4) = 10#: pointsArray(5) = 0
  88.    pointsArray(6) = 10#: pointsArray(7) = 10#: pointsArray(8) = 0
  89.    pointsArray(9) = 10#: pointsArray(10) = -7#: pointsArray(11) = 0
  90.    Dim FilterType(1) As Integer
  91.    Dim FilterData(1) As Variant
  92.    Set sstext = ThisDrawing.SelectionSets.Add("SS9")
  93.    
  94.    FilterType(0) = 0
  95.    FilterData(0) = "Circle"
  96.    FilterType(1) = 1001
  97.    FilterData(1) = "MY_APP"
  98.    
  99.    sstext.SelectByPolygon mode, pointsArray, FilterType, FilterData
  100.    
  101. End Sub

  102.   [/FONT]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 181个

财富等级: 日进斗金

 楼主| 发表于 2003-5-6 11:56:27 | 显示全部楼层

[文章]:关于VB和VBA开发CAD的一些知识(四)

关于VB和VBA开发CAD的一些知识(四)
编者:尹凡(efan2000) 时间:2003年5月

14、文件系统的操作
文件系统对象(FileSystemObject)提供对计算机文件系统的访问。主要包含驱动器对象(Drive对象)、目录对象(Folder对象)、文件对象(File对象)和流对象(TextStream对象)。
FileSystemObject对象提供了几个对于文件操作的函数,如用FileExists方法判断指定的文件是否存在,用CreateTextFile创建一个指定文件名的文件,用OpenTextFile打开一个指定的文件等。
TextStream对象则对打开的文件进行操作,如用AtEndOfStream判断是否到达文件的末尾,用Read、ReadAll和ReadLine方法分别读取一定数量的字符、全部或者一行的内容,而用Skip、SkipLine方法跳过指定数量的字符或者一行,用Write、WriteBlankLines和WriteLine分别写入一定数量的字符、换行符或者一行。

更具体的可以参考VB的语言参考手册和VBScript的帮助文件。



  1.   [FONT=courier new]
  2. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  3. '
  4. ' FileSystemObject 示例代码
  5. '
  6. 'Copyright 1998  Microsoft Corporation。保留所有权利。
  7. '
  8. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  9. Option Explicit

  10. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  11. '
  12. ' 对于代码质量:
  13. '
  14. ' 1) 下面的代码有许多字符串操作,用"&"运算符来把短字符串连接在一起。由于
  15. '    字符串连接是费时的,所以这是一种低效率的写代码方法。无论如何,它是
  16. '    一种非常好维护的写代码方法,并且在这儿使用了这种方法,因为该程序执行
  17. '    大量的磁盘操作,而磁盘操作比连接字符串所需的内存操作要慢得多。
  18. '    记住这是示范代码,而不是产品代码。
  19. '
  20. ' 2) 使用了 "Option Explicit",因为访问声明过的变量,比访问未声明的变量要
  21. '    稍微快一些。它还能阻止在代码中发生错误,例如,把 DriveTypeCDROM 误拼
  22. '    成了 DriveTypeCDORM 。
  23. '
  24. ' 3) 为了使代码更可读,该代码中没有错误处理。虽然采取了防范措施,来保证代码
  25. '    在普通情况下没有错误,但文件系统是不可预知的。在产品代码中,使用
  26. '    On Error Resume Next 和 Err 对象来捕获可能发生的错误。
  27. '
  28. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  29. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  30. '
  31. ' 一些容易取得的全局变量
  32. '
  33. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  34. Dim TabStop
  35. Dim NewLine

  36. Const TestDrive = "C"
  37. Const TestFilePath = "C:\Test"

  38. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  39. '
  40. ' 由 Drive.DriveType 返回的常数
  41. '
  42. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  43. Const DriveTypeRemovable = 1
  44. Const DriveTypeFixed = 2
  45. Const DriveTypeNetwork = 3
  46. Const DriveTypeCDROM = 4
  47. Const DriveTypeRAMDisk = 5

  48. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  49. '
  50. ' 由 File.Attributes 返回的常数
  51. '
  52. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  53. Const FileAttrNormal  = 0
  54. Const FileAttrReadOnly = 1
  55. Const FileAttrHidden = 2
  56. Const FileAttrSystem = 4
  57. Const FileAttrVolume = 8
  58. Const FileAttrDirectory = 16
  59. Const FileAttrArchive = 32
  60. Const FileAttrAlias = 64
  61. Const FileAttrCompressed = 128

  62. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  63. '
  64. ' 用来打开文件的常数
  65. '
  66. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  67. Const OpenFileForReading = 1
  68. Const OpenFileForWriting = 2
  69. Const OpenFileForAppending = 8


  70. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  71. '
  72. ' ShowDriveType
  73. '
  74. ' 目的:
  75. '
  76. ' 生成一个字符串,来描述给定 Drive 对象的驱动器类型。
  77. '
  78. ' 示范下面的内容
  79. '
  80. ' - Drive.DriveType
  81. '
  82. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  83. Function ShowDriveType(Drive)

  84.         Dim S
  85.   
  86.         Select Case Drive.DriveType
  87.         Case DriveTypeRemovable
  88.                 S = "Removable"
  89.         Case DriveTypeFixed
  90.                 S = "Fixed"
  91.         Case DriveTypeNetwork
  92.                 S = "Network"
  93.         Case DriveTypeCDROM
  94.                 S = "CD-ROM"
  95.         Case DriveTypeRAMDisk
  96.                 S = "RAM Disk"
  97.         Case Else
  98.                 S = "Unknown"
  99.         End Select

  100.         ShowDriveType = S

  101. End Function

  102. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  103. '
  104. ' ShowFileAttr
  105. '
  106. ' 目的:
  107. '
  108. ' 生成一个字符串,来描述文件或文件夹的属性。
  109. '
  110. ' 示范下面的内容
  111. '
  112. ' - File.Attributes
  113. ' - Folder.Attributes
  114. '
  115. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  116. Function ShowFileAttr(File) ' File 可以是文件或文件夹

  117.         Dim S
  118.           Dim Attr
  119.        
  120.         Attr = File.Attributes

  121.         If Attr = 0 Then
  122.                 ShowFileAttr = "Normal"
  123.                 Exit Function
  124.         End If

  125.         If Attr And FileAttrDirectory  Then S = S & "Directory "
  126.         If Attr And FileAttrReadOnly   Then S = S & "Read-Only "
  127.         If Attr And FileAttrHidden     Then S = S & "Hidden "
  128.         If Attr And FileAttrSystem     Then S = S & "System "
  129.         If Attr And FileAttrVolume     Then S = S & "Volume "
  130.         If Attr And FileAttrArchive    Then S = S & "Archive "
  131.         If Attr And FileAttrAlias      Then S = S & "Alias "
  132.         If Attr And FileAttrCompressed Then S = S & "Compressed "

  133.         ShowFileAttr = S

  134. End Function


  135. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  136. '
  137. ' GenerateDriveInformation
  138. '
  139. ' 目的:
  140. '
  141. ' 生成一个字符串,来描述可用驱动器的当前状态。
  142. '
  143. ' 示范下面的内容
  144. '
  145. ' - FileSystemObject.Drives
  146. ' - Iterating the Drives collection
  147. ' - Drives.Count
  148. ' - Drive.AvailableSpace
  149. ' - Drive.DriveLetter
  150. ' - Drive.DriveType
  151. ' - Drive.FileSystem
  152. ' - Drive.FreeSpace
  153. ' - Drive.IsReady
  154. ' - Drive.Path
  155. ' - Drive.SerialNumber
  156. ' - Drive.ShareName
  157. ' - Drive.TotalSize
  158. ' - Drive.VolumeName
  159. '
  160. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  161. Function GenerateDriveInformation(FSO)

  162.         Dim Drives
  163.         Dim Drive
  164.         Dim S

  165.         Set Drives = FSO.Drives

  166.         S = "Number of drives:" & TabStop & Drives.Count & NewLine & NewLine

  167.         ' 构造报告的第一行。
  168.         S = S & String(2, TabStop) & "Drive"
  169.         S = S & String(3, TabStop) & "File"
  170.         S = S & TabStop & "Total"
  171.         S = S & TabStop & "Free"
  172.         S = S & TabStop & "Available"
  173.         S = S & TabStop & "Serial" & NewLine

  174.         ' 构造报告的第二行。
  175.         S = S & "Letter"
  176.         S = S & TabStop & "Path"
  177.         S = S & TabStop & "Type"
  178.         S = S & TabStop & "Ready?"
  179.         S = S & TabStop & "Name"
  180.         S = S & TabStop & "System"
  181.         S = S & TabStop & "Space"
  182.         S = S & TabStop & "Space"
  183.         S = S & TabStop & "Space"
  184.         S = S & TabStop & "Number" & NewLine       

  185.         ' 分隔行。
  186.         S = S & String(105, "-") & NewLine

  187.         For Each Drive In Drives

  188.                 S = S & Drive.DriveLetter
  189.                 S = S & TabStop & Drive.Path
  190.                 S = S & TabStop & ShowDriveType(Drive)
  191.                 S = S & TabStop & Drive.IsReady

  192.                 If Drive.IsReady Then
  193.                     If DriveTypeNetwork = Drive.DriveType Then
  194.                                 S = S & TabStop & Drive.ShareName
  195.                         Else
  196.                                 S = S & TabStop & Drive.VolumeName
  197.                         End If   

  198.                         S = S & TabStop & Drive.FileSystem
  199.                         S = S & TabStop & Drive.TotalSize
  200.                         S = S & TabStop & Drive.FreeSpace
  201.                         S = S & TabStop & Drive.AvailableSpace
  202.                         S = S & TabStop & Hex(Drive.SerialNumber)

  203.                 End If

  204.                 S = S & NewLine

  205.         Next  
  206.        
  207.         GenerateDriveInformation = S

  208. End Function

  209. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  210. '
  211. ' GenerateFileInformation
  212. '
  213. ' 目的:
  214. '
  215. ' 生成一个字符串,来描述文件的当前状态。
  216. '
  217. ' 示范下面的内容
  218. '
  219. ' - File.Path
  220. ' - File.Name
  221. ' - File.Type
  222. ' - File.DateCreated
  223. ' - File.DateLastAccessed
  224. ' - File.DateLastModified
  225. ' - File.Size
  226. '
  227. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  228. Function GenerateFileInformation(File)

  229.         Dim S

  230.         S = NewLine & "Path:" & TabStop & File.Path
  231.         S = S & NewLine & "Name:" & TabStop & File.Name
  232.         S = S & NewLine & "Type:" & TabStop & File.Type
  233.         S = S & NewLine & "Attribs:" & TabStop & ShowFileAttr(File)
  234.         S = S & NewLine & "Created:" & TabStop & File.DateCreated
  235.         S = S & NewLine & "Accessed:" & TabStop & File.DateLastAccessed
  236.         S = S & NewLine & "Modified:" & TabStop & File.DateLastModified
  237.         S = S & NewLine & "Size" & TabStop & File.Size & NewLine

  238.         GenerateFileInformation = S

  239. End Function


  240. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  241. '
  242. ' GenerateFolderInformation
  243. '
  244. ' 目的:
  245. '
  246. ' 生成一个字符串,来描述文件夹的当前状态。
  247. '
  248. ' 示范下面的内容
  249. '
  250. ' - Folder.Path
  251. ' - Folder.Name
  252. ' - Folder.DateCreated
  253. ' - Folder.DateLastAccessed
  254. ' - Folder.DateLastModified
  255. ' - Folder.Size
  256. '
  257. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  258. Function GenerateFolderInformation(Folder)

  259.         Dim S

  260.         S = "Path:" & TabStop & Folder.Path
  261.         S = S & NewLine & "Name:" & TabStop & Folder.Name
  262.         S = S & NewLine & "Attribs:" & TabStop & ShowFileAttr(Folder)
  263.         S = S & NewLine & "Created:" & TabStop & Folder.DateCreated
  264.         S = S & NewLine & "Accessed:" & TabStop & Folder.DateLastAccessed
  265.         S = S & NewLine & "Modified:" & TabStop & Folder.DateLastModified
  266.         S = S & NewLine & "Size:" & TabStop & Folder.Size & NewLine

  267.         GenerateFolderInformation = S

  268. End Function

  269. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  270. '
  271. ' GenerateAllFolderInformation
  272. '
  273. ' 目的:
  274. '
  275. ' 生成一个字符串,来描述一个文件夹和所有文件及子文件夹的当前状态。
  276. '
  277. ' 示范下面的内容
  278. '
  279. ' - Folder.Path
  280. ' - Folder.SubFolders
  281. ' - Folders.Count
  282. '
  283. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  284. Function GenerateAllFolderInformation(Folder)

  285.         Dim S
  286.         Dim SubFolders
  287.         Dim SubFolder
  288.         Dim Files
  289.         Dim File

  290.         S = "Folder:" & TabStop & Folder.Path & NewLine & NewLine

  291.         Set Files = Folder.Files

  292.         If 1 = Files.Count Then
  293.                 S = S & "There is 1 file" & NewLine
  294.         Else
  295.                 S = S & "There are " & Files.Count & " files" & NewLine
  296.         End If

  297.         If Files.Count <> 0 Then

  298.                 For Each File In Files
  299.                         S = S & GenerateFileInformation(File)
  300.                 Next

  301.         End If

  302.         Set SubFolders = Folder.SubFolders

  303.         If 1 = SubFolders.Count Then
  304.                 S = S & NewLine & "There is 1 sub folder" & NewLine & NewLine
  305.         Else
  306.                 S = S & NewLine & "There are " & SubFolders.Count & " sub folders" & NewLine & NewLine
  307.         End If

  308.         If SubFolders.Count <> 0 Then

  309.                 For Each SubFolder In SubFolders
  310.                         S = S & GenerateFolderInformation(SubFolder)
  311.                 Next

  312.                 S = S & NewLine

  313.                 For Each SubFolder In SubFolders
  314.                         S = S & GenerateAllFolderInformation(SubFolder)
  315.                 Next

  316.         End If

  317.         GenerateAllFolderInformation = S

  318. End Function

  319. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  320. '
  321. ' GenerateTestInformation
  322. '
  323. ' 目的:
  324. '
  325. ' 生成一个字符串,来描述 C:\Test 文件夹和所有文件及子文件夹的当前状态。
  326. '
  327. ' 示范下面的内容
  328. '
  329. ' - FileSystemObject.DriveExists
  330. ' - FileSystemObject.FolderExists
  331. ' - FileSystemObject.GetFolder
  332. '
  333. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  334. Function GenerateTestInformation(FSO)

  335.         Dim TestFolder
  336.         Dim S

  337.         If Not FSO.DriveExists(TestDrive) Then Exit Function
  338.         If Not FSO.FolderExists(TestFilePath) Then Exit Function

  339.         Set TestFolder = FSO.GetFolder(TestFilePath)

  340.         GenerateTestInformation = GenerateAllFolderInformation(TestFolder)

  341. End Function


  342. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  343. '
  344. ' DeleteTestDirectory
  345. '
  346. ' 目的:
  347. '
  348. ' 清理 test 目录。
  349. '
  350. ' 示范下面的内容
  351. '
  352. ' - FileSystemObject.GetFolder
  353. ' - FileSystemObject.DeleteFile
  354. ' - FileSystemObject.DeleteFolder
  355. ' - Folder.Delete
  356. ' - File.Delete
  357. '
  358. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  359. Sub DeleteTestDirectory(FSO)

  360.         Dim TestFolder
  361.         Dim SubFolder
  362.         Dim File
  363.        
  364.         ' 有两种方法可用来删除文件:

  365.         FSO.DeleteFile(TestFilePath & "\Beatles\OctopusGarden.txt")

  366.         Set File = FSO.GetFile(TestFilePath & "\Beatles\BathroomWindow.txt")
  367.         File.Delete       



  368.         ' 有两种方法可用来删除文件夹:

  369.         FSO.DeleteFolder(TestFilePath & "\Beatles")

  370.         FSO.DeleteFile(TestFilePath & "\ReadMe.txt")

  371.         Set TestFolder = FSO.GetFolder(TestFilePath)
  372.         TestFolder.Delete

  373. End Sub

  374. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  375. '
  376. ' CreateLyrics
  377. '
  378. ' 目的:
  379. '
  380. ' 在文件夹中创建两个文本文件。
  381. '
  382. '
  383. ' 示范下面的内容
  384. '
  385. ' - FileSystemObject.CreateTextFile
  386. ' - TextStream.WriteLine
  387. ' - TextStream.Write
  388. ' - TextStream.WriteBlankLines
  389. ' - TextStream.Close
  390. '
  391. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  392. Sub CreateLyrics(Folder)

  393.         Dim TextStream
  394.        
  395.         Set TextStream = Folder.CreateTextFile("OctopusGarden.txt")
  396.        
  397.         TextStream.Write("Octopus' Garden ") ' 请注意,该语句不添加换行到文件中。
  398.         TextStream.WriteLine("(by Ringo Starr)")
  399.         TextStream.WriteBlankLines(1)
  400.         TextStream.WriteLine("I'd like to be under the sea in an octopus' garden in the shade,")
  401.         TextStream.WriteLine("He'd let us in, knows where we've been -- in his octopus' garden in the shade.")
  402.         TextStream.WriteBlankLines(2)
  403.        
  404.         TextStream.Close

  405.         Set TextStream = Folder.CreateTextFile("BathroomWindow.txt")
  406.         TextStream.WriteLine("She Came In Through The Bathroom Window (by Lennon/McCartney)")
  407.         TextStream.WriteLine("")
  408.         TextStream.WriteLine("She came in through the bathroom window protected by a silver spoon")
  409.         TextStream.WriteLine("But now she sucks her thumb and wanders by the banks of her own lagoon")
  410.         TextStream.WriteBlankLines(2)
  411.         TextStream.Close

  412. End Sub

  413. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  414. '
  415. ' GetLyrics
  416. '
  417. ' 目的:
  418. '
  419. ' 显示 lyrics 文件的内容。
  420. '
  421. '
  422. ' 示范下面的内容
  423. '
  424. ' - FileSystemObject.OpenTextFile
  425. ' - FileSystemObject.GetFile
  426. ' - TextStream.ReadAll
  427. ' - TextStream.Close
  428. ' - File.OpenAsTextStream
  429. ' - TextStream.AtEndOfStream
  430. ' - TextStream.ReadLine
  431. '
  432. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  433. Function GetLyrics(FSO)

  434.         Dim TextStream
  435.         Dim S
  436.         Dim File

  437.         ' 有多种方法可用来打开一个文本文件,和多种方法来从文件读取数据。
  438.         ' 这儿用了两种方法来打开文件和读取文件:

  439.         Set TextStream = FSO.OpenTextFile(TestFilePath & "\Beatles\OctopusGarden.txt", OpenFileForReading)
  440.        
  441.         S = TextStream.ReadAll & NewLine & NewLine
  442.         TextStream.Close

  443.         Set File = FSO.GetFile(TestFilePath & "\Beatles\BathroomWindow.txt")
  444.         Set TextStream = File.OpenAsTextStream(OpenFileForReading)
  445.         Do         While Not TextStream.AtEndOfStream
  446.                 S = S & TextStream.ReadLine & NewLine
  447.         Loop
  448.         TextStream.Close

  449.         GetLyrics = S
  450.        
  451. End Function


  452. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  453. '
  454. ' BuildTestDirectory
  455. '
  456. ' 目的:
  457. '
  458. ' 创建一个目录分层结构来示范 FileSystemObject。
  459. '
  460. ' 以这样的次序来创建分层结构:
  461. '
  462. ' C:\Test
  463. ' C:\Test\ReadMe.txt
  464. ' C:\Test\Beatles
  465. ' C:\Test\Beatles\OctopusGarden.txt
  466. ' C:\Test\Beatles\BathroomWindow.txt
  467. '
  468. '
  469. ' 示范下面的内容
  470. '
  471. ' - FileSystemObject.DriveExists
  472. ' - FileSystemObject.FolderExists
  473. ' - FileSystemObject.CreateFolder
  474. ' - FileSystemObject.CreateTextFile
  475. ' - Folders.Add
  476. ' - Folder.CreateTextFile
  477. ' - TextStream.WriteLine
  478. ' - TextStream.Close
  479. '
  480. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  481. Function BuildTestDirectory(FSO)
  482.        
  483.         Dim TestFolder
  484.         Dim SubFolders
  485.         Dim SubFolder
  486.         Dim TextStream

  487.         ' 排除(a)驱动器不存在,或(b)要创建的目录已经存在的情况。

  488.         If Not FSO.DriveExists(TestDrive) Then
  489.                 BuildTestDirectory = False
  490.                 Exit Function
  491.         End If

  492.         If FSO.FolderExists(TestFilePath) Then
  493.                 BuildTestDirectory = False
  494.                 Exit Function
  495.         End If

  496.         Set TestFolder = FSO.CreateFolder(TestFilePath)

  497.         Set TextStream = FSO.CreateTextFile(TestFilePath & "\ReadMe.txt")
  498.         TextStream.WriteLine("My song lyrics collection")
  499.         TextStream.Close

  500.         Set SubFolders = TestFolder.SubFolders

  501.         Set SubFolder = SubFolders.Add("Beatles")

  502.         CreateLyrics SubFolder       

  503.         BuildTestDirectory = True

  504. End Function



  505. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  506. '
  507. ' 主程序
  508. '
  509. ' 首先,它创建一个 test 目录,以及一些子文件夹和文件。
  510. ' 然后,它转储有关可用磁盘驱动器和 test 目录的某些信息,
  511. ' 最后,清除 test 目录及其所有内容。
  512. '
  513. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  514. Sub Main

  515.         Dim FSO

  516.         ' 设立全局变量。
  517.         TabStop = Chr(9)
  518.         NewLine = Chr(10)
  519.        
  520.         Set FSO = CreateObject("Scripting.FileSystemObject")

  521.         If Not BuildTestDirectory(FSO) Then
  522.                 Print "Test directory already exists or cannot be created.  Cannot continue."
  523.                 Exit Sub
  524.         End If
  525.        
  526.         Print GenerateDriveInformation(FSO) & NewLine & NewLine

  527.         Print GenerateTestInformation(FSO) & NewLine & NewLine

  528.         Print GetLyrics(FSO) & NewLine & NewLine

  529.         DeleteTestDirectory(FSO)
  530.        
  531. End Sub

  532.   [/FONT]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 181个

财富等级: 日进斗金

 楼主| 发表于 2003-5-7 12:39:41 | 显示全部楼层

[文章]:关于VB和VBA开发CAD的一些知识(五)

关于VB和VBA开发CAD的一些知识(五)
编者:尹凡(efan2000) 时间:2003年5月

15、Excel文件的操作
Excel应用程序对象(Application)提供了对Excel应用程序控制的接口。它包括工作簿对象(Workbook对象),代表当前打开的一个Excel文件(文档)。而一个工作簿又包含了一些工作表对象(Worksheet对象),代表工作簿中的一张工作表。Cell代表工作表中的一个单元格,而Range是由一个或者多个单元格构成的区域。

在 Excel 电子表格中列出 AutoCAD 属性
以下子例程在当前图形中查找所有的块引用,然后查找附着到这些块引用的属性,并将它们列在 Excel 电子表格中。要运行本样例,请按以下步骤执行:
1.        打开包含块引用的图形,这些块引用带有属性。(样例图形 sample/activeX/attrib.dwg 包含这样的块引用。)
2.        使用 AutoCAD VBAIDE 命令打开 VBA IDE。
3.        使用 VBA IDE 中的“工具” “引用”菜单选项,选择 Microsoft Excel 8.0 对象模型。
4.        将这个子例程复制到 VBA 的“代码”窗口中并运行它。

  1.   [FONT=courier new]
  2. Sub Ch12_Extract()
  3.     Dim Excel As Excel.Application
  4.     Dim ExcelSheet As Object
  5.     Dim ExcelWorkbook As Object
  6.    
  7.     Dim RowNum As Integer
  8.     Dim Header As Boolean
  9.     Dim elem As AcadEntity
  10.     Dim Array1 As Variant
  11.     Dim Count As Integer
  12.    
  13.     ' 启动 Excel。
  14.     Set Excel = New Excel.Application
  15.    
  16.     ' 创建新的工作簿并查找活动电子表格。
  17.     Set ExcelWorkbook = Excel.Workbooks.Add
  18.     Set ExcelSheet = Excel.ActiveSheet
  19.     ExcelWorkbook.SaveAs "Attribute.xls"
  20.    
  21.     RowNum = 1
  22.     Header = False
  23.     ' 遍历模型空间,查找
  24.     ' 所有的块引用。
  25.     For Each elem In ThisDrawing.ModelSpace
  26.         With elem
  27.             ' 找到块引用时,
  28.             ' 检查其属性
  29.             If StrComp(.EntityName, "AcDbBlockReference", 1) _
  30.                 = 0 Then
  31.                 If .HasAttributes Then
  32.                     ' 获取属性
  33.                     Array1 = .GetAttributes
  34.                     ' 将属性的标记字符串
  35.                     ' 复制到 Excel
  36.                     For Count = LBound(Array1) To UBound(Array1)
  37.                         If Header = False Then
  38.                             If StrComp(Array1(Count).EntityName, _
  39.                                   "AcDbAttribute", 1) = 0 Then
  40.                                 ExcelSheet.Cells(RowNum, _
  41.                                     Count + 1).value = _
  42.                                     Array1(Count).TagString
  43.                             End If
  44.                         End If
  45.                     Next Count
  46.                     RowNum = RowNum + 1
  47.                     For Count = LBound(Array1) To UBound(Array1)
  48.                         ExcelSheet.Cells(RowNum, Count + 1).value _
  49.                                     = Array1(Count).textString
  50.                     Next Count
  51.                     Header = True
  52.                 End If
  53.             End If
  54.         End With
  55.     Next elem
  56.     Excel.Application.Quit
  57. End Sub

  58.   [/FONT]


16、使用ADO操作Access数据库
ADO的Connection对象提供了连接数据库的方法,也可以看做是对数据库进行控制的接口。它主要包括数据集对象(Recordset对象),代表返回数据库中的数据记录,还有命令对象(Command对象),执行一些SQL语句。
Connection对象的Provider属性是提供者的名称,ConnectionString属性是建立到数据源的连接的信息。Open方法是打开到数据源的连接,Execute方法是执行指定的SQL语句。
Recordset对象的Open方法是返回表的记录或者执行SQL语句查询等的结果。
Command对象的Execute方法是执行SQL语句,如插入、更新、删除记录等。

  1.   [FONT=courier new]
  2. 示例:
  3. Public Sub Example_ADO()

  4.     Dim cnn As ADODB.Connection
  5. Set cnn = New ADODB.Connection

  6. ' 打开连接
  7. ' 1、在连接字符串外指定提供者
  8. ' cnn.Provider = "Microsoft.Jet.OLEDB.3.51"
  9. ' strCnn = "Data Source=c:\MyDb.mdb;"
  10. ' cnn.Open strCnn

  11. ' 2、在Open语句外指定连接字符串
  12. ' cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;Data Source=c:\MyDb.mdb;"
  13. ' cnn.Open

  14.     strCnn = "Provider=Microsoft.Jet.OLEDB.3.51;" & _
  15.         "Data Source= c:\MyDb.mdb;"
  16.     cnn.Open strCnn

  17. Dim rst As ADODB.Recordset
  18. Set rst = New ADODB.Recordset

  19. ' 打开表

  20.     rst.CursorType = adOpenKeyset
  21.     rst.LockType = adLockOptimistic
  22. rst.Open "employee", cnn, , , adCmdTable

  23. ' 执行SQL语句

  24. Dim cmd As ADODB.Command
  25. Set cmd = New ADODB.Command
  26.     Set cmd.ActiveConnection = cnn
  27.     cmd.CommandText = "UPDATE Titles SET Type ='self_help' WHERE Type = 'psychology'"
  28.    
  29.    
  30. rst.Close
  31.     cnn.Close
  32. End Sub

  33.   [/FONT]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-6-4 22:07:57 | 显示全部楼层
VB与CAD之间编程控制我指了好久,终于找到,感谢楼主!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3532个

财富等级: 富可敌国

发表于 2004-6-5 08:43:13 | 显示全部楼层
斑竹真是强啊!
厉害!佩服!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2004-6-9 08:56:33 | 显示全部楼层
看君一篇贴,胜过十本书!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-12-22 19:36 , Processed in 0.570162 second(s), 47 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表