分类： 编程园地

‘本节介绍几个知识点，即建立过滤器、建立选择集、四种方式选择图元。

'打开并绑定文件 D:/Test.dwg
Dim I As Integer, J As Integer
Dim oAutoCAD As Object
Call BindAutoCAD(True)
Dim oDraw As Object
Set oDraw = oAutoCAD.Application.Documents.Open("D:/Test.dwg")

'申明选择集及集成员
Dim oSelset As Object, oItem As Object

'建立过滤器，目标是位于 0 层的红色的单行文字、直线、圆(半径为15)、样条曲线、多义线
Dim FilterType(13) As Integer
Dim FilterData(13) As Variant
FilterType(0) = -4
FilterData(0) = "<AND"
FilterType(1) = 8 'Layer
FilterData(1) = "0"
FilterType(2) = 62 'Color
FilterData(2) = 1 'Red
FilterType(3) = -4
FilterData(3) = "<OR"
FilterType(4) = 0 '图元
FilterData(4) = "text"
FilterType(5) = 0 '图元
FilterData(5) = "line"
FilterType(6) = -4
FilterData(6) = "<AND"
FilterType(7) = 0 '图元
FilterData(7) = "circle"
FilterType(8) = 40 '半径
FilterData(8) = 15
FilterType(9) = -4
FilterData(9) = "AND>"
FilterType(10) = 0 '图元
FilterData(10) = "spline"
FilterType(11) = 0 '图元
FilterData(11) = "Polyline"
FilterType(12) = -4
FilterData(12) = "OR>"
FilterType(13) = -4
FilterData(13) = "AND>"

'点选式选择图元，同时满足过滤器原则
Call AppActivate(oAutoCAD.Caption)
Set oSelset = oDraw.SelectionSets.Add(SelName(8))
oSelset.Select 5, , , FilterType, FilterData
'acSelectionSetWindow = 0;
'acSelectionSetCrossing = 1;
'acSelectionSetFence = 2;
'acSelectionSetPrevious = 3;
'acSelectionSetLast = 4;
'acSelectionSetAll = 5;
For I = 0 To oSelset.Count - 1
Debug.Print Replace(oSelset(I).ObjectName, "AcDb", "", 1, -1, vbTextCompare)
Next I
Debug.Print

'屏幕选择图元，同时满足过滤器原
Call AppActivate(oAutoCAD.Caption)
Set oSelset = oDraw.SelectionSets.Add(SelName(8))
oSelset.SelectOnScreen FilterType, FilterData
For I = 0 To oSelset.Count - 1
Debug.Print Replace(oSelset(I).ObjectName, "AcDb", "", 1, -1, vbTextCompare)
Next I
Debug.Print

'多边形选择图元，同时满足过滤器原则
Call AppActivate(oAutoCAD.Caption)
Set oSelset = oDraw.SelectionSets.Add(SelName(8))
Dim PointArray(0 To 11) As Double
PointArray(0) = 0
PointArray(1) = 0
PointArray(2) = 0
PointArray(3) = 77
PointArray(4) = 380
PointArray(5) = 0
PointArray(6) = 215
PointArray(7) = 425
PointArray(8) = 0
PointArray(9) = 466
PointArray(10) = 188
PointArray(11) = 0
oSelset.SelectByPolygon 2, PointArray, FilterType, FilterData
'acSelectionSetFence = 0
'acSelectionSetWindowPolygon = 1
'acSelectionSetCrossingPolygon = 2
For I = 0 To oSelset.Count - 1
Debug.Print Replace(oSelset(I).ObjectName, "AcDb", "", 1, -1, vbTextCompare)
Next I
Debug.Print

'通过某点选择图元，同时满足过滤器原则
Call AppActivate(oAutoCAD.Caption)
Set oSelset = oDraw.SelectionSets.Add(SelName(8))
Dim TempPoint(0 To 2) As Double
TempPoint(0) = 10
TempPoint(1) = 10
TempPoint(2) = 0
oSelset.SelectAtPoint TempPoint, FilterType, FilterData
For I = 0 To oSelset.Count - 1
Debug.Print Replace(oSelset(I).ObjectName, "AcDb", "", 1, -1, vbTextCompare)
Next I
Debug.Print

Public Function SelName(ByVal iNumber As Integer) As String ‘生成 iNumber 位数的字符串
Dim I As Integer, J As Integer
Dim ReservedArray As Variant
ReservedArray = Array(“MANUALLY”, “SUPPORT”, “OHTLLINE”, “ACAD”, “WCAD”)
ERR_AVOID:
SelName = “”
Randomize
For I = 1 To iNumber
SelName = SelName & Chr((64 + Int((26 * Rnd) + 1)))
Next I
If IsInArray(SelName, ReservedArray) Then GoTo ERR_AVOID
End Function

