I would like to replace the [code]LWArea = .Statistics.Perimeter
[ id(AECCXLAND_DISPID_PARCEL_SETUSERDEFINEDPROPERTYVALUE), helpcontext(IDH_AECCXLAND_PARCEL_SETUSERDEFINEDPROPERTYVALUE), helpstringcontext(AECCXLAND_HELPSTR_PARCEL_SETUSERDEFINEDPROPERTYVALUE) ]
HRESULT SetUserDefinedPropertyValue(
[in] VARIANT userDefinedProperty,
[in] VARIANT newValue
);
[ id(AECCXLAND_DISPID_PARCEL_GETUSERDEFINEDPROPERTYVALUE), helpcontext(IDH_AECCXLAND_PARCEL_GETUSERDEFINEDPROPERTYVALUE), helpstringcontext(AECCXLAND_HELPSTR_PARCEL_GETUSERDEFINEDPROPERTYVALUE) ]
HRESULT GetUserDefinedPropertyValue(
[in] VARIANT userDefinedProperty,
[out, retval] VARIANT* pVal
);
CN = .GetUserDefinedPropertyValue("CN")
Sub PickLwPolyAndGetData()
Dim MyCell As Range
Dim ACAD As AcadApplication
Dim LWPoly As AcadLWPolyline
Dim oParcel As AeccParcel
Dim ThisDrawing As AcadDocument
Dim Pt1 As Variant
Dim LWArea As Double, LWZ As Double
Dim CN As Variant
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' select LwPolyline
On Error Resume Next
Do
Err.Clear
ThisDrawing.Utility.GetEntity oParcel, Pt1, "Select a Parcel:"
Loop While Err
On Error GoTo 0
'get LWPoly data
' With LWPoly
' LWArea = .Area
' LWZ = .Elevation
' End With
'get oParcel data
With oParcel
LWArea = .Statistics.Area
LWZ = .Statistics.Perimeter
CN = .GetUserDefinedPropertyValue("CN")
End With
' write LWPoly data on worksheet
Set MyCell = ActiveCell
With MyCell
.Offset(0, 0).Value = "Area:"
.Offset(0, 1).Value = LWArea
.Offset(0, 2).Value = User1
.Offset(1, 0) = "Perimeter:"
.Offset(1, 1) = LWZ
.Offset(1, 2) = CN
End With
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
Sub PickLwPolysAndGetData()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim oParcel As AeccParcel
'Dim Pt1 As Variant
Dim CN As Variant
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
'Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
Set ssetObj = ThisDrawing.SelectionSets.Item("oParcelSSET")
'ThisDrawing.Utility.GetEntity oParcel, Pt1, "Select a Parcel:" <------- This is from the Code you did
'If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("oParcelSSET")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "Parcel"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(3, 2) 'Where to Start the Excel Cell Input X, Y
With MyCell
'.Offset(0, 0).Value = "LWPoly nr"
.Offset(0, 1).Value = "Area"
.Offset(0, 0) = "Z"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each oParcel In ssetObj
'retrieving LWPoly data
With oParcel
LWArea = .Statistics.Area
'LWZ = .Statistics.Perimeter
CN = .GetUserDefinedPropertyValue("CN")
End With
' writing LWPoly data
With MyCell
'.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWArea
.Offset(iRow, 0) = LWZ
End With
iRow = iRow + 1
Next oParcel
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
Sub PickLwPolysAndGetData()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim oParcel As AeccParcel
'Dim Pt1 As Variant
Dim CN As Variant
Dim TC As Variant
Dim Name As Variant
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
'Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
Set ssetObj = ThisDrawing.SelectionSets.Item("oParcelSSET")
'Set ssetObj = ThisDrawing.SelectionSets.Item("AECC_PARCEL")
'ThisDrawing.Utility.GetEntity oParcel, Pt1, "Select a Parcel:"
'If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("oParcelSSET")
'If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("AECC_PARCEL")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "AECC_PARCEL"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(3, 2) 'Where to Start the Excel Cell Input X, Y
With MyCell
'.Offset(0, 0).Value = "LWPoly nr"
.Offset(0, 1).Value = "Area"
.Offset(0, 0) = "Perimeter"
.Offset(0, 2) = "CN"
.Offset(0, 3) = "TC"
.Offset(0, 4) = "Name"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each oParcel In ssetObj
'retrieving LWPoly data
With oParcel
LWArea = .Statistics.Area
Perimeter = .Statistics.Perimeter
CN = .GetUserDefinedPropertyValue("CN")
TC = .GetUserDefinedPropertyValue("T.C.")
Name = .DisplayName
End With
' writing LWPoly data
With MyCell
'.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWArea
.Offset(iRow, 0) = Perimeter
.Offset(iRow, 2) = CN
.Offset(iRow, 3) = TC
.Offset(iRow, 3) = Name
End With
iRow = iRow + 1
Next oParcel
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
.GetUserDefinedPropertyValue