EPS房屋注记合并源码

scxffy · 发表于 2020-12-18 19:23

废话不多说，直接上源码！
粘贴就可以使用，希望大家评分走起，支持支持！

Sub OnClick()
SSProcess.ClearSelection
SSProcess.ClearSelectCondition
SSProcess.ClearSelectConditionGroups
SSProcess.SetSelectCondition "SSObj_Type", "=", "NOTE"
SSProcess.SetSelectCondition "SSObj_FontClass", "=", "39900292"
SSProcess.SetSelectCondition "SSObj_FontString", "=", "1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52"
SSProcess.SelectFilter
SSProcess.ChangeSelectionObjAttr "SSObj_FontAlignment", "0"
SSProcess.ClearSelection
SSProcess.ClearSelectCondition
SSProcess.ClearSelectConditionGroups
SSProcess.SetSelectCondition "SSObj_Type", "=", "NOTE"
SSProcess.SetSelectCondition "SSObj_FontClass", "=", "39900291"
SSProcess.SetSelectCondition "SSObj_FontString", "=", "砖,土,混,石,砼,铁,木"
SSProcess.SelectFilter
SSProcess.ChangeSelectionObjAttr "SSObj_FontAlignment", "0"
SSProcess.PushUndoMark
SSProcess.ClearSelection
SSProcess.ClearSelectCondition
SSProcess.ClearSelectConditionGroups
SSProcess.SetSelectCondition "SSObj_Type", "=", "NOTE"
SSProcess.SetSelectCondition "SSObj_FontClass", "=", "39900292"
SSProcess.SetSelectCondition "SSObj_FontString", "=", "1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52"
SSProcess.SelectFilter
geoCount = SSProcess.GetSelNoteCount()
Dim arID(100000),t(100000),idCount
For i=0 To geoCount-1
polygonID = SSProcess.GetSelNoteValue( i, "SSObj_ID" )
FontString = SSProcess.GetSelNoteValue( i, "SSObj_FontString" )
SSProcess.GetSelNotePoint i, 0, x, y, z, pointType, name
ids1= SSProcess.SearchNearObjIDs(x, y, 2.5, 3, "39900291", polygonID )
if ids1<>"" then
ScanString ids1, ",", arID, idCount
For k=0 To idCount-1
t(k)=SSProcess.GetObjectAttr (arID(k), "SSObj_FontString")
if t(k)="砖" or t(k)="土" or t(k)="混" or t(k)="石" or t(k)="砼" or t(k)="铁" or t(k)="木" then
SSProcess.SetObjectAttr arID(k), "SSObj_FontAlignment", "0"
SSProcess.SetObjectAttr arID(k), "SSObj_FontAlignment", "0"
x1= SSProcess.GetObjectAttr (arID(k), "SSObj_X(0)" )
y1=SSProcess.GetObjectAttr (arID(k), "SSObj_Y(0)" )
tt=t(k)&FontString
SSProcess.SetObjectAttr polygonID, "SSObj_FontString", tt
SSProcess.SetObjectAttr polygonID, "SSObj_X(0)", x1
SSProcess.SetObjectAttr polygonID, "SSObj_Y(0)", y1
SSProcess.DeleteObject arID(k)
end if
next
end if
next
SSProcess.ClearSelection
SSProcess.ClearSelectCondition
SSProcess.ClearSelectConditionGroups
SSProcess.SetSelectCondition "SSObj_Type", "=", "NOTE"
SSProcess.SetSelectCondition "SSObj_FontClass", "=", "39900291"
SSProcess.SelectFilter
SSProcess.ChangeSelectionObjAttr "SSObj_FontAlignment", "0"
End Sub
Function ScanString(ByVal str, ByVal sep, ByRef strs(), ByRef count)
Dim sepidx1, sepidx2, strtemp
count = 0
sepidx1 = 1
sepidx2 = InStr(sepidx1 , str, sep, 1)
While (sepidx2 > 0)
strs(count) = Mid( str, sepidx1, sepidx2-sepidx1)
sepidx1 = sepidx2+1
sepidx2 = InStr(sepidx1, str, sep, 1)
count = count + 1
Wend
strs(count) = Mid( str, sepidx1, Len(str)+1-sepidx1)
count = count + 1
End Function
Function hasdot(str)
bl = False
For i = 1 to Len(str) - 0
If Mid(str,i,1) = "." Then
bl = True
hasdot = bl
End If
Next
hasdot = bl
End Function