---

Teil2.CATPart

Hallo zusammen
leider bin ich in der Programmierung nicht sehr begabt (um ehrlich gesagt hasse ich es zu programmieren und werde nur wahnsinnig dabei   ) , deshalb erbitte ich um etwas Unterstützung.
Ich hab mir schon einige Bespiele angeguckt, doch leider blicke ich bei der Sache einfach nicht durch -.-
Mein Aufgabe ist es Punkte aus einer Zeichnung auszulesen und diese anschließend in einer .txt datei abzuspeichern (die Koordinaten x,y,z).
Man muss sich das so vorstellen.
Es gibt 20 Skizzen, die sich in einem Körper X befinden. Jede Skizze besteht aus einem Punkteprofil. Alle Punkte müssen nun aus jeden Skizzen ausgelesen werden ( die Positionen) und in einer txt Datei gespeichert werden. Eine Bsp Datei ist im Anhang
Vielen Dank schon mal

[Diese Nachricht wurde von Jo Hannes am 06. Okt. 2012 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

das Resultat sollte ca so aussehen:
Skizze 1
0.123123      1231231231    121241243242
32423523      12312341421    124124124124
.
.
.

Skizze 2
0.123123      1231231231    121241243242
32423523      12312341421    124124124124
.
.
.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Servus
Willkommen im Form. Bitte Systeminfo ausfüllen.
Wie weit bist du mit deinem Makro gekommen?
Falls es such m eine einmalige Aufgabe handelt könntest du auch einen Workaround verwenden:
- Datei als STEP abspeichern und mit einem Texteditor "ausmisten"

Gruß
Bernd

------------------
Warum einfach, wenn es auch kompliziert geht.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Super Tipp
wieso bin ich nicht früher darauf gekommen

Ich arbeite mit V5R19

ich hab versucht diesen Code anzupassen, was mir nicht gelungen ist

Code:
Sub CATMain()

'by DANIEL FRAUENRATH
'Version: 1.1

    '***DEKLARATION
    Dim objPartDoc As PartDocument
    Dim objPart As Part
    Dim objSPAWB As Workbench
    Dim objSel As Selection
    Dim strSelString As String
    Dim objPointColl() As Object
    Dim i As Long
    Dim objPoint As Variant
    Dim dblYValue As Double
    Dim arrPointCoord(2)
    Dim booMinusCheck As Boolean
    Dim objPointRef As Reference
    Dim objMeasurable As Object
    Dim objMsgBoxRes As VbMsgBoxResult
    Dim objPointFailColl()
    Dim objPointPassColl() As Object

    '***PART DOKUMENT HOLEN (TYP ABRFRAGE)
    On Error Resume Next
    Set objPartDoc = CATIA.ActiveDocument
    Set objPart = objPartDoc.Part
    Set objSPAWB = objPartDoc.GetWorkbench("SPAWorkbench")
    If Err.Number <> 0 Then
        MsgBox "Das aktive Dokument ist kein CATPart!", vbExclamation, "ABBRUCH"
        Exit Sub
    Else
        On Error GoTo 0
    End If

    '***PUNKTE SELEKTIEREN
    Set objSel = objPartDoc.Selection
    objSel.Clear
    strSelString = "(((((CATStFreeStyleSearch.Point + CATSketchSearch.2DPoint) + CATDrwSearch.2DPoint) + CATPrtSearch.Point) + CATGmoSearch.Point) + CATSpdSearch.Point),all"
    CATIA.HSOSynchronized = False
    objSel.Search CStr(strSelString)
    CATIA.HSOSynchronized = True

    If objSel.Count = 0 Then
        MsgBox "Es wurden keine Punkt-Features im Dokument gefunden!", vbExclamation, "KEINE PUNKTE"
        objSel.Clear
        Exit Sub
    Else
        ReDim objPointColl(objSel.Count - 1)
        ReDim objPointPassColl(objSel.Count - 1)
        For i = 0 To objSel.Count - 1
            Set objPointColl(i) = objSel.Item(i + 1).Value
        Next
        objSel.Clear
    End If

    '***Y-KOORDINATEN ABFRAGEN
 
    ReDim Preserve objPointFailColl(0)
 
    For Each objPoint In objPointColl
        If TypeName(objPoint) = "HybridShapePointCoord" Then
            lngYValue = objPoint.Y.Value
        ElseIf TypeName(objPoint) = "Point2D" Then
            Set objPointRef = objPart.CreateReferenceFromObject(objPoint)
            Set objMeasurable = objSPAWB.GetMeasurable(objPointRef)
            objMeasurable.GetPoint arrPointCoord
            lngYValue = arrPointCoord(1)
        Else
            objPoint.GetCoordinates arrPointCoord
            lngYValue = arrPointCoord(1)
        End If
   
        If CheckValue(lngYValue) = True Then
            If UBound(objPointFailColl) = 0 Then
              ReDim Preserve objPointFailColl(UBound(objPointFailColl) + 2)
            Else
                ReDim Preserve objPointFailColl(UBound(objPointFailColl) + 3)
            End If
            Set objPointFailColl(UBound(objPointFailColl) - 2) = objPoint
            objPointFailColl(UBound(objPointFailColl) - 1) = objPoint.Name
            objPointFailColl(UBound(objPointFailColl)) = lngYValue
        End If
    Next

    '***ERGEBNISSAUSGABE
    Dim strMsgTitle As String
    Dim objMsgSkin As VbMsgBoxStyle
    Dim M1, M2, strMsgBody As String
   
    If UBound(objPointFailColl) <= 1 Then
        MsgBox "Es wurden keine Punkte mit negativen Y-Wert gefunden!", vbInformation, "KEINE NEGATIVEN PUNKTE GEFUNDEN"
    Else
        '***GRUNDEINSTELLUNG MSGBOX
        strMsgTitle = "NEGATIVE Y-WERTE GEFUNDEN"
        objMsgSkin = vbExclamation + vbYesNo + vbDefaultButton2
        M1 = "Folgende Punkte wurden mit negativen Y-Werten indentifiziert!"
        M2 = "Wollen Sie den/die Punkte(e) selektieren?"
        For i = 0 To UBound(objPointFailColl) Step 3
          strMsgBody = strMsgBody + vbNewLine + _
                        "Punktname:" + vbTab + objPointFailColl(i + 1) + vbNewLine + _
                        "Y-Koordinate:" + vbTab + CStr(objPointFailColl(i + 2)) + vbNewLine
        Next
     
        objMsgBoxRes = MsgBox(M1 + vbNewLine + vbNewLine + strMsgBody + vbNewLine + vbNewLine + M2, objMsgSkin, strMsgTitle)
     
        If objMsgBoxRes = vbYes Then
            For i = 0 To UBound(objPointFailColl) Step 3
                objSel.Add objPointFailColl(i)
            Next
        End If
    End If

End Sub

Private Function CheckValue(ByVal lngYValue As Double) As Boolean

    '***VERGLEICH MIT NULL
    If lngYValue < 0 Then
        CheckValue = True
    Else
        CheckValue = False
    End If

End Function

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP