VBA Object data update - Answer

[Anonymous]

Hello all,

This is just a quick post for those out there wanting to update data in existing ODTables under VB/A control. Just looking to save others the many hours of trolling cryptic autodesk documentation on the subject and lots of other frustrated blog/web entries.

Regards,

Tom

Existing Conditions:

dwg with object data attached to entities. In my case I have a table called "Parcels" with a date field attached to closed lwpolylines

vba code that can attach Object data to entities is already working so we're 90% there

Need to:

Replace the contents of an existing field with updated data

Process:

In the UserForm Activate section I have a code block that determined what version was running as I had to support multiple versions over the years so set a global variable to reference. One still had to select the correct version dependent reference objects for things to work

  'Which version of acad is running?
   Select Case AutoCAD.Application.Version
    Case "16.0"
      intVersion = 2004
      strMapObject = "AutoCADMap.Application.2"
    Case "16.1"
      intVersion = 2005
      strMapObject = "AutoCADMap.Application.3"
    Case "16.2s (LMS Tech)"
      intVersion = 2006
      strMapObject = "AutoCADMap.Application.4"
    Case "17.0s (LMS Tech)"
      intVersion = 2007
      strMapObject = "AutoCADMap.Application.5"
    Case "17.1s (LMS Tech)"
      intVersion = 2008
      strMapObject = "AutoCADMap.Application"
    Case "17.2s (LMS Tech)"
      intVersion = 2009
      strMapObject = "AutoCADMap.Application"
End Select

Private Sub UpdateDate

   Dim objLayer As AcadLayer
  Dim SSet As AcadSelectionSet
  Dim fTyp(1) As Integer
  Dim Fval(1) As Variant
  Dim objText As AcadText
  Dim acEnt As Object
  Dim objText2 As AcadText
  Dim intWork As Integer
  Dim strText As String
  Dim IP(0 To 2) As Double
  Dim height As Double
  Dim objDate As Date
 
  Dim amap As AcadMap
  Dim ODrcs As ODRecords
  Dim ODrc As ODRecord
  Dim bolVal, bol2 As Boolean
  Dim ent As AcadLWPolyline
 
  Set amap = ThisDrawing.Application.GetInterfaceObject(strMapObject) 'Get the version of code dependent on version running
  Set ODrcs = amap.Projects(ThisDrawing).ODTables("Parcels").GetODRecords
 
  On Error Resume Next
  ZoomExtents 'Selection seems to be a touch flaky for objects outside the visible extent
  frmProcParcels.Hide    'Hide the form during processing

  'Turn on the GIS1 layer & make sure layer is selectable
  Set objLayer = ThisDrawing.Layers.item("GIS1")
  If objLayer Is Nothing Then
    Set objLayer = ThisDrawing.Layers.Add("GIS1")
    objLayer.color = 72
  End If
  objLayer.Freeze = False
  objLayer.Lock = False
  objLayer.LayerOn = True
 
  'Create the Selection Sets
  Set SSet3 = ThisDrawing.SelectionSets.Add("GIS")
  If SSet3 Is Nothing Then
    Set SSet3 = ThisDrawing.SelectionSets.item("GIS")
  End If
  SSet3.Clear

  'Get 2D polylines from GIS1 layer
  fTyp(0) = 8: Fval(0) = "gis1"    '8 = Layer Name String
  fTyp(1) = 0: Fval(1) = "lwpolyline"    '0 = Object Type String
  SSet3.Select acSelectionSetAll, , , fTyp, Fval
 
  'Correct the odrecord date and dwg
  If SSet3.Count > 0 Then                 'Only process if there's data to work with
    For Each ent In SSet3                'Iterate through each object
      bolVal = ODrcs.Init(ent, True, True)         'Get to the ObjectData Records
      Set ODrc = ODrcs.Record                'Get Specific Record
      ODrc.item(5).Value = Trim(CStr(Date))        'Update Date field - Remember that the field array is 0 referenced so I'm actually updating the 6th OD Item in my list
      ODrc.item(6).Value = Trim(ThisDrawing.Name)    'Store the dwg name for reference after data exported - Updating field 7 if looking at the dialog
      bol2 = ODrcs.Update(ODrc)                'Trigger the update
      
    Next
  End If
  'Clean up prior to exit
  frmProcParcels.Show
  SSet3.Clear
  SSet3.Delete

End Sub