VBA question creating C3D points

[XXL66]

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

[Anonymous]

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