作者： 老王

‘将任意整数分解为等比数列之中的数值
Dim vRet As Variant
vRet = GeometricSeriesEx(2147483647)
For I = LBound(vRet) To UBound(vRet)
Debug.Print vRet(I)
Next I

Public Function GeometricSeriesEx(ByVal lData As Long) As Variant ‘分解整数为 1 2 4 8 16 32 64 … …，且每个数只出现一次
Dim I As Integer, J As Integer
If Not IsNumericEx(lData) Then Exit Function
Dim sBin As String
sBin = DEC_to_BIN(lData)
Dim iCount As Integer
Dim TempArray() As Long
For I = 1 To Len(sBin)
If Mid(sBin, I, 1) = “1” Then
ReDim Preserve TempArray(0 To iCount)
TempArray(iCount) = 2 ^ (Len(sBin) – I)
iCount = iCount + 1
End If
Next I
GeometricSeriesEx = TempArray
End Function

Public Function DEC_to_BIN(Dec As Long) As String ‘十进制转化为二进制
DEC_to_BIN = “”
Do While Dec > 0
DEC_to_BIN = Dec Mod 2 & DEC_to_BIN
Dec = Dec \ 2
Loop
End Function

Public Function IsNumericEx(ByVal sData As String) As Boolean ‘电子表格空格被 IsNumeric 视为数值 0,IsNumericEx 则视为字符 “”
IsNumericEx = False
sData = Trim(sData)
If sData = “” Then Exit Function
IsNumericEx = IsNumeric(sData)
End Function

Public Function IsInteger(ByVal txtString As String) As Boolean ‘是数值，且是整数
IsInteger = True
If Not IsNumeric(txtString) Then
IsInteger = False
Exit Function
End If
If Not CDbl(txtString) / 1 = CDbl(txtString) \ 1 Then
IsInteger = False
End If
End Function

Public Function IsInRange(ByVal sData As String, ByVal LowerLimit As Double, ByVal UpperLimit As Double, ByVal bAllowThreshold As Boolean) As Boolean ‘判断某数据是不是数值，且是否在界内
IsInRange = False
If Not IsNumeric(sData) Then Exit Function ‘字符等视为越界,防止以下比较时发生错误
If bAllowThreshold Then ‘压界算在界内
If CDbl(sData) > UpperLimit Then Exit Function ‘越上界
If CDbl(sData) < LowerLimit Then Exit Function ‘越下界 Else ‘压界不算在界内 If CDbl(sData) >= UpperLimit Then Exit Function ‘越上界
If CDbl(sData) <= LowerLimit Then Exit Function ‘越下界
End If
IsInRange = True
End Function

Public Function MinRow(ByVal vSheet As Variant) As Integer ‘有内容的最小行号
MinRow = -1
On Error Resume Next
If vSheet Is Nothing Then Exit Function
vSheet.Activate
MinRow = vSheet.UsedRange.Rows(vSheet.UsedRange.Rows.Count).Row – vSheet.UsedRange.Rows.Count + 1
On Error GoTo 0
End Function

Public Function MaxRow(ByVal vSheet As Variant) As Integer ‘有内容的最大行号
MaxRow = -1
On Error Resume Next
If vSheet Is Nothing Then Exit Function
vSheet.Activate
MaxRow = vSheet.UsedRange.Rows(vSheet.UsedRange.Rows.Count).Row
On Error GoTo 0
End Function

Public Function MinColumn(ByVal vSheet As Variant) As Integer ‘有内容的最小列号
MinColumn = -1
On Error Resume Next
If vSheet Is Nothing Then Exit Function
vSheet.Activate
MinColumn = vSheet.UsedRange.Columns(vSheet.UsedRange.Columns.Count).Column – vSheet.UsedRange.Columns.Count + 1
‘vSheet.Cells.Find(“*”, , , , 2, 1).Column 同
On Error GoTo 0
End Function

Public Function MaxColumn(ByVal vSheet As Variant) As Integer ‘有内容的最大列号
MaxColumn = -1
On Error Resume Next
If vSheet Is Nothing Then Exit Function
vSheet.Activate
MaxColumn = vSheet.UsedRange.Columns(vSheet.UsedRange.Columns.Count).Column
‘vSheet.Cells.Find(“*”, , , , 2, 2).Column 同
If Err.Number <> 0 Then Call SaveOccurredErr(1)
If Not ExposeError Then On Error GoTo 0
End Function

Public Function SheetExist(ByVal vBook As Variant, ByVal sSheet As String) As Boolean ‘当前 WorkBook 之 Sheet 存在
On Error Resume Next
Dim I As Integer, J As Integer
SheetExist = False
If vBook Is Nothing Then Exit Function
‘If vSheet Is Nothing Then Exit Function
For I = 1 To vBook.Sheets.Count
If vBook.Sheets(I).Name = sSheet Then SheetExist = True
Next I
If Err.Number <> 0 Then SheetExist = False
On Error GoTo 0
End Function

Public Function GetColumnNumber(ByVal vSheet As Variant, ByVal sData As String, ByVal iRow As Integer) As Integer ‘确定数据在某行的哪一列,如果不存在则指向新列
Dim I As Integer, J As Integer
GetColumnNumber = 0
If vSheet Is Nothing Then Exit Function
vSheet.Activate
For J = MinColumn(vSheet) To MaxColumn(vSheet)
If sData = vSheet.Cells(iRow, J) Then GetColumnNumber = J
Next J
If GetColumnNumber = 0 Then GetColumnNumber = MaxColumn(vSheet) + 1
End Function

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

'打开并绑定文件 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