Try this code:
'' Global variables -----------------------------------------------------
Public g_oCivilApp As AeccApplication
Public g_oAeccDoc As AeccDocument
Public g_oAeccDb As AeccDatabase
Public g_oTCD As AeccTinCreationData
Public g_oUnits As AeccDrawingUnitType
Public g_dScale As AeccDrawingUnitType
'' Connection to Civil 3D
application ---------------------------------------
Public Function InitCivil3D() As Boolean
On Error Resume Next
If Not g_oCivilApp Is Nothing Then
InitCivil3D = True
Exit Function
End If
Const sAppName = "AeccXUiLand.AeccApplication"
Set g_oCivilApp = Application.GetInterfaceObject(sAppName)
If g_oCivilApp Is Nothing Then
MsgBox "Error creating " & sAppName & ", exit."
InitCivil3D = False
Exit Function
End If
Set g_oAeccDoc = g_oCivilApp.ActiveDocument
Set g_oAeccDb = g_oAeccDoc.Database
g_oUnits = g_oAeccDb.Settings.DrawingSettings.UnitZoneSettings.DrawingUnits
g_dScale = g_oAeccDb.Settings.DrawingSettings.UnitZoneSettings.DrawingScale
InitCivil3D = True
End Function
'' Working function ----------------------------------------------------
Public Sub AppPnt()
If Not InitCivil3D Then Exit Sub
Dim dpo() As Double
Dim oPoint As AeccPoint
Dim oObj As Object
For Each oObj In ThisDrawing.ModelSpace
If TypeOf oObj Is AcadPoint Then
dpo = oObj.Coordinates
Set oPoint = g_oAeccDb.Points.Add(dpo)
oObj.Delete
End If
Next
Set oPoint = g_oAeccDb.Points.Add(dpo)
End Sub
"SixFeet6" wrote in message
news:3664644.1106644946876.JavaMail.jive@jiveforum1.autodesk.com...
> Hi this code below does place the 3 points but does not convert the ACAD
points, does anyone knows what is wrong ?
>
> THX !!!
>
> Option Explicit
> '
> ' This sample is dependent on EG.xml
> ' because the points are located on top of surface.
> ' Use Add point groups from the treeview UI to see
> ' the result of a point getting build into the surface.
> '
> Public Function createPointsPointGroups() As Boolean
> On Error Resume Next
>
> If getCivilObjects = False Then
> createPointsPointGroups = False
> Exit Function
> End If
> Dim oPoints As AeccPoints
> Set oPoints = g_oAeccDoc.Points
> Dim oPoint1 As AeccPoint
> Dim oPoint2 As AeccPoint
> Dim oPoint3 As AeccPoint
>
> Dim elem As Object
> Dim found As Boolean
> Dim pt(0 To 2) As Double
>
> 'Debug.Print "OK1"
> ' Cycle through the entities in modelspace
> For Each elem In ThisDrawing.ModelSpace
> With elem
> If (.EntityName = "Point") Then
> ' Change the height of the text entity
> pt(0) = elem.X
> pt(1) = elem.Y
> pt(2) = elem.Z
>
> Set oPoint2 = oPoints.Add(pt)
> oPoint2.Name = "Gpoint"
> oPoint2.LabelStyle = g_oAeccDoc.PointLabelStyles.Item(0)
> ' Debug.Print "OK"
>
> ' .Update
> found = True
> End If
> End With
> Set elem = Nothing
> Next elem
>
>
> Dim pt1(0 To 2) As Double
> Dim pt2(0 To 2) As Double
> Dim pt3(0 To 2) As Double
> pt1(0) = 4958: pt1(1) = 4078
> pt2(0) = 5507: pt2(1) = 3176
> pt3(0) = 4177: pt3(1) = 3539
> ' Dim oPoints As AeccPoints
> ' Set oPoints = g_oAeccDoc.Points
>
>
>
> Set oPoint1 = oPoints.Item("point1") ' avoid duplication
> If oPoint1 Is Nothing Then
> Set oPoint1 = oPoints.Add(pt1)
> oPoint1.Name = "point1"
> oPoint1.LabelStyle = g_oAeccDoc.PointLabelStyles.Item(0)
> End If
> Debug.Print oPoint1.RawDescription
> Debug.Print oPoint1.FullDescription
>
> Set oPoint2 = oPoints.Add(pt2)
> oPoint2.Name = "point2"
> oPoint2.LabelStyle = g_oAeccDoc.PointLabelStyles.Item(0)
>
> Set oPoint3 = oPoints.Add(pt3)
> oPoint3.Name = "point3"
> oPoint3.LabelStyle = g_oAeccDoc.PointLabelStyles.Item(0)
>
>
>
>
> Debug.Print "OK1"
> ' Cycle through the entities in modelspace
> For Each elem In ThisDrawing.ModelSpace
> With elem
> If (.EntityName = "Point") Then
> ' Change the height of the text entity
> pt(0) = elem.X
> pt(1) = elem.Y
> pt(2) = elem.Z
>
> Set oPoint2 = oPoints.Add(pt)
> oPoint2.Name = "Gpoint"
> oPoint2.LabelStyle = g_oAeccDoc.PointLabelStyles.Item(0)
> Debug.Print "OK"
>
> ' .Update
> found = True
> End If
> End With
> Set elem = Nothing
> Next elem
>
>
>
>
> Dim oPtGroups As AeccPointGroups
> Dim oPtGroup As AeccPointGroup
> Set oPtGroups = g_oAeccDoc.PointGroups
> If oPtGroups Is Nothing Then
> createPointsPointGroups = False
> Exit Function
> End If
>
> Set oPtGroup = oPtGroups.Item("Sample point group")
> If Err.Number <> 0 Then
> Set oPtGroup = oPtGroups.Add("Sample point group")
> End If
>
> oPtGroup.QueryBuilder.IncludeNames = "point1"
> '
> If oPtGroup.ContainsPoint(oPoint1.Number) = False Then
> Debug.Print "No points are contained in the point group."
> End If
>
> ' add the point group to the surface
> ' the surface will automatically rebuild
> '
> ' Dim oSurf As AeccSurface
> ' Set oSurf = g_oAeccDoc.Surfaces.Item(0)
> ' If oSurf Is Nothing Then
> ' MsgBox "Error: no surface exists. Make sure you create a surface
first."
> ''' createPointsPointGroups = False
> ' Exit Function
> ' End If
> ' If oSurf.Type = aecckTinSurface Then
> ' Dim oTinSurf As AeccTinSurface
> ' Set oTinSurf = oSurf
> ' oTinSurf.Update
> ' oTinSurf.PointGroups.Add oPtGroup
> ' End If
>
> g_oCivilApp.Update
>
> createPointsPointGroups = True
>
> End Function