Thanks again for your assistance with this Eric. However, I am now
completely stumped as to why it is not 'updating' the records for each
iteration. It should work now as I have made changes as suggested as well
as some others, but it still does not update each record that it should for
items SLOPE and ZLENGTH. The record for each of these fields remain
unchanged (default value '0.0000' respectively) when the routine finishes
and the object data records for these items for each pipe entity is checked.
There are no error messages when the program finishes. It bypasses line
entities that do not include an attached object data table and also checks
to see if a "SEWER" table exists. For purposes of checking whether the
values for each record within the invert elevations are recognized/passed
and correct calculations for the slope and 3D pipe length are assigned, I
included code to pass the extracted elevation values and calculated values
to an Excel spreadsheet for each record iteration and it works great. Any
other ideas/suggestions to make this code work for updating the records
within the object data table is appreciated . Below is the latest version
of code:
Private Sub ComGetEnt_Click()
Dim p1 As Variant, p2 As Variant
Dim x As Double, y As Double
Dim z_from As Double, z_to As Double
Dim Zlngth
Dim Lngth
Dim rise
Dim SlpFt
Dim acadApp As AcadApplication
Dim ent As AcadEntity
Dim amobj As AcadMap
Dim acadObject As Object
Dim objectID As Long
Dim proj As Project
Dim DrawSet As DrawingSet
Dim AttachedDwg As AttachedDrawing
Dim Tables As ODTables
Dim Table As ODTable
Dim Fields As ODFieldDefs
Dim Field As ODFieldDef
Dim entHandle As String
Dim entType As String
Dim entLayer As String
Dim dwgName As String
Dim Orecords As ODRecords
Dim Orecord As ODRecord
Dim Fieldval As ODFieldValue
Dim msg As String
Dim pv_temp As String
Dim pb_quit As Boolean
Dim Excel As Object
Dim excelSheet As Object
Dim RowNum As Integer
Set acadApp = ThisDrawing.Application
Set amobj = acadApp.GetInterfaceObject("AutoCADMap.Application")
Set proj = amobj.Projects(ThisDrawing)
dwgName = ThisDrawing.Name
Me.Hide
''Starts/Loads Excel
On Error Resume Next
Set Excel = GetObject(, "Excel.Application")
If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")
If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If
On Error GoTo 0
Excel.Visible = True
Excel.Workbooks.Add
Excel.Sheets("Sheet1").Select
Excel.ActiveWorkbook.SaveAs (dwgName)
Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")
RowNum = 1
excelSheet.Cells(RowNum, 1).Value = "Mapkey"
excelSheet.Cells(RowNum, 2).Value = "3DLength"
excelSheet.Cells(RowNum, 3).Value = "Slope_FT"
excelSheet.Cells(RowNum, 4).Value = "Rise_FT"
excelSheet.Cells(RowNum, 5).Value = "2DLength"
excelSheet.Range("A1:E1").Font.Bold = True
Set Table = proj.ODTables.Item("SEWER")
If Table Is Nothing Then
MsgBox "Object Data Table does not exist"
Exit Sub
End If
For Each ent In ThisDrawing.ModelSpace
Select Case ent.EntityType
Case acLine
entHandle = ent.Handle
entLayer = ent.Layer
Lngth = ent.Length
p1 = ent.StartPoint
p2 = ent.EndPoint
Set Orecords = Table.GetODRecords
If Orecords Is Nothing Then
MsgBox "No Object Data associated"
Exit Sub
End If
Select Case entLayer
Case "C-SW"
Orecords.Init ent, True, False
If (Orecords.IsDone = False) Then
Set Orecord = Orecords.record
pcounter = pcounter + 1
z1 = Orecord.Item(6).Value
z2 = Orecord.Item(7).Value
x = p1(0) - p2(0)
y = p1(1) - p2(1)
'Calculate the 'rise' value
z = z1 - z2
'Calculate the 3D Line length
Zlngth = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
'Calculate the slope in ft/ft
SlpFt = z / Lngth
Orecord.Item(2).Value = Zlngth
Orecord.Item(19).Value = SlpFt
Orecords.Update Orecord
''This portion of routine places extracted data into Excel worksheet
RowNum = RowNum + 1
excelSheet.Cells(RowNum, 1).Value = entHandle
excelSheet.Cells(RowNum, 2).Value = Zlngth
excelSheet.Cells(RowNum, 2).NumberFormat = "0.000000"
excelSheet.Cells(RowNum, 3).Value = SlpFt
excelSheet.Cells(RowNum, 3).NumberFormat = "0.000000"
excelSheet.Cells(RowNum, 4).Value = z
excelSheet.Cells(RowNum, 4).NumberFormat = "0.000000"
excelSheet.Cells(RowNum, 5).Value = Lngth
excelSheet.Cells(RowNum, 5).NumberFormat = "0.000000"
End If
End Select
Set Orecords = Nothing
End Select
Next
excelSheet.columns("A:G").AutoFit
If pcounter > 0 Then
MsgBox ("Found " & pcounter & " Sewer pipe entities.") '(...Data Transfer
Complete.")
End If
End Sub
"Eric Smallwood" wrote in message
news:FE3B7F1E5132C379B7BD9DDF22BDE77B@in.WebX.maYIadrTaRb...
> Now that I take another look at your code, I think the problem is that the
> 'If Orecords.IsDone Then' check doesn't bypass the remaining code, meaning
> that if an object doesn't have a table, it's stil going to head for the
code
> that is looking to update the table, and that's where the error message
> occurs. So, I think you need to move the 'End if' to the bottom of the
code
> but before the Next.
>
>
> Eric Smallwood
>
> "Gregg Greer" wrote in message
> news:322DC5D5B0B5846310CB06BD764E2BDF@in.WebX.maYIadrTaRb...
> > Thanks for your help Eric. Yes, a "SEWER" table is already attached to
> > the object. I have revised the code as instructed and had to add an
> > additional 'Orecords.Init ent, True, False' within the select case
"C-SW"
> > structure since setting the first Orecords.Init ent, to true and false
> > caused the error message 'Run-time error '-2145386417(8020004f)': Object
> was
> > open for write' and the program stopped at the 'p1 = ent.StartPoint'
line.
> > Inserting the line of code 'Orecords.Update Orecord' in place of the
> > original coding causes the same run-time error as before (Method
'Update'
> of
> > object 'ODRecords' failed) only with the Update method replacing the
> > AttachTo method. Also, utilizing the line of code 'Orecords.Update
> Orecord'
> > causes some funky things to occur with the values z1, z2 assigned as 0
> > instead of the correct assigned elevation values as present in the
record
> > for these items. So, changing the last line to 'Orecords.Update
> > Orecord.Item(19).Value' to try and force the SlpFt value (not an object,
I
> > know) into this record and table now results in the error message
> 'Run-time
> > error '424': Object required', but at least the correct assigned/passed
> and
> > calculated values for z1, z2, z, and SlpFt have returned to what they
> should
> > be. Are there any other suggestions/methods to try in order to assign
the
> > SlpFt calculated value into each empty record per field item 19
(SLOPE)??
> Is
> > this task really this difficult or is it just me?! All help/suggestions
is
> > greatly appreciated!!!
> >
> > Below is the revised code:
> >
> > ...Dim Tables As ODTables
> > Dim Table As ODTable
> > Dim Orecords As ODRecords
> > Dim Orecord As ODRecord
> > Dim ent As AcadEntity
> > Dim ObjectID As Long
> > Dim p1 As Variant, p2 As Variant
> > Dim z As Double, z_fr As Double, z_to As Double
> > Dim Lngth As Double
> > Dim SlpFt As Variant...
> >
> > Set Table = amobj.ODTables.Item("SEWER")
> > Set Orecords = Table.GetODRecords
> >
> > For Each ent in ThisDrawing.ModelSpace
> > Select Case ent.EntityType...
> > entLayer = ent.Layer
> > Lngth = ent.Length...
> >
> > Orecords.Init ent, False, False
> > If Orecords.IsDone Then
> > msg = ""
> > Else
> > Set Orecord = Orecords.Record
> > End If
> >
> > Select Case entLayer
> > Case "C-SW" 'Layer name for sewer pipe entities
> > p1 = ent.StartPoint
> > p2 = ent.EndPoint
> >
> > Set Table = amobj.ODTables.Item(Orecord.tableName)
> > Orecords.Init ent, True, False...
> >
> > z_fr = Orecord.Item(7).Value
> > z_to = Orecord.Item(8).Value...
> > z = z_fr - z_to
> > SlpFt = z / Lngth
> > Orecord.Item(19).Value = SlpFt
> > Orecords.Update Orecord.Item(19).Value...
>
>
>