3Dの点をﾘﾝｸ付きでｽｹｯﾁ投影

COEでこちらの記述を見て、作ってみました。
http://www.coe.org/p/fo/st/thread=29815

ﾚｽしたものはｲﾝﾃﾞﾝﾄが消えてしまっているので

Sub CATMain()
    'HybridBody-Points
    Dim HBdy As HybridBody
    Set HBdy = SelectItem("Select a HybridBody : ESC = Cancel", Array("HybridBody"))
    If HBdy Is Nothing Then Exit Sub
    
    'Part
    Dim Pt As Part: Set Pt = GetParent_Of_T(HBdy, "Part")
    If Pt Is Nothing Then Exit Sub
    
    'Point Refs
    Dim PntRefLst As Collection: Set PntRefLst = GetPntRefs(HBdy, Pt)
    If PntRefLst Is Nothing Then Exit Sub
    
    'Sketch_Support
    Dim Pln As Plane
    Set Pln = SelectItem("Select a Sketch_Support_Plane : ESC = Cancel", Array("Plane"))
    If Pln Is Nothing Then Exit Sub
    
    'Part Check
    Dim TmpPt As Part: Set TmpPt = GetParent_Of_T(Pln, "Part")
    If Not (Pt Is TmpPt) Then
        MsgBox "Please choose the Plane of the same Part!"
        Exit Sub
    End If
    
    'HybridBody_Sketch
    Dim NewHbdy As HybridBody: Set NewHbdy = Pt.HybridBodies.Add()
    Dim Skt As Sketch: Set Skt = InitSketch(NewHbdy, Pt.CreateReferenceFromObject(Pln))
    
    'Projection
    Call ProjectionPnts(Skt, PntRefLst)
    Pt.UpdateObject Skt
    
    MsgBox "Done"
End Sub

'点投影
Private Sub ProjectionPnts(ByVal Skt As Sketch, ByVal PntRefLst As Collection)
    Dim Fact2D As Factory2D
    Dim Ref As Reference
    Dim Geos As GeometricElements
    
    On Error Resume Next
        Set Fact2D = Skt.OpenEdition()
        For Each Ref In PntRefLst
            Set Geos = Fact2D.CreateProjections(Ref)
            Geos.Item(1).Name = Ref.DisplayName
        Next
        Skt.CloseEdition
    On Error GoTo 0
End Sub

'ｽｹｯﾁ生成
Private Function InitSketch(ByVal HBdy As HybridBody, ByVal SktSptRef As Reference) As Sketch
    Set InitSketch = HBdy.HybridSketches.Add(SktSptRef)
End Function

'点ﾘﾌｧﾚﾝｽ取得
Private Function GetPntRefs(ByVal HBdy As HybridBody, ByVal Pt As Part) As Collection
    Set GetPntRefs = Nothing
    
    Dim HShps As HybridShapes: Set HShps = HBdy.HybridShapes
    If HShps.Count < 1 Then Exit Function
    
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    
    Dim PntRefLst As Collection: Set PntRefLst = New Collection
    Dim HShp As HybridShape
    For Each HShp In HShps
        If Fact.GetGeometricalFeatureType(HShp) = 1 Then
            PntRefLst.Add Pt.CreateReferenceFromObject(HShp)
        End If
    Next
    If PntRefLst.Count < 1 Then Exit Function
    
    Set GetPntRefs = PntRefLst
End Function


'選択
''' @param:Msg-ﾒｯｾｰｼﾞ
''' @param:Filter-array(string),string 選択ﾌｨﾙﾀｰ(指定無し時AnyObject)
''' @return:AnyObject
Private Function SelectItem(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As AnyObject
    Dim SE As SelectedElement
    Set SE = SelectElement(Msg, Filter)
    
    If IsNothing(SE) Then
        Set SelectItem = SE
    Else
        Set SelectItem = SE.Value
    End If
End Function

'選択
''' @param:Msg-ﾒｯｾｰｼﾞ
''' @param:Filter-array(string),string 選択ﾌｨﾙﾀｰ(指定無し時AnyObject)
''' @return:SelectedElement
Private Function SelectElement(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As SelectedElement
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SelectElement = Sel.Item(1)
    Sel.Clear
End Function

'T型のParent取得 Nameでのﾁｪｯｸも必要
''' @param:AOj-AnyObject
''' @param:T-String
''' @return:AnyObject
Private Function GetParent_Of_T(ByVal AOj As AnyObject, ByVal t$) As AnyObject
    If TypeName(AOj) = TypeName(AOj.Parent) And _
       AOj.Name = AOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AOj) = t Then
        Set GetParent_Of_T = AOj
    Else
        Set GetParent_Of_T = GetParent_Of_T(AOj.Parent, t)
    End If
End Function

作ったものは、ｽｹｯﾁから全て作ってしまうﾏｸﾛなんですが、
質問者の望んでいるものは、手動でｽｹｯﾁに投影したものの
ﾘﾝｸ元の名前に取得したい　ってことだろうと
ﾚｽした後に気が付きました･･･。