Public Function CountStr(ByVal bOverlapable As Boolean, ByVal sMom As String, ByVal sSon As String) As Integer ‘sSon 在 sMom 中出现的次数
CountStr = 0
Do While InStr(1, sMom, sSon, vbTextCompare) > 0
CountStr = CountStr + 1
If bOverlapable Then ‘允许重复计数,如 nnn 中含两个 nn
sMom = Right(sMom, Len(sMom) – InStr(1, sMom, sSon, vbTextCompare))
Else ‘不允许重复计数,如 nnn 中含一个 nn
sMom = Right(sMom, Len(sMom) – InStr(1, sMom, sSon, vbTextCompare) – (Len(sSon) – 1))
End If
Loop
End Function

Public Function ExtractDivide(ByVal sLetter As String, ByVal sData As String, ByVal iOrder As Integer) As String ‘读出由 sLetter 分割的第 IOrder 节子字符串
ExtractDivide = “”
If sData = “” Then Exit Function
If iOrder < 1 Then Exit Function If iOrder > CountStr(False, sData, sLetter) + 1 Then Exit Function
sData = Trim(sData)
Dim TempArray As Variant
TempArray = Split(sData, sLetter, -1, vbTextCompare)
ExtractDivide = TempArray(iOrder – 1)
ExtractDivide = Trim(ExtractDivide)
End Function

Public Function CutLeft(ByVal sOriginal As String, ByVal sCut As String) As String ‘去掉左侧字符 sCut 一次(如果有)
CutLeft = LTrim(sOriginal)
If InStr(1, sOriginal, sCut, vbTextCompare) = 1 Then CutLeft = Right(sOriginal, Len(sOriginal) – Len(sCut))
End Function

Public Function CutRight(ByVal sOriginal As String, ByVal sCut As String) As String ‘去掉右侧字符 sCut 一次(如果有)
CutRight = RTrim(sOriginal)
If CutRight = “” Then Exit Function
If InStrRev(sOriginal, sCut, -1, vbTextCompare) = Len(sOriginal) – Len(sCut) + 1 Then CutRight = Left(sOriginal, Len(sOriginal) – Len(sCut))
End Function

Public Function CutTerminal(ByVal sOriginal As String, ByVal sCut As String) As String ‘去掉两端字符 sCut 一次(如果有)
CutTerminal = Trim(sOriginal)
CutTerminal = CutLeft(CutTerminal, sCut)
CutTerminal = CutRight(CutTerminal, sCut)
End Function

Public Function PurgeLeft(ByVal sOriginal As String, ByVal sPurge As String) As String ‘去掉左侧字符 sPurge(所有)
sOriginal = LTrim(sOriginal)
If sPurge = vbCr Or sPurge = vbLf Or sPurge = vbCrLf Then
Do While Asc(Left(sOriginal, Len(sPurge))) = Asc(sPurge)
sOriginal = Right(sOriginal, Len(sOriginal) – Len(sPurge))
sOriginal = LTrim(sOriginal)
Loop
Else
Do While InStr(1, sOriginal, sPurge, vbTextCompare) = 1 And Len(sOriginal) – Len(sPurge) > -1
sOriginal = Right(sOriginal, Len(sOriginal) – Len(sPurge))
sOriginal = LTrim(sOriginal)
Loop
End If
PurgeLeft = sOriginal
End Function

Public Function PurgeRight(ByVal sOriginal As String, ByVal sPurge As String) As String ‘去掉右侧字符 sPurge(所有)
sOriginal = RTrim(sOriginal)
If sPurge = vbCr Or sPurge = vbLf Or sPurge = vbCrLf Then
Do While Asc(Right(sOriginal, Len(sPurge))) = Asc(sPurge)
sOriginal = Left(sOriginal, Len(sOriginal) – Len(sPurge))
sOriginal = RTrim(sOriginal)
Loop
Else
Do While InStrRev(sOriginal, sPurge, -1, vbTextCompare) = Len(sOriginal) – Len(sPurge) + 1 And Len(sOriginal) – Len(sPurge) > -1
sOriginal = Left(sOriginal, Len(sOriginal) – Len(sPurge))
sOriginal = RTrim(sOriginal)
Loop
End If
PurgeRight = sOriginal
End Function

Public Function PurgeTerminal(ByVal sOriginal As String, ByVal sPurge As String) As String ‘去掉两端字符 sPurge(所有)
sOriginal = PurgeLeft(sOriginal, sPurge)
sOriginal = PurgeRight(sOriginal, sPurge)
PurgeTerminal = sOriginal
End Function

Public Function GetAPIString(ByVal sAPI As String) As String ‘字符包装，用于处理 API 返回字符
On Error Resume Next
Dim iZeroPos As Integer
iZeroPos = InStr(sAPI, Chr$(0))
If iZeroPos > 0 Then
GetAPIString = Left$(sAPI, iZeroPos – 1)
Else
GetAPIString = sAPI
End If
On Error GoTo 0
End Function

Public Function IsInArray(ByVal sData As String, ByVal vData As Variant) As Boolean ‘某字符串是否在某一维数组中
IsInArray = False
If Not IsArray(vData) Then Exit Function
If IsEmptyArray(vData) Then Exit Function
Dim I As Integer
For I = LBound(vData) To UBound(vData)
If sData = vData(I) Then IsInArray = True
Next I
End Function

Public Function IsEmptyArray(ByVal sArray As Variant) As Boolean ‘判断一维数组为空或者尚未初始化
‘类似 Dim TestArray(0 To 2) As String，一经申明，各元素即被赋 “” 值，IsEmptyArray 为 False；
‘类似 Dim TestArray() As String，虽经申明，仍为空数组，IsEmptyArray 为 True。
Dim I As Integer, J As Integer
On Error GoTo ERR_EMPTY
I = UBound(sArray) ‘试错
If LBound(sArray) > UBound(sArray) Then GoTo ERR_EMPTY
IsEmptyArray = False
On Error GoTo 0
Exit Function
ERR_EMPTY:
IsEmptyArray = True
On Error GoTo 0
End Function

Public Function IndexInArray(ByVal sData As String, ByVal vData As Variant) As Integer ‘某数值在某一维数组中的位次(以最小号为准, 不存在则为 -1)
Dim I As Integer, J As Integer
IndexInArray = -1
If Not IsArray(vData) Then Exit Function
If IsEmptyArray(vData) Then Exit Function
For I = LBound(vData) To UBound(vData)
If LCase(sData) = LCase(vData(I)) Then
IndexInArray = I
Exit For
End If
Next I
End Function

Public Sub CleanUpArray(vData As Variant) ‘剔除数组中的重复数据
If Not IsArray(vData) Then Exit Sub ‘数组判断
If IsEmptyArray(vData) Then Exit Sub
Dim LO, HI As Integer ‘上下界
LO = LBound(vData)
HI = UBound(vData)
Dim I, J, KCount As Integer
KCount = 0 ‘计数器
Dim DupeIndex() As String ‘重复数据的序号组成的数组，记后不记前
For I = HI To LO Step -1
For J = I – 1 To LO Step -1
If vData(I) = vData(J) Then
KCount = KCount + 1
ReDim Preserve DupeIndex(1 To KCount) As String
DupeIndex(KCount) = CStr(I)
Exit For
End If
Next J
Next I
If KCount > 0 Then ‘有重复
Dim iCount As Integer
iCount = LO – 1 ‘计数器
Dim TempArray() As String
For I = LO To HI
If Not IsInArray(CStr(I), DupeIndex()) Then ‘首次出现或未重复的数据
iCount = iCount + 1
ReDim Preserve TempArray(LO To iCount) As String
TempArray(iCount) = vData(I)
End If
Next I
ReDim vData(LO To iCount) ‘ As String ‘重新赋值并返回
For I = LO To iCount
vData(I) = TempArray(I)
Next I
Else
‘无重复，不处理
End If
Erase DupeIndex
End Sub

Dim oExcel As Object
Call BindExcel(True)

Dim oBook As Object
Dim oSheet As Object
Set oBook = oExcel.ActiveWorkBook
Set oSheet = oBook.ActiveSheet

oSheet.Cells(1, 1) = “1001”
oSheet.Cells(1, 2) = “1003”
oSheet.Cells(1, 3) = “1005”
oSheet.Cells(1, 4) = “1010”
oSheet.Cells(1, 5) = “1040”
oSheet.Cells(2, 1) = “属性
oSheet.Cells(2, 2) = “PROFILE”
oSheet.Cells(2, 3) = “467”
oSheet.Cells(3, 4) = “26.3333,236.0000,0.0000|26.3333,268.0000,0.0000” ‘两组坐标值
oSheet.Cells(3, 5) = “6885.44

‘绑定 Microsoft Excel
Dim oExcel As Object ‘Microsoft Excel Application 本身
Call BindExcel(True)
Dim oBook As Object ‘Microsoft Excel 多工作薄之一
Dim oSheet As Object ‘工作薄的工作表之一

‘打开并绑定文件 D:/Test.xls
Set oBook = oExcel.Application.WorkBooks.Open(“D:/Test.xls”)

‘绑定已经打开文件 Demo.xls
Set oBook = oExcel.WorkBooks.Item(“Demo.xls”)

‘新建文件并绑定
Set oBook = oExcel.WorkBooks.Add

‘绑定已经打开的当前文件
Set oBook = oExcel.ActiveWorkBook

绑定已有工作表 Sheet1
Set oSheet = oBook.Sheets(“Sheet1”)

‘新建工作表并绑定
Set oSheet = oBook.Worksheets.Add
oSheet.Name = “New Sheet”

‘绑定已经打开的当前工作表
Set oSheet = oBook.ActiveSheet

‘另存文件并指定格式
oBook.SaveAs “D:/TestBack.xls”, FileFormat:=18 ‘Excel Format

‘退出 Microsoft Excel 并释放资源
oExcel.Quit
Set oExcel = Nothing
Set oBook = Nothing
Set oSheet = Nothing