Sub CATMain()
'*********************************************************
'Copyright: Airbus Bremen
'
'Language:  VB
'Date: 29-07-04
'CATIA Level: Catia V5 Release 11

'*********************************************************
   
   
Dim Zeile, strFile As String
Dim datname As String
Dim datei, datout As File
Dim EOL As String
Dim DStrom As TextStream
Dim DataStrom
Dim x, y, z As Double
Dim I, k, J, L As Integer
Dim partDocument1 As PartDocument
Dim part1 As Part
Dim hybridShapeFactory1 As HybridShapeFactory
Dim hybridShapePointCoord(10000) As hybridShapePointCoord
Dim PointBodies As HybridBodies
Dim PointBody As HybridBody
Dim Result As Long
Dim array1, array2, array3 As Variant
Dim spoint(2), test(2)
Dim axisSystem1 As AxisSystem
Dim reference4(1000), reference5(1000) As Reference
Dim reference1, reference2, reference3 As Reference
Dim TheSPAWorkbench As SPAWorkbench
Dim TheMeasurable1  As Object

Dim hybridBodies1 As HybridBodies
Dim hybridBody1 As HybridBody
Dim hybridShapes1 As HybridShapes
Dim hybridBody2 As HybridBody
Dim hybridBodies2 As HybridBodies
Dim hybridBody3 As HybridBody
Dim hybridShapes2 As HybridShapes
Dim hybridShapeAxisToAxis1(1000) As HybridShapeAxisToAxis
Dim hybridShapeProject1 As HybridShapeProject


Dim UserSel
Dim TheMeasurable As Object
Dim e As String
Dim was(0)
Dim weiter, exist_pro As Boolean

EOL = Chr(10)
Result = vbNo
 
Do While Result = vbNo
  strFile = CATIA.FileSelectionBox("Datei auswählen", "*.*", CatFileSelectionModeOpen)
  If (strFile <> "") Then
    Result = vbYes
  Else
    Result = MsgBox("Durch Das Drücken auf Abbrechen wird das Programm beendet" _
                    & Chr(10) & "Soll das Programm wirklich beendet werden?", vbYesNo + vbQuestion, "ShapeVis")
  End If
Loop
  
Set datei = CATIA.FileSystem.GetFile(strFile)
k = 1

InputBoxText = "Bitte geben Sie an in welche Datei (gesamter Pfad z.B. c:\TEMP\test.csv) " & Chr(10) & "die Daten geschrieben werden sollen."
datname = InputBox(InputBoxText, "File eingeben", datname)
If datname = "" Then
  datname = "c:\TEMP\test.csv"
End If

Set datout = CATIA.FileSystem.CreateFile(datname, True)
Set DStrom = datout.OpenAsTextStream("ForWriting")
  
If Err.Number <> 0 Then
  I = MsgBox("Datei nicht vorhanden", vbOKOnly, "Fehler")
Else


 
  Set partDocument1 = CATIA.ActiveDocument
  Set part1 = partDocument1.Part
  Set axisSystems1 = part1.AxisSystems
  Set axisSystem1 = axisSystems1.Item("Axis System.2 ( A340-300_SEC.32_MESS-AXIS_L - wsp *MASTER -  )")
  axisSystem1.IsCurrent = True

  Set hybridShapeFactory1 = part1.HybridShapeFactory
  Set PointBodies = CATIA.ActiveDocument.Part.HybridBodies
  Set SplineBodies = CATIA.ActiveDocument.Part.HybridBodies
  Set TheSPAWorkbench = CATIA.ActiveDocument.GetWorkbench("SPAWorkbench")
  
  ' Surface selectieren

was(0) = "HybridShapeAxisToAxis"

Set UserSel = CATIA.ActiveDocument.Selection
UserSel.Clear
weiter = True
J = 0
Do While weiter
'MsgBox ("SURFACE selectieren")
e = UserSel.SelectElement(was, "Surface aus wählen: ", True)
'MsgBox (e)
If e = "Normal" Then
 J = J + 1
 Set hybridShapeAxisToAxis1(J) = UserSel.Item(1).Value
 Set reference5(J) = part1.CreateReferenceFromObject(hybridShapeAxisToAxis1(J))
 MsgBox (reference5(J).DisplayName)
