avinash patil
2012-09-04, 11:29 AM
Hi!
At least please help me on this.
I am attaching the code here
I want to select object (rectangle polyline) , get the array points of this rectangle and again select by "SelectByPolygon" to get the Circle's.
Kindly correct this for me.
Thanks,
Avinash
Code:
Sub Example_SelectOnScreen()
' This example adds objects to a selection set by prompting the user
' to select ones to add.
' Create the selection set
Dim ssetObj As AcadSelectionSet
'Set ssetObj = ThisDrawing.SelectionSets.Item("TEST_SSET35")
Set ssetObj = ThisDrawing.SelectionSets.Item(1)
ReDim xvalue(0 To 3) As Variant
ReDim yvalue(0 To 3) As Variant
' Add objects to a selection set by prompting user to select on the screen
ssetObj.SelectOnScreen
Dim lngL As Long
Dim objAcadPoly As AcadLWPolyline
Dim IctX, IctY As Integer
IctX = 0
IctY = 0
Dim pointsArray(0 To 14) As Double
For Each objAcadPoly In ssetObj 'objSelectionSet
For lngL = 0 To UBound(objAcadPoly.Coordinates)
'Debug.Print objAcadPoly.Coordinates(lngL)
If lngL = 0 Then pointsArray(0) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(1) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(2) = 0#
If lngL = 2 Then pointsArray(3) = objAcadPoly.Coordinates(lngL)
If lngL = 3 Then pointsArray(4) = objAcadPoly.Coordinates(lngL)
If lngL = 3 Then pointsArray(5) = 0#
If lngL = 4 Then pointsArray(6) = objAcadPoly.Coordinates(lngL)
If lngL = 5 Then pointsArray(7) = objAcadPoly.Coordinates(lngL)
If lngL = 5 Then pointsArray(8) = 0#
If lngL = 6 Then pointsArray(9) = objAcadPoly.Coordinates(lngL)
If lngL = 7 Then pointsArray(10) = objAcadPoly.Coordinates(lngL)
If lngL = 7 Then pointsArray(11) = 0#
If lngL = 0 Then pointsArray(12) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(13) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(14) = 0#
If lngL = 0 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 1 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
If lngL = 2 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 3 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
If lngL = 4 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 5 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
If lngL = 6 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 7 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
Next lngL
Next objAcadPoly
'ssetObj.Delete
Dim itcnt, itcnt1 As Integer
For itcnt = 0 To 3 ' Loop 10 times.
Debug.Print "X-Value = " & xvalue(itcnt)
Next itcnt
For itcnt1 = 0 To 3 ' Loop 10 times.
Debug.Print "Y-Value = " & yvalue(itcnt1)
Next itcnt1
Dim maxX, minX, maxY, minY As Variant
maxY = Max(yvalue, 1)
maxX = Max(xvalue, 1)
minY = Min(yvalue)
minX = Min(xvalue)
Debug.Print "Max Y Value is = "; maxY
Debug.Print "Max X Value is = "; maxX
Debug.Print ; "Min Y Value is = "; minY
Debug.Print ; "Min X Value is = "; minX
Dim Po1(2), Po2(2), Po3(2), po4(2), po5(2) As Double
Dim cntpnts1, cntpnts2, cntpnts3, cntpnts4 As Integer
For cntpnts1 = 0 To 3 ' Loop 4 times.
If yvalue(cntpnts1) = maxY Then
Po1(0) = xvalue(cntpnts1)
Po1(1) = yvalue(cntpnts1)
Po1(2) = 0
End If
Next cntpnts1
For cntpnts2 = 0 To 3 ' Loop 4 times.
If xvalue(cntpnts2) = maxX Then
Po2(0) = xvalue(cntpnts2)
Po2(1) = yvalue(cntpnts2)
Po2(2) = 0
End If
Next cntpnts2
For cntpnts3 = 0 To 3 ' Loop 4 times.
If yvalue(cntpnts3) = minY Then
Po3(0) = xvalue(cntpnts3)
Po3(1) = yvalue(cntpnts3)
Po3(2) = 0
End If
Next cntpnts3
For cntpnts4 = 0 To 3 ' Loop 4 times.
If xvalue(cntpnts4) = minX Then
po4(0) = xvalue(cntpnts4)
po4(1) = yvalue(cntpnts4)
po4(2) = 0
End If
Next cntpnts4
Debug.Print " "
Debug.Print "P1 points : "; Po1(0) & " , " & Po1(1) & " , " & Po1(2)
Debug.Print "P2 points : "; Po2(0) & " , " & Po2(1) & " , " & Po2(2)
Debug.Print "P3 points : "; Po3(0) & " , " & Po3(1) & " , " & Po3(2)
Debug.Print "P4 points : "; po4(0) & " , " & po4(1) & " , " & po4(2)
Debug.Print "PointsArray : " & pointsArray(0) & " , " & pointsArray(1) & " , " & pointsArray(2)
Debug.Print "PointsArray : " & pointsArray(3) & " , " & pointsArray(4) & " , " & pointsArray(5)
Debug.Print "PointsArray : " & pointsArray(6) & " , " & pointsArray(7) & " , " & pointsArray(8)
Debug.Print "PointsArray : " & pointsArray(9) & " , " & pointsArray(10) & " , " & pointsArray(11)
Debug.Print "PointsArray : " & pointsArray(12) & " , " & pointsArray(13) & " , " & pointsArray(14)
Dim ssetObj5 As AcadSelectionSet
Dim mode As Integer
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "Circle"
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
Debug.Print "avinash patil"
'ssetObj5.SelectByPolygon mode, pointsArray, groupCode, dataCode
Set ssetObj5 = ThisDrawing.SelectionSets.Add("TEST_SSET37")
ssetObj5.SelectByPolygon mode, pointsArray, groupCode, dataCode
Debug.Print "avinash"
ssetObj.Delete
ssetObj5.Delete
Debug.Print "patil avinash"
End Sub
Function Min(ParamArray avValues() As Variant) As Variant
Dim vThisItem As Variant, vThisElement As Variant
On Error Resume Next
For Each vThisItem In avValues
If IsArray(vThisItem) Then
For Each vThisElement In vThisItem
Min = Min(vThisElement, Min)
Next
Else
If vThisItem < Min Then
If Not IsEmpty(vThisItem) Then
Min = vThisItem
End If
ElseIf IsEmpty(Min) Then
Min = vThisItem
End If
End If
Next
On Error GoTo 0
End Function
Function Max(ParamArray avValues() As Variant) As Variant
Dim vThisItem As Variant, vThisElement As Variant
On Error Resume Next
For Each vThisItem In avValues
If IsArray(vThisItem) Then
For Each vThisElement In vThisItem
Max = Max(vThisElement, Max)
Next
Else
If vThisItem > Max Then
If Not IsEmpty(vThisItem) Then
Max = vThisItem
End If
ElseIf IsEmpty(Max) Then
Max = vThisItem
End If
End If
Next
On Error GoTo 0
End Function
At least please help me on this.
I am attaching the code here
I want to select object (rectangle polyline) , get the array points of this rectangle and again select by "SelectByPolygon" to get the Circle's.
Kindly correct this for me.
Thanks,
Avinash
Code:
Sub Example_SelectOnScreen()
' This example adds objects to a selection set by prompting the user
' to select ones to add.
' Create the selection set
Dim ssetObj As AcadSelectionSet
'Set ssetObj = ThisDrawing.SelectionSets.Item("TEST_SSET35")
Set ssetObj = ThisDrawing.SelectionSets.Item(1)
ReDim xvalue(0 To 3) As Variant
ReDim yvalue(0 To 3) As Variant
' Add objects to a selection set by prompting user to select on the screen
ssetObj.SelectOnScreen
Dim lngL As Long
Dim objAcadPoly As AcadLWPolyline
Dim IctX, IctY As Integer
IctX = 0
IctY = 0
Dim pointsArray(0 To 14) As Double
For Each objAcadPoly In ssetObj 'objSelectionSet
For lngL = 0 To UBound(objAcadPoly.Coordinates)
'Debug.Print objAcadPoly.Coordinates(lngL)
If lngL = 0 Then pointsArray(0) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(1) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(2) = 0#
If lngL = 2 Then pointsArray(3) = objAcadPoly.Coordinates(lngL)
If lngL = 3 Then pointsArray(4) = objAcadPoly.Coordinates(lngL)
If lngL = 3 Then pointsArray(5) = 0#
If lngL = 4 Then pointsArray(6) = objAcadPoly.Coordinates(lngL)
If lngL = 5 Then pointsArray(7) = objAcadPoly.Coordinates(lngL)
If lngL = 5 Then pointsArray(8) = 0#
If lngL = 6 Then pointsArray(9) = objAcadPoly.Coordinates(lngL)
If lngL = 7 Then pointsArray(10) = objAcadPoly.Coordinates(lngL)
If lngL = 7 Then pointsArray(11) = 0#
If lngL = 0 Then pointsArray(12) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(13) = objAcadPoly.Coordinates(lngL)
If lngL = 1 Then pointsArray(14) = 0#
If lngL = 0 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 1 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
If lngL = 2 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 3 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
If lngL = 4 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 5 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
If lngL = 6 Then
xvalue(IctX) = objAcadPoly.Coordinates(lngL)
IctX = IctX + 1
End If
If lngL = 7 Then
yvalue(IctY) = objAcadPoly.Coordinates(lngL)
IctY = IctY + 1
End If
Next lngL
Next objAcadPoly
'ssetObj.Delete
Dim itcnt, itcnt1 As Integer
For itcnt = 0 To 3 ' Loop 10 times.
Debug.Print "X-Value = " & xvalue(itcnt)
Next itcnt
For itcnt1 = 0 To 3 ' Loop 10 times.
Debug.Print "Y-Value = " & yvalue(itcnt1)
Next itcnt1
Dim maxX, minX, maxY, minY As Variant
maxY = Max(yvalue, 1)
maxX = Max(xvalue, 1)
minY = Min(yvalue)
minX = Min(xvalue)
Debug.Print "Max Y Value is = "; maxY
Debug.Print "Max X Value is = "; maxX
Debug.Print ; "Min Y Value is = "; minY
Debug.Print ; "Min X Value is = "; minX
Dim Po1(2), Po2(2), Po3(2), po4(2), po5(2) As Double
Dim cntpnts1, cntpnts2, cntpnts3, cntpnts4 As Integer
For cntpnts1 = 0 To 3 ' Loop 4 times.
If yvalue(cntpnts1) = maxY Then
Po1(0) = xvalue(cntpnts1)
Po1(1) = yvalue(cntpnts1)
Po1(2) = 0
End If
Next cntpnts1
For cntpnts2 = 0 To 3 ' Loop 4 times.
If xvalue(cntpnts2) = maxX Then
Po2(0) = xvalue(cntpnts2)
Po2(1) = yvalue(cntpnts2)
Po2(2) = 0
End If
Next cntpnts2
For cntpnts3 = 0 To 3 ' Loop 4 times.
If yvalue(cntpnts3) = minY Then
Po3(0) = xvalue(cntpnts3)
Po3(1) = yvalue(cntpnts3)
Po3(2) = 0
End If
Next cntpnts3
For cntpnts4 = 0 To 3 ' Loop 4 times.
If xvalue(cntpnts4) = minX Then
po4(0) = xvalue(cntpnts4)
po4(1) = yvalue(cntpnts4)
po4(2) = 0
End If
Next cntpnts4
Debug.Print " "
Debug.Print "P1 points : "; Po1(0) & " , " & Po1(1) & " , " & Po1(2)
Debug.Print "P2 points : "; Po2(0) & " , " & Po2(1) & " , " & Po2(2)
Debug.Print "P3 points : "; Po3(0) & " , " & Po3(1) & " , " & Po3(2)
Debug.Print "P4 points : "; po4(0) & " , " & po4(1) & " , " & po4(2)
Debug.Print "PointsArray : " & pointsArray(0) & " , " & pointsArray(1) & " , " & pointsArray(2)
Debug.Print "PointsArray : " & pointsArray(3) & " , " & pointsArray(4) & " , " & pointsArray(5)
Debug.Print "PointsArray : " & pointsArray(6) & " , " & pointsArray(7) & " , " & pointsArray(8)
Debug.Print "PointsArray : " & pointsArray(9) & " , " & pointsArray(10) & " , " & pointsArray(11)
Debug.Print "PointsArray : " & pointsArray(12) & " , " & pointsArray(13) & " , " & pointsArray(14)
Dim ssetObj5 As AcadSelectionSet
Dim mode As Integer
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "Circle"
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
Debug.Print "avinash patil"
'ssetObj5.SelectByPolygon mode, pointsArray, groupCode, dataCode
Set ssetObj5 = ThisDrawing.SelectionSets.Add("TEST_SSET37")
ssetObj5.SelectByPolygon mode, pointsArray, groupCode, dataCode
Debug.Print "avinash"
ssetObj.Delete
ssetObj5.Delete
Debug.Print "patil avinash"
End Sub
Function Min(ParamArray avValues() As Variant) As Variant
Dim vThisItem As Variant, vThisElement As Variant
On Error Resume Next
For Each vThisItem In avValues
If IsArray(vThisItem) Then
For Each vThisElement In vThisItem
Min = Min(vThisElement, Min)
Next
Else
If vThisItem < Min Then
If Not IsEmpty(vThisItem) Then
Min = vThisItem
End If
ElseIf IsEmpty(Min) Then
Min = vThisItem
End If
End If
Next
On Error GoTo 0
End Function
Function Max(ParamArray avValues() As Variant) As Variant
Dim vThisItem As Variant, vThisElement As Variant
On Error Resume Next
For Each vThisItem In avValues
If IsArray(vThisItem) Then
For Each vThisElement In vThisItem
Max = Max(vThisElement, Max)
Next
Else
If vThisItem > Max Then
If Not IsEmpty(vThisItem) Then
Max = vThisItem
End If
ElseIf IsEmpty(Max) Then
Max = vThisItem
End If
End If
Next
On Error GoTo 0
End Function