---

Hallo Experten!
Ich habe mal ein Makro geschrieben, welches export Punkte aus dem Part zum Excel (mit seine Coordinaten, Namen usw.)
Alles lauft sauber nur fuer einzelnem Part. (Ich habe das mit Selektion und GetNameToUseInRelation gemacht).
Bei anderem Fall habe ich ganze Produkt-Struktur mit mehrere Parts mit Punkten.
Kann mir jemand hilfen, wie soll ich jetzt machen mit meinem Makro, wenn ich will alle Punkten vom jedem Part nutzten?
Ich habe versucht alle Punkten mit selektion markieren, aber ich weisst nicht wie kann ich parameters aus einzelnes Punkt kriegen (leafproduct?).
Sorry fuer mein schlecht Deutsch.
Anbei mein Code (ein Teil des Codes ist Müll - sorry):

Code:

---

Sub CATMain()

Wersja.Hide
'_________________________________________
' Separating char
Dim trz As String, crlf As String
trz = ";"
crlf = Chr(10)
'-----------------------------------------
'RegEx
Dim reg As String
reg = "([\w]{3}\.[\w]{3}\.[\w]{3})"
'-----------------------------------------
Set Document = CATIA.ActiveDocument
Set filesys = CATIA.FileSystem
CATIA.ActiveWindow.ActiveViewer.Reframe
'__________________________________________________________________________
' Filename and path
'on error resume next
Dim Nfile As String

Nfile = Document.name
Dim path As String, Nazwa As String, filename As String

path = Left(Document.FullName, InStrRev(Document.FullName, "\"))
pathdummy = Left(path, Len(path) - 1)
Nazwa = Left(Nfile, InStr(Nfile, ".") - 1)

If Wersja.PT_all = True Then
    filename = "D:\" & Nazwa & "_point_exp_all"
ElseIf Wersja.PT_scr = True Then
    filename = "D:\" & Nazwa & "_point_exp_visible"
ElseIf Wersja.PT_NoShow = True Then
    filename = "D:\" & Nazwa & "_point_exp_not_visible"
End If

'--------------------------------------------------------------------------
Dim selection1 As Selection

Set selection1 = Document.Selection
selection1.Clear

If Wersja.PT_all = True Then
    selection1.Search "((((CATStFreeStyleSearch.Point + CATSketchSearch.2DPoint) + CATDrwSearch.2DPoint) + CATPrtSearch.Point) + CATGmoSearch.Point),all"
ElseIf Wersja.PT_scr = True Then
    selection1.Search "((((CATStFreeStyleSearch.Point + CATSketchSearch.2DPoint) + CATDrwSearch.2DPoint) + CATPrtSearch.Point) + CATGmoSearch.Point),scr"
ElseIf Wersja.PT_NoShow = True Then
    CATIA.ActiveDocument.SeeHiddenElements = True
    selection1.Search "((((CATStFreeStyleSearch.Point + CATSketchSearch.2DPoint) + CATDrwSearch.2DPoint) + CATPrtSearch.Point) + CATGmoSearch.Point),scr"
End If

If Err <> 0 Then
MsgBox ("Didn't find any points!")
End If

Dim coords(2)
Dim Params
Dim name, Cname
Dim Splitnametemp
Dim A As String, B As String, C As String, D As String
Set Params = Document.Part.Parameters
'ograniczenie tylko do SWP

Dim SWP_kol As New VBA.Collection
Dim MAG_kol As New VBA.Collection
Dim MIG_kol As New VBA.Collection
Dim LaserS_kol As New VBA.Collection
Dim Abt_kol As New VBA.Collection
Dim Kleb_kol As New VBA.Collection

Dim CMAG_kol As New VBA.Collection
Dim CMIG_kol As New VBA.Collection
Dim CLaserS_kol As New VBA.Collection

For i = 1 To selection1.Count
    Set Element = selection1.Item(i)
    Set Point = Element.Value
    name = Params.GetNameToUseInRelation(Point)
    If InStr(1, name, "\MAG") <> 0 Then
        MAG_kol.Add Point
    ElseIf InStr(1, name, "\MIG") <> 0 Then
        MIG_kol.Add Point
    ElseIf InStr(1, name, "\LaserS") <> 0 Then
        LaserS_kol.Add Point
    ElseIf InStr(1, name, "\Abdichtungen") <> 0 Then
        Abt_kol.Add Point
    ElseIf InStr(1, name, "\Klebungen") <> 0 Then
        Kleb_kol.Add Point
    ElseIf InStr(1, name, "\SWP und Naehte") <> 0 Then
        SWP_kol.Add Point
    End If
       
Next

'tworzenie EXCELa

Dim Excel As Object
Dim workbooks1 As workbooks
Dim workbook1 As Workbook
Dim sheets As Object
Dim sheet As Object
Dim worksheet As Excel.worksheet
Dim wrkbook As Excel.Workbook
Dim worksh2 As Excel.worksheet
Set Excel = CreateObject("EXCEL.application")
Excel.Visible = True

Set workbooks1 = Excel.workbooks
Set workbook1 = workbooks1.Add
workbook1.SaveAs filename
workbook1.ActiveSheet.name = "OUT_PPS"

Excel.Cells(1, 1) = "Point Name"
Excel.Cells(1, 2) = "X-Coor"
Excel.Cells(1, 3) = "Y-Coor"
Excel.Cells(1, 4) = "Z-Coor"
Excel.Cells(1, 5) = "Technologia"
Excel.Columns(6).NumberFormat = "@"
Excel.Cells(1, 6) = "Joint Group"

'-----------------------------------SWP----------------------------
For s = 1 To SWP_kol.Count
    Set Element = SWP_kol.Item(s)
    Set Point = Element '.Value
    Point.name = "Point." & s
    Point.GetCoordinates coords
    name = Params.GetNameToUseInRelation(Point)
    Splitnametemp = Split(name, "\")
   
Excel.Cells(s + 1, 1) = Left(Splitnametemp(3), Len(Splitnametemp(3))) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + 1, 2) = coords(0)
Excel.Cells(s + 1, 3) = coords(1)
Excel.Cells(s + 1, 4) = coords(2)
Excel.Cells(s + 1, 5) = Splitnametemp(2) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + 1, 6) = Mid(Splitnametemp(0), 33, 3)

Next

'-----------------------------------MAG----------------------------
For k = 1 To MAG_kol.Count
    Set Element = MAG_kol.Item(k)
    Set Point = Element '.Value
    Point.name = "Point." & s + k - 1
    Point.GetCoordinates coords
    name = Params.GetNameToUseInRelation(Point)
    Splitnametemp = Split(name, "\")
   
Excel.Cells(s + k, 1) = Left(Splitnametemp(3), Len(Splitnametemp(3)))  'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + k, 2) = coords(0)
Excel.Cells(s + k, 3) = coords(1)
Excel.Cells(s + k, 4) = coords(2)
Excel.Cells(s + k, 5) = Splitnametemp(2) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 2)
Excel.Cells(s + k, 6) = Mid(Splitnametemp(0), 33, 3)

Next
'-----------------------------------MIG----------------------------
For n = 1 To MIG_kol.Count
    Set Element = MIG_kol.Item(n)
    Set Point = Element '.Value
    Point.name = "Point." & s + k + n - 2
    Point.GetCoordinates coords
    name = Params.GetNameToUseInRelation(Point)
    Splitnametemp = Split(name, "\")
   
Excel.Cells(s + k + n - 1, 1) = Left(Splitnametemp(3), Len(Splitnametemp(3))) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + k + n - 1, 2) = coords(0)
Excel.Cells(s + k + n - 1, 3) = coords(1)
Excel.Cells(s + k + n - 1, 4) = coords(2)
Excel.Cells(s + k + n - 1, 5) = Splitnametemp(2) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 2)
Excel.Cells(s + k + n - 1, 6) = Mid(Splitnametemp(0), 33, 3)