Else
' MsgBox ("Abbruch")
 weiter = False
End If
Loop


UserSel.EndSelectElement
UserSel.Clear
'MsgBox ("anzahl " & J)
  
  Set PointBody = PointBodies.Add
  
  PointBody.name = "PointBody"
 
  part1.Update

  Set DataStrom = datei.OpenAsTextStream("ForReading")
  If Err.Number <> 0 Then
    I = MsgBox("Datei konnt nicht geöffnet werden", vbOKOnly, "Fehler")
  Else
        
    Do While (DataStrom.AtEndOfStream = False)
     '  Punkte einlesen
  
       zeile1 = DataStrom.ReadLine
       zeile2 = DataStrom.ReadLine
       zeile3 = DataStrom.ReadLine
       zeile4 = DataStrom.ReadLine
       
       ' X Coordinate lesen
    
         array1 = Split(zeile2, ";")
         x = array1(2)
    
       ' y Coordinate lesen
         array2 = Split(zeile3, ";")
         y = array2(2)
    
       ' z Coordinate lesen
         
         
         array3 = Split(zeile4, ";")
         z = array3(2)
        'MsgBox (x & y & z)
        
         Set hybridShapePointCoord(k) = hybridShapeFactory1.AddNewPointCoord(x, y, z)
         hybridShapePointCoord(k).name = array1(0)
         PointBody.AppendHybridShape hybridShapePointCoord(k)
         'part1.InWorkObject = hybridShapePointCoord(k)
         Set reference1 = part1.CreateReferenceFromObject(hybridShapePointCoord(k))
         
          'part1.Update
        
         
   ' Projection des Punktes auf die Fläche '
        
          

          Set hybridBodies1 = part1.HybridBodies
          'Set hybridBody1 = hybridBodies1.Item("PointBody")
          L = 1
          exist_pro = True
          Do While (L <= J And exist_pro)
              
              'Set reference4(L) = part1.CreateReferenceFromObject(hybridShapeAxisToAxis1(L))
              'MsgBox (reference4(L).DisplayName)
              Set TheMeasurable = TheSPAWorkbench.GetMeasurable(reference5(L))
              Set hybridShapeProject1 = hybridShapeFactory1.AddNewProject(reference1, reference5(L))
              'MsgBox (reference5(L).DisplayName)
              hybridShapeProject1.SolutionType = 0
              hybridShapeProject1.Normal = True
              hybridShapeProject1.SmoothingType = 0
              
          
              On Error Resume Next
              'part1.UpdateObject (hybridShapeProject1)
              part1.InWorkObject = hybridShapeProject1
              part1.Update
                            If Err.Number = 0 Then

                   PointBody.AppendHybridShape hybridShapeProject1
                   'part1.InWorkObject = hybridShapeProject1
                   part1.Update
                   Set reference3 = part1.CreateReferenceFromObject(hybridShapeProject1)
                   Set TheMeasurable1 = TheSPAWorkbench.GetMeasurable(reference3)
                   TheMeasurable1.GetPoint test
                   MsgBox ("projection inserted ")
                   exist_pro = False
               Else
               ' hier müsste die erzeugte falsche Projection gelöscht werden
               'MsgBox ("weitere Flächelesen")
               End If
               L = L + 1
            On Error GoTo 0
          Loop
         On Error GoTo 0
        'part1.Update
                   
        DStrom.Write Format(x, "###0.000") & " ; " & Format(y, "###0.000") & " ; " & Format(z, "###0.000") & " ; " & Format(test(0), "###0.000") & ";" & Format(test(1), "###0.000") & ";" & Format(test(2), "###0.000") & EOL
    test(0) = 0#
    test(1) = 0#
    test(2) = 0#
    k = k + 1
Loop
 'Schliessen des Lesevorgangs
  End If
  DataStrom.Close
  DatoutEnde = DStrom.AtEndOfStream
  DStrom.Close
End If

End Sub