|
|
请问，下面代码的过滤器怎么无效啊？
Private Sub CommandButton515_Click()
'注意图元色值须为红色1才有效，还须注意随层时，它虽然是红色，色值仍是256，而不是1
'‘按单行文字的数学X值编页码的宏
Dim x, y, i
Dim VVV
Dim ZRR() As Variant
Dim QZ, QY, QJ, TEMP1, TEMP2, TEMP3, XH, k
''来源：[原创]给text加框的程序-VBA/VB/ActiveX/API 编程技术-CAD论坛-乐筑天下CAD社区 - Powered by Discuz!
'http://bbs.mjtd.com/forum.php?mod=viewthread&tid=77184
' On Error Resume Next
Dim mypnt1 As Variant
Dim mypnt2 As Variant
Rem mypnt1 = ThisDrawing.Utility.GetPoint(, "请选择左下角点:")
Rem mypnt2 = ThisDrawing.Utility.GetCorner(mypnt1, "请选择右上角点:")
'crossing 方法选择所有内部对象
Dim sset1 As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
Set sset1 = ThisDrawing.SelectionSets.Item("SS1")
sset1.Delete
End If
Set sset1 = ThisDrawing.SelectionSets.Add("SS1")
'定义过滤规则
Dim filterType1(0 To 4) As Integer
Dim filterData1(0 To 4) As Variant
filterType1(0) = -4
filterData1(0) = ""
Rem sset1.Select acSelectionSetCrossing, mypnt1, mypnt2, filterType1, filterData1 ' 使用Crossing选择模式，选择内部所有对象（包含边界本身）
sset1.Select acSelectionSetAll, , , filterType1, filterData1 ' 使用Crossing选择模式，选择内部所有对象（包含边界本身）
Dim ADTEXT As AcadText
Dim MINPT As Variant
Dim MAXPT As Variant
Dim RECPL As AcadLWPolyline
For Each ADTEXT In sset1
'是红色才处理的代码
' If ADTEXT.color = 1 Then
k = k + 1
ReDim Preserve ZRR(1 To 4, 1 To k)
'下面是将数组X由小到大排序
Set ZRR(1, k) = ADTEXT
ZRR(2, k) = ADTEXT.InsertionPoint(0)
ZRR(3, k) = ADTEXT.InsertionPoint(1)
' End If
'ADTEXT.TextString = Replace(ADTEXT.TextString, 1, 9)
' ADTEXT.GetBoundingBox MINPT, MAXPT'获得方框的两角点坐标
' Set RECPL = AddRectangle(MINPT, MAXPT)'画方框
Next
ZRR = 数组排序2维第1参数1行降2013年4月19日(ZRR, 3)
'下面是给Y值相等或相近的文字编同一组号
y = LBound(ZRR, 1)
x = LBound(ZRR, 2)
For i = x To UBound(ZRR, 2)
If i = y Then
ZRR(4, i) = 1
GoTo 下一个循环
End If
If (ZRR(3, i - 1) - ZRR(3, i)) > (TextBox7.Value * 1) Then
ZRR(4, i) = ZRR(4, i - 1) + 1
Else
ZRR(4, i) = ZRR(4, i - 1)
End If
下一个循环:
Next i
ZRR = 数组排序2维第1参数2行升升2013年4月19日(ZRR, 4, 2)
'再下面是将排序后的单行文本填为页码
XH = TextBox5.Value * 1
For i = x To UBound(ZRR, 2)
VVV = VVV + 1
ZRR(1, i).TextString = VVV + XH - 1
Next i
'这是因为最后一次经过了NEXT，QZ增加了一位
TextBox6.Value = VVV + XH - 1
TextBox5.Value = VVV + XH - 1 + 1
End Sub |
|
置顶卡