Next
'-----------------------------------LASER_S----------------------------
For no = 1 To LaserS_kol.Count
    Set Element = CLaserS_kol.Item(no)
    Set Point = Element '.Value
    Point.name = "Point." & s + k + n + no - 3
    Point.GetCoordinates coords
    name = Params.GetNameToUseInRelation(Point)
    Splitnametemp = Split(name, "\")
   
Excel.Cells(s + k + n + no - 2, 1) = Left(Splitnametemp(3), Len(Splitnametemp(3))) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + k + n + no - 2, 2) = coords(0)
Excel.Cells(s + k + n + no - 2, 3) = coords(1)
Excel.Cells(s + k + n + no - 2, 4) = coords(2)
Excel.Cells(s + k + n + no - 2, 5) = Splitnametemp(2) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 2)
Excel.Cells(s + k + n + no - 2, 6) = Mid(Splitnametemp(0), 33, 3)

Next
'-----------------------------------ABDICHTUNGEN----------------------------
For abd = 1 To Abt_kol.Count
    Set Element = Abt_kol.Item(abd)
    Set Point = Element '.Value
    Point.name = "Point." & s + k + n + no + abd - 4
    Point.GetCoordinates coords
    name = Params.GetNameToUseInRelation(Point)
    Splitnametemp = Split(name, "\")
   
Excel.Cells(s + k + n + no + abd - 3, 1) = Left(Splitnametemp(3), Len(Splitnametemp(3))) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + k + n + no + abd - 3, 2) = coords(0)
Excel.Cells(s + k + n + no + abd - 3, 3) = coords(1)
Excel.Cells(s + k + n + no + abd - 3, 4) = coords(2)
Excel.Cells(s + k + n + no + abd - 3, 5) = Splitnametemp(2) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 2)
Excel.Cells(s + k + n + no + abd - 3, 6) = Mid(Splitnametemp(0), 33, 3)

Next
'-----------------------------------KLEBUNGEN----------------------------
For kl = 1 To Kleb_kol.Count
    Set Element = Kleb_kol.Item(kl)
    Set Point = Element '.Value
    Point.name = "Point." & s + k + n + no + abd + kl - 5
    Point.GetCoordinates coords
    name = Params.GetNameToUseInRelation(Point)
    Splitnametemp = Split(name, "\")
   
Excel.Cells(s + k + n + no + abd + kl - 4, 1) = Left(Splitnametemp(3), Len(Splitnametemp(3))) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 1)
Excel.Cells(s + k + n + no + abd + kl - 4, 2) = coords(0)
Excel.Cells(s + k + n + no + abd + kl - 4, 3) = coords(1)
Excel.Cells(s + k + n + no + abd + kl - 4, 4) = coords(2)
Excel.Cells(s + k + n + no + abd + kl - 4, 5) = Splitnametemp(2) 'Left(Splitnametemp(UBound(Splitnametemp)), Len(Splitnametemp(UBound(Splitnametemp))) - 2)
Excel.Cells(s + k + n + no + abd + kl - 4, 6) = Mid(Splitnametemp(0), 33, 3)

Next

CATIA.ActiveDocument.Part.Update

End Sub

---

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

---

Hi Sylas,

first off: I don't like using variable names like 'point' or 'name'.
Why? They're dangerous. Both have a special meaning within the CAA.
Better call them oPt and strName.

Code:

---

  For i = 1 To selection1.Count
      Set Element = selection1.Item(i)
      Set Point = Element.Value
      name = Params.GetNameToUseInRelation(Point)
      If InStr(1, name, "\MAG") <> 0 Then
        MAG_kol.Add Point
      ElseIf InStr(1, name, "\MIG") <> 0 Then
        MIG_kol.Add Point
      ElseIf InStr(1, name, "\LaserS") <> 0 Then
        LaserS_kol.Add Point
      ElseIf InStr(1, name, "\Abdichtungen") <> 0 Then
        Abt_kol.Add Point
      ElseIf InStr(1, name, "\Klebungen") <> 0 Then
        Kleb_kol.Add Point
      ElseIf InStr(1, name, "\SWP und Naehte") <> 0 Then
        SWP_kol.Add Point
      End If
  Next

---

Zu Deinem LeafProduct-Thema:
- Du hast eine funktionierende Routine für Catparts
- Du hast ein Product mit mehreren Catparts mit Punkten

Warum durchläufst Du nicht das Product um dann die Parts an die Part-Routine zu übergeben?

zB so:

Code:

---

Sub catmain()
  Dim oRootProd As Product

  Set oRootProd = CATIA.ActiveDocument.Product
  RunTree oRootProd
End Sub

Sub RunTree(oRoot As Product)
  Dim oProdItem As Object                                'Product
  Dim i As Integer
 
  For i = 1 To oRoot.Products.Count
      '    MsgBox oRoot.Products.Item(i).Name
      Set oProdItem = oRoot.Products.Item(i)
      oProdItem.ApplyWorkMode (DESIGN_MODE)                'set work mode
      DoEvents
      '---------------------------------------------------------------------------------------
      'PRODUCT LEVEL
      If TypeName(oProdItem.ReferenceProduct.Parent) = "ProductDocument" Then
        Debug.Print oProdItem.name
        RunTree oProdItem                                'reenter one level down
        '---------------------------------------------------------------------------------------
        'PART LEVEL
      ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then
        Debug.Print oProdItem.name
        'do something with the part
      End If
  Next
End Sub

---

Die 'Debug.Print'-Anweisungen sind nur zur Kontrolle.

Hope it helps,
Joe

------------------
Inoffizielle Catia Hilfeseite

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

---

Hallo Joe
Danke fuer deinem Post.
Wenn ich das richtig verstand habe, ich kann durch ganze Baum gehen, Part per Part und mein altes Code fuer jedes laufen?
Also so etwas:

Code:

---

ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then
        'hier altes Code
      End If

---

?

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

---

Hi Sylas,

anstatt den Code direkt einzufügen - geht wahrscheinlich auch - würde ich eine andere Routine aufrufen,
Also anstatt

Code:

---

  ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then
        'hier altes Code
  End If

---

lieber

Code:

---

  ElseIf TypeName(oProdItem.ReferenceProduct.Parent) = "PartDocument" Then
        'Sub mit altem Code aufrufen
  End If

---

Die Collections wirst dann aber wahrscheinlich global deklarieren müssen.

Stichworte: Scope of variables; Sub; Function;

Tschau,
Joe

------------------
Inoffizielle Catia Hilfeseite

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