Hi Francisco,
I didn't find your drawing, but can make a couple
of comments about the code:
' Loop through parcels
styles:
For k = 0 To n - 1
Set txtbox =
Me.Controls.Item("txtbox" & k)
cvalue =
txtbox.Text
ReDim areasArray(n, 3)
color=#ff0000> ' Note you are redimming this inside the
loop
' and hence lose the data from the previous run
through the loop
areasArray(k, 1) =
g_oDocument.ParcelStyles.Item(k).Name
For z = 0 To j - 1 '
Loop through the parcels'
If
areasArray(k, 1) = g_oDocument.Sites.Item(0).Parcels.Item(z).styleName
Then
area
= g_oDocument.Sites.Item(0).Parcels.Item(z).Statistics.area +
area
End If
Next
areasArray(k, 2) = area
areasArray(k, 3) = areasArray(k, 2) * CDbl(cvalue)
totalarea = totalarea + areasArray(k, 2)
ck = ck +
areasArray(k, 3)
Next
What you have done here is to use the
item with the smaller number of entries as the outer loop and then processed
every item in the inner loop for each of the items in the outer
loop.
Thus in total you will run through
the loop "NoOfParcels * NoOfStyles" times.
If you cycle through the parcels in
the outer loop and find the style for the parcel - on average you will find the
parcel style half way through the style count and hence you will go through the
loop about half the number of times - and with an overhead of checking to exit
the loop.
I've written some code to put the
data in a list box. This does not requre the array to hold the data and is
certainly slower than using an array as I have to convert the data backwards and
forwards between values and strings. I should have used a 'double array'
to hold the data till ready to write it to the form
For this you need a form with a
combobox from which to select the required site, a list box to display the data
and two command controls. One to run the program and to exit the
form.
<Code start for
Module>
Option Explicit
Public g_oCivilApp As AeccApplication
Public
g_oAeccDoc As AeccDocument
size=2>
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Start Civil 3D and create Civil 3D document
object.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function
getCivilObjects() As Boolean
Dim sAppName As String
Dim oApp As
AcadApplication
Set oApp =
ThisDrawing.Application
sAppName =
"AeccXUiLand.AeccApplication.5.0"
Set g_oCivilApp =
oApp.GetInterfaceObject(sAppName)
If g_oCivilApp Is
Nothing Then
MsgBox "Error
creating " & sAppName & ",
exit."
getCivilObjects =
False
Exit
Function
End If
Set g_oAeccDoc =
g_oCivilApp.ActiveDocument
getCivilObjects = True
End
Function
Sub Start()
Dim bParcelsFound As
Boolean
getCivilObjects
For Each oSite In
g_oAeccDoc.Sites
If oSite.Parcels.Count > 0
Then
bParcelsFound =
True
Exit For
End
If
Next
If bParcelsFound = False Then
MsgBox "No parcels found in drawing"
Else
UserForm1.Show
End If
End Sub
<End module
code>
<Start form code>
face=Arial color=#ff0000 size=2>
Private Sub
UserForm_Initialize()
Dim iStyleNum As Integer
Dim iParcelNum As
Integer
Dim bParcelsFound As Boolean
Dim oSite As AeccSite
Me.Width = 400
Me.ListBox1.Width =
220
Me.ListBox1.ColumnCount = 3
Me.ListBox1.ColumnWidths =
60
Me.ListBox1.TextAlign = fmTextAlignRight
Me.ListBox1.ColumnHeads = False
Me.ListBox1.Clear
Me.ListBox1.AddItem "NAME "
Me.ListBox1.List(0, 1) = "STYLE"
Me.ListBox1.List(0, 2) = "AREA"
For iStyleNum = 0 To
g_oAeccDoc.ParcelStyles.Count - 1
Me.ListBox1.AddItem
"Test " & CStr(iStyleNum)
Me.ListBox1.List(iStyleNum +
1, 1) = g_oAeccDoc.ParcelStyles.Item(iStyleNum).Name
Me.ListBox1.List(iStyleNum + 1, 2) = ""
Next iStyleNum
Me.ListBox1.AddItem "Total"
Me.ListBox1.List(iStyleNum + 1, 2) =
""
cbSites.Clear
For Each oSite In
g_oAeccDoc.Sites
If oSite.Parcels.Count > 0
Then
cbSites.AddItem
oSite.Name
End If
Next
cbSites.ListIndex = 0
End Sub
Private Sub OK_Click()
Dim i As Integer
Dim iParcelNum As
Integer
Dim iNumParcels As Integer
Dim iNumParcelStyles As Integer
Dim
oSite As AeccSite
Dim oParcel As AeccParcel
Dim dArea() As Double
Dim
dTotal As Double
' Select the site to process from the
sites list box
Set oSite =
g_oAeccDoc.Sites.Item(cbSites.ListIndex)
iNumParcels =
oSite.Parcels.Count
iNumParcelStyles =
g_oAeccDoc.ParcelStyles.Count
ReDim dArea(1 To
iNumParcelStyles)
' Loop through the parcels -- each
parcel only addressed once
For iParcelNum = 0 To iNumParcels -
1
Set oParcel = oSite.Parcels.Item(iParcelNum)
color=#008000> ' find the listindex in the listbox which matches the parcel
style
' The styles are addressed several times, but only till the style
for each parcel is found
i =
1
Do While Not oParcel.Style.Name = Me.ListBox1.List(i,
1)
i = i + 1
Loop
' Add the cummulative area for that style to
the list box
dArea(i) = dArea(i) +
oParcel.Statistics.area
Next iParcelNum
'
Format the areas and add to the form
For i = 1 To
Me.ListBox1.ListCount - 2
If dArea(i) > 0
Then
Me.ListBox1.List(i, 2) = Format(dArea(i),
"#0.000")
dTotal = dTotal +
dArea(i)
Else
Me.ListBox1.List(i, 2) = ""
End If
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) =
Val(Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2)) + Val(Me.ListBox1.List(i,
2))
Next i
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 2) =
Format(dTotal, "#0.000")
End Sub
Private Sub cmdExit_Click()
me.Hide
End
Sub