[VBA程序]：acad map vba入门的例子

native007

Sub tableproc()

Dim amap As AcadMap
Dim ODfdfs As ODFieldDefs
Dim ODfdf As ODFieldDef
Dim ODtb As ODTable
Dim ODrc As ODRecord

Set amap = ThisDrawing.Application. GetInterfaceObject("AutoCADMap.Application")

'Create OD Table Definition
Set ODfdfs = amap.Projects(ThisDrawing).MapUtil.NewODFieldDefs

' Add Column Headings and Defaults
Set ODfdf = ODfdfs.Add("Entity", "Entity name", "", 0)
Set ODfdf = ODfdfs.Add("Color", "Object color", acRed, 1)
Set ODfdf = ODfdfs.Add("Layer", "Object layer", "0", 2)

'Ensure Table Does Not Exist
If amap.Projects(ThisDrawing).ODTables.Item("SampleOD2") Is Nothing Then

'Register OD Table in the drawing
Set ODtb = amap.Projects(ThisDrawing) .ODTables.Add("SampleOD2", "Sample Xdata", ODfdfs, True)

'Create OD Record with Defaults
Set ODrc = ODtb.CreateRecord

'Loop Through Entities in Model Space

For Each acadObj In ThisDrawing.ModelSpace

'Fill Records with Entity Data
ODrc.Item(0).Value = acadObj.EntityName
ODrc.Item(1).Value = acadObj.Color
ODrc.Item(2).Value = acadObj.Layer

'Attach Record to Entity
ODrc.AttachTo (acadObj.ObjectID)
Next

Else

'Table Already Exists
MsgBox "Unable to create " & "SampleOD", , "Object Data Table Error"
End If


End Sub

Lzx838

先下来看看再说,先顶为上!