I'm sure you guys have had fun trying to work with this file.
I wrote some code hoping to make renumbering parcels a bit more user friendly. The code below will change the block attribute as well as invoke the Parcels.Rename method. When using this method, it seems to corrupt the parcel file (can't get the lot info any more).
What am I missing?
TIA!
sorry for the bad word wrap. i've pasted the code into the attached txt file if you want to see it more clearly...
( I realize the code is quite "primative." it will certainly blow up if trying to rename a parcel to one that already exists. Any other code help would be greatly appreciated!)
'works with block only - leaves project file out of sync!
Public Sub Renumber_Parcels()
Dim oSelectionSet As AcadSelectionSet 'selection set of parcel blocks
Dim oEntity As AcadEntity
Dim oBlockReference As AcadBlockReference 'each block
Dim vBlockAttributes As Variant 'blocks attributes
Dim iAttributeCounter As Integer
Dim iBlocksModifiedCounter As Integer
Dim iTextModifiedCounter As Integer
Dim sResults As String
Dim iNumberToAdd As Integer
Dim sCurrentParcelValue As String
Dim sCurrentParcelNumber As String
Dim sNewParcelValue As String
Dim vTextPosition1 As Variant
Dim vTextPosition2 As Variant
Dim sOutput As String 'output
Dim oParcel As AeccParcel
Dim oParcels As AeccParcels
' intialize counters
iBlocksModifiedCounter = 0
iAttributeCounter = 0
' get a collection of parcel blocks to modify
Set oSelectionSet = getParcelBlocks
' get number to modify with
iNumberToAdd = InputBox("Enter number to add (use a negative to subtract):")
' if parcel blocks are found
If oSelectionSet.Count > 0 Then
Set oParcels = AeccApplication.ActiveProject.Parcels
' for each object selected
For Each oEntity In oSelectionSet
'if this is a block
If TypeOf oEntity Is AcadBlockReference Then
Set oBlockReference = oEntity
' get the blocks attributes
vBlockAttributes = oBlockReference.GetAttributes
' search for the "lot number" attribute
For iAttributeCounter = LBound(vBlockAttributes) To UBound(vBlockAttributes)
' find the attribute for the lot number
If UCase(vBlockAttributes(iAttributeCounter).TagString) = "LOTDES" Then
' get the current value
sCurrentParcelValue = vBlockAttributes(iAttributeCounter).TextString
' get the current parcel
For Each oParcel In oParcels
If oParcel.Name = sCurrentParcelValue Then
Exit For
End If
Next
' search for extra chars in the label
' search for the "#" first. if the parcel is underlined and has the # sign,
' this will take care of it
vTextPosition1 = InStr(1, sCurrentParcelValue, "#", vbTextCompare)
' search only for the underline
vTextPosition2 = InStr(1, sCurrentParcelValue, "%%U", vbTextCompare)
If vTextPosition1 > 0 Then
' current parcel number
sCurrentParcelNumber = Mid(sCurrentParcelValue, vTextPosition1 + 1, Len(sCurrentParcelValue))
' create new parcel label
sNewParcelValue = Mid(sCurrentParcelValue, 1, vTextPosition1) & sCurrentParcelNumber + iNumberToAdd
' modify block
vBlockAttributes(iAttributeCounter).TextString = sNewParcelValue
sOutput = sOutput & sCurrentParcelValue & "->" & sNewParcelValue & vbNewLine
iBlocksModifiedCounter = iBlocksModifiedCounter + 1
' if the underline was found
ElseIf vTextPosition2 > 0 Then
' current parcel number
sCurrentParcelNumber = Mid(sCurrentParcelValue, vTextPosition2 + 3, Len(sCurrentParcelValue))
' create new parcel label
sNewParcelValue = Mid(sCurrentParcelValue, 1, vTextPosition2 + 2) & sCurrentParcelNumber + iNumberToAdd
' modify block
vBlockAttributes(iAttributeCounter).TextString = sNewParcelValue
sOutput = sOutput & sCurrentParcelValue & "->" & sNewParcelValue & vbNewLine
iBlocksModifiedCounter = iBlocksModifiedCounter + 1
' didn't find a "#" or "%%U", so it should be a number
ElseIf IsNumeric(sCurrentParcelValue) = True Then
' current parcel number
sCurrentParcelNumber = sCurrentParcelValue
' create new parcel label
sNewParcelValue = sCurrentParcelValue + iNumberToAdd
' modify block
vBlockAttributes(iAttributeCounter).TextString = sNewParcelValue
sOutput = sOutput & sCurrentParcelValue & " -> " & sNewParcelValue & vbNewLine
iBlocksModifiedCounter = iBlocksModifiedCounter + 1
Else
MsgBox "Unable to change Parcel: " & sCurrentParcelValue
End If
If Not oParcel Is Nothing Then
oParcels.Rename sCurrentParcelValue, sNewParcelValue
End If
End If
Next iAttributeCounter
End If
Next oEntity
' no blocks found to modify
Else
sResults = "No parcel label blocks were found/selected to update."
MsgBox sResults, vbInformation, "No Parcel Labels Selected"
End If
' display any results
If iBlocksModifiedCounter > 0 Then
sResults = "[" & CStr(iBlocksModifiedCounter) & "] parcel blocks(s) updated." & vbNewLine
End If
If iTextModifiedCounter > 0 Then
sResults = "[" & CStr(iTextModifiedCounter) & "] parcel text label(s) updated." & vbNewLine
End If
If sResults <> vbNullString Then
MsgBox sResults & "LOT CONVERSION: " & vbNewLine & sOutput
End If
' release objects from memory
Set oEntity = Nothing
Set oBlockReference = Nothing
Set oSelectionSet = Nothing
Set oParcels = Nothing
If Not oParcel Is Nothing Then
Set oParcel = Nothing
End If
End Sub