cad

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

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' FileSystemObject 示例代码
'
'Copyright 1998 Microsoft Corporation。保留所有权利。
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
作者： drawing101 2006-2-28 22:37 　 回复此发言 6CAD应用 & 二次开发---VB和VBA开发CAD的知识
Option Explicit

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

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 一些容易取得的全局变量
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim TabStop
Dim NewLine

Const TestDrive = "C"
Const TestFilePath = "C:\Test"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 由 Drive.DriveType 返回的常数
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Const DriveTypeRemovable = 1
Const DriveTypeFixed = 2
Const DriveTypeNetwork = 3
Const DriveTypeCDROM = 4
Const DriveTypeRAMDisk = 5

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 由 File.Attributes 返回的常数
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Const FileAttrNormal = 0
Const FileAttrReadOnly = 1
Const FileAttrHidden = 2
Const FileAttrSystem = 4
Const FileAttrVolume = 8
Const FileAttrDirectory = 16
Const FileAttrArchive = 32
Const FileAttrAlias = 64
Const FileAttrCompressed = 128

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 用来打开文件的常数
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Const OpenFileForReading = 1
Const OpenFileForWriting = 2
Const OpenFileForAppending = 8


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ShowDriveType
'
' 目的：
'
' 生成一个字符串，来描述给定 Drive 对象的驱动器类型。
'
' 示范下面的内容
'
' - Drive.DriveType
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function ShowDriveType(Drive)

Dim S

Select Case Drive.DriveType
Case DriveTypeRemovable
S = "Removable"
Case DriveTypeFixed
S = "Fixed"
Case DriveTypeNetwork
S = "Network"
Case DriveTypeCDROM
S = "CD-ROM"
Case DriveTypeRAMDisk
S = "RAM Disk"
Case Else
S = "Unknown"
End Select

ShowDriveType = S

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' ShowFileAttr
'
' 目的：
'
' 生成一个字符串，来描述文件或文件夹的属性。
'
' 示范下面的内容
'
' - File.Attributes
' - Folder.Attributes
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
作者： drawing101 2006-2-28 22:37 　 回复此发言 7CAD应用 & 二次开发---VB和VBA开发CAD的知识
Function ShowFileAttr(File) ' File 可以是文件或文件夹

Dim S
Dim Attr

Attr = File.Attributes

If Attr = 0 Then
ShowFileAttr = "Normal"
Exit Function
End If

If Attr And FileAttrDirectory Then S = S & "Directory "
If Attr And FileAttrReadOnly Then S = S & "Read-Only "
If Attr And FileAttrHidden Then S = S & "Hidden "
If Attr And FileAttrSystem Then S = S & "System "
If Attr And FileAttrVolume Then S = S & "Volume "
If Attr And FileAttrArchive Then S = S & "Archive "
If Attr And FileAttrAlias Then S = S & "Alias "
If Attr And FileAttrCompressed Then S = S & "Compressed "

ShowFileAttr = S

End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GenerateDriveInformation
'
' 目的：
'
' 生成一个字符串，来描述可用驱动器的当前状态。
'
' 示范下面的内容
'
' - FileSystemObject.Drives
' - Iterating the Drives collection
' - Drives.Count
' - Drive.AvailableSpace
' - Drive.DriveLetter
' - Drive.DriveType
' - Drive.FileSystem
' - Drive.FreeSpace
' - Drive.IsReady
' - Drive.Path
' - Drive.SerialNumber
' - Drive.ShareName
' - Drive.TotalSize
' - Drive.VolumeName
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function GenerateDriveInformation(FSO)

Dim Drives
Dim Drive
Dim S

Set Drives = FSO.Drives

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

' 构造报告的第一行。
S = S & String(2, TabStop) & "Drive"
S = S & String(3, TabStop) & "File"
S = S & TabStop & "Total"
S = S & TabStop & "Free"
S = S & TabStop & "Available"
S = S & TabStop & "Serial" & NewLine

' 构造报告的第二行。
S = S & "Letter"
S = S & TabStop & "Path"
S = S & TabStop & "Type"
S = S & TabStop & "Ready?"
S = S & TabStop & "Name"
S = S & TabStop & "System"
S = S & TabStop & "Space"
S = S & TabStop & "Space"
S = S & TabStop & "Space"
S = S & TabStop & "Number" & NewLine

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

For Each Drive In Drives

S = S & Drive.DriveLetter
S = S & TabStop & Drive.Path
S = S & TabStop & ShowDriveType(Drive)
S = S & TabStop & Drive.IsReady

If Drive.IsReady Then
If DriveTypeNetwork = Drive.DriveType Then
S = S & TabStop & Drive.ShareName
Else
S = S & TabStop & Drive.VolumeName
End If

S = S & TabStop & Drive.FileSystem
S = S & TabStop & Drive.TotalSize
S = S & TabStop & Drive.FreeSpace
S = S & TabStop & Drive.AvailableSpace
S = S & TabStop & Hex(Drive.SerialNumber)

End If

S = S & NewLine

Next

GenerateDriveInformation = S

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GenerateFileInformation
'
' 目的：
'
' 生成一个字符串，来描述文件的当前状态。
'
' 示范下面的内容
'
' - File.Path
' - File.Name
' - File.Type
' - File.DateCreated
' - File.DateLastAccessed
' - File.DateLastModified
' - File.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function GenerateFileInformation(File)

Dim S

S = NewLine & "Path:" & TabStop & File.Path
S = S & NewLine & "Name:" & TabStop & File.Name
作者： drawing101 2006-2-28 22:37 　 回复此发言 8CAD应用 & 二次开发---VB和VBA开发CAD的知识 S = S & NewLine & "Type:" & TabStop & File.Type
S = S & NewLine & "Attribs:" & TabStop & ShowFileAttr(File)
S = S & NewLine & "Created:" & TabStop & File.DateCreated
S = S & NewLine & "Accessed:" & TabStop & File.DateLastAccessed
S = S & NewLine & "Modified:" & TabStop & File.DateLastModified
S = S & NewLine & "Size" & TabStop & File.Size & NewLine

GenerateFileInformation = S

End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GenerateFolderInformation
'
' 目的：
'
' 生成一个字符串，来描述文件夹的当前状态。
'
' 示范下面的内容
'
' - Folder.Path
' - Folder.Name
' - Folder.DateCreated
' - Folder.DateLastAccessed
' - Folder.DateLastModified
' - Folder.Size
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function GenerateFolderInformation(Folder)

Dim S

S = "Path:" & TabStop & Folder.Path
S = S & NewLine & "Name:" & TabStop & Folder.Name
S = S & NewLine & "Attribs:" & TabStop & ShowFileAttr(Folder)
S = S & NewLine & "Created:" & TabStop & Folder.DateCreated
S = S & NewLine & "Accessed:" & TabStop & Folder.DateLastAccessed
S = S & NewLine & "Modified:" & TabStop & Folder.DateLastModified
S = S & NewLine & "Size:" & TabStop & Folder.Size & NewLine

GenerateFolderInformation = S

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GenerateAllFolderInformation
'
' 目的：
'
' 生成一个字符串，来描述一个文件夹和所有文件及子文件夹的当前状态。
'
' 示范下面的内容
'
' - Folder.Path
' - Folder.SubFolders
' - Folders.Count
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function GenerateAllFolderInformation(Folder)

Dim S
Dim SubFolders
Dim SubFolder
Dim Files
Dim File

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

Set Files = Folder.Files

If 1 = Files.Count Then
S = S & "There is 1 file" & NewLine
Else
S = S & "There are " & Files.Count & " files" & NewLine
End If

If Files.Count <> 0 Then

For Each File In Files
S = S & GenerateFileInformation(File)
Next

End If

Set SubFolders = Folder.SubFolders

If 1 = SubFolders.Count Then
S = S & NewLine & "There is 1 sub folder" & NewLine & NewLine
Else
S = S & NewLine & "There are " & SubFolders.Count & " sub folders" & NewLine & NewLine
End If

If SubFolders.Count <> 0 Then

For Each SubFolder In SubFolders
S = S & GenerateFolderInformation(SubFolder)
Next

S = S & NewLine

For Each SubFolder In SubFolders
S = S & GenerateAllFolderInformation(SubFolder)
Next

End If

GenerateAllFolderInformation = S

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GenerateTestInformation
'
' 目的：
'
' 生成一个字符串，来描述 C:\Test 文件夹和所有文件及子文件夹的当前状态。
'
' 示范下面的内容
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.GetFolder
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function GenerateTestInformation(FSO)
作者： drawing101 2006-2-28 22:37 　 回复此发言 9CAD应用 & 二次开发---VB和VBA开发CAD的知识
Dim TestFolder
Dim S

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

Set TestFolder = FSO.GetFolder(TestFilePath)

GenerateTestInformation = GenerateAllFolderInformation(TestFolder)

End Function


--------------------------------------------------------------------------------

yfy20032004-06-30 20:03
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' DeleteTestDirectory
'
' 目的：
'
' 清理 test 目录。
'
' 示范下面的内容
'
' - FileSystemObject.GetFolder
' - FileSystemObject.DeleteFile
' - FileSystemObject.DeleteFolder
' - Folder.Delete
' - File.Delete
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub DeleteTestDirectory(FSO)

Dim TestFolder
Dim SubFolder
Dim File

' 有两种方法可用来删除文件：

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

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



' 有两种方法可用来删除文件夹：

FSO.DeleteFolder(TestFilePath & "\Beatles")

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

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

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CreateLyrics
'
' 目的：
'
' 在文件夹中创建两个文本文件。
'
'
' 示范下面的内容
'
' - FileSystemObject.CreateTextFile
' - TextStream.WriteLine
' - TextStream.Write
' - TextStream.WriteBlankLines
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub CreateLyrics(Folder)

Dim TextStream

Set TextStream = Folder.CreateTextFile("OctopusGarden.txt")

TextStream.Write("Octopus' Garden ") ' 请注意，该语句不添加换行到文件中。
TextStream.WriteLine("(by Ringo Starr)")
TextStream.WriteBlankLines(1)
TextStream.WriteLine("I'd like to be under the sea in an octopus' garden in the shade,")
TextStream.WriteLine("He'd let us in, knows where we've been -- in his octopus' garden in the shade.")
TextStream.WriteBlankLines(2)

TextStream.Close

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

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' GetLyrics
'
' 目的：
'
' 显示 lyrics 文件的内容。
'
'
' 示范下面的内容
'
' - FileSystemObject.OpenTextFile
' - FileSystemObject.GetFile
' - TextStream.ReadAll
' - TextStream.Close
' - File.OpenAsTextStream
' - TextStream.AtEndOfStream
' - TextStream.ReadLine
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function GetLyrics(FSO)

Dim TextStream
Dim S
Dim File

' 有多种方法可用来打开一个文本文件，和多种方法来从文件读取数据。
作者： drawing101 2006-2-28 22:37 　 回复此发言 10CAD应用 & 二次开发---VB和VBA开发CAD的知识 ' 这儿用了两种方法来打开文件和读取文件：

Set TextStream = FSO.OpenTextFile(TestFilePath & "\Beatles\OctopusGarden.txt", OpenFileForReading)

S = TextStream.ReadAll & NewLine & NewLine
TextStream.Close

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

GetLyrics = S

End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' BuildTestDirectory
'
' 目的：
'
' 创建一个目录分层结构来示范 FileSystemObject。
'
' 以这样的次序来创建分层结构：
'
' C:\Test
' C:\Test\ReadMe.txt
' C:\Test\Beatles
' C:\Test\Beatles\OctopusGarden.txt
' C:\Test\Beatles\BathroomWindow.txt
'
'
' 示范下面的内容
'
' - FileSystemObject.DriveExists
' - FileSystemObject.FolderExists
' - FileSystemObject.CreateFolder
' - FileSystemObject.CreateTextFile
' - Folders.Add
' - Folder.CreateTextFile
' - TextStream.WriteLine
' - TextStream.Close
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Function BuildTestDirectory(FSO)

Dim TestFolder
Dim SubFolders
Dim SubFolder
Dim TextStream

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

If Not FSO.DriveExists(TestDrive) Then
BuildTestDirectory = False
Exit Function
End If

If FSO.FolderExists(TestFilePath) Then
BuildTestDirectory = False
Exit Function
End If

Set TestFolder = FSO.CreateFolder(TestFilePath)

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

Set SubFolders = TestFolder.SubFolders

Set SubFolder = SubFolders.Add("Beatles")

CreateLyrics SubFolder

BuildTestDirectory = True

End Function



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 主程序
'
' 首先，它创建一个 test 目录，以及一些子文件夹和文件。
' 然后，它转储有关可用磁盘驱动器和 test 目录的某些信息，
' 最后，清除 test 目录及其所有内容。
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Main

Dim FSO

' 设立全局变量。
TabStop = Chr(9)
NewLine = Chr(10)

Set FSO = CreateObject("Scripting.FileSystemObject")

If Not BuildTestDirectory(FSO) Then
Print "Test directory already exists or cannot be created. Cannot continue."
Exit Sub
End If

Print GenerateDriveInformation(FSO) & NewLine & NewLine

Print GenerateTestInformation(FSO) & NewLine & NewLine

Print GetLyrics(FSO) & NewLine & NewLine

DeleteTestDirectory(FSO)

End Sub

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

在 Excel 电子表格中列出 AutoCAD 属性
作者： drawing101 2006-2-28 22:37 　 回复此发言 11CAD应用 & 二次开发---VB和VBA开发CAD的知识 以下子例程在当前图形中查找所有的块引用，然后查找附着到这些块引用的属性，并将它们列在 Excel 电子表格中。要运行本样例，请按以下步骤执行：
1. 打开包含块引用的图形，这些块引用带有属性。（样例图形 sample/activeX/attrib.dwg 包含这样的块引用。）
2. 使用 AutoCAD VBAIDE 命令打开 VBA IDE。
3. 使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 8.0 对象模型。
4. 将这个子例程复制到 VBA 的“代码”窗口中并运行它。
Sub Ch12_Extract()
Dim Excel As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object

Dim RowNum As Integer
Dim Header As Boolean
Dim elem As AcadEntity
Dim Array1 As Variant
Dim Count As Integer

' 启动 Excel。
Set Excel = New Excel.Application

' 创建新的工作簿并查找活动电子表格。
Set ExcelWorkbook = Excel.Workbooks.Add
Set ExcelSheet = Excel.ActiveSheet
ExcelWorkbook.SaveAs "Attribute.xls"

RowNum = 1
Header = False
' 遍历模型空间，查找
' 所有的块引用。
For Each elem In ThisDrawing.ModelSpace
With elem
' 找到块引用时，
' 检查其属性
If StrComp(.EntityName, "AcDbBlockReference", 1) _
= 0 Then
If .HasAttributes Then
' 获取属性
Array1 = .GetAttributes
' 将属性的标记字符串
' 复制到 Excel
For Count = LBound(Array1) To UBound(Array1)
If Header = False Then
If StrComp(Array1(Count).EntityName, _
"AcDbAttribute", 1) = 0 Then
ExcelSheet.Cells(RowNum, _
Count + 1).value = _
Array1(Count).TagString
End If
End If
Next Count
RowNum = RowNum + 1
For Count = LBound(Array1) To UBound(Array1)
ExcelSheet.Cells(RowNum, Count + 1).value _
= Array1(Count).textString
Next Count
Header = True
End If
End If
End With
Next elem
Excel.Application.Quit
End Sub
16、使用ADO操作Access数据库
ADO的Connection对象提供了连接数据库的方法，也可以看做是对数据库进行控制的接口。它主要包括数据集对象（Recordset对象），代表返回数据库中的数据记录，还有命令对象（Command对象），执行一些SQL语句。
Connection对象的Provider属性是提供者的名称，ConnectionString属性是建立到数据源的连接的信息。Open方法是打开到数据源的连接，Execute方法是执行指定的SQL语句。
Recordset对象的Open方法是返回表的记录或者执行SQL语句查询等的结果。
Command对象的Execute方法是执行SQL语句，如插入、更新、删除记录等。

示例：
Public Sub Example_ADO()

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

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

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

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

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

' 打开表

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

' 执行SQL语句

Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cnn
cmd.CommandText = "UPDATE Titles SET Type ='self_help' WHERE Type = 'psychology'"


rst.Close
cnn.Close
End Sub