---

Halo Leute!

Ich habe Mal eines kleines Problem: Ich möchte ein Ergebnis von ein Makro geschreibt hier:

http://ww3.cad.de/foren/ubb/Forum137/HTML/005410.shtml

unter Excel oder txt-Datei speichern.

Ich habe etwas so geschrieben:

Code:

---

Sub CATMain()
Dim ProdDoc As ProductDocument
Dim osel As Selection
Dim objSel As Object
Dim i As Integer
Dim PartProduct 'As Product

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ------------

Dim objGEXCELapp As Object
Dim objGEXCELwkBks As Object
Dim objGEXCELwkBk As Object
Dim objGEXCELwkShs As Object
Dim objGEXCELSh As Object
'Dim fs, f, f1, fc, s
'Dim coords(2) As Integer
'Dim PartDocument1

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ------------

'Dokument geöffnet
If CATIA.Windows.Count = 0 Then
    Exit Sub
End If

'CATProduct geöffnet
If TypeName(CATIA.ActiveDocument) <> "ProductDocument" Then
    MsgBox "Keine CATProduct geöffnet"
    Exit Sub
End If

'Start
Set ProdDoc = CATIA.ActiveDocument
Set objSel = ProdDoc.Selection
Set osel = objSel

'Suche
osel.Clear
osel.Search "(CATAsmSearch.Part.Name=*ADAPTER* + CATAsmSearch.Part.Name=*DRUCK* + CATAsmSearch.Part.Name=*KONTUR* + CATAsmSearch.Part.Name=*AUFLAGE*),all"

'Vergleichsarray erstellen
Dim NullPosArray
NullPosArray = Array(1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0)
Dim PosArray(11)

'Position auslesen und vergleichen
For i = osel.Count2 to 1 Step -1
      Set PartProduct = osel.Item2(i).Value
      'PartProduct.Position.GetComponents PosArray
      PartProduct.Position.GetComponents (PosArray)
      If not CompareArrays(PosArray, NullPosArray) Then
MsgList = osel.Item(i).Value.Name & Chr(10) & MsgList

End If
Next
if len(MsgList)=0 then
MsgList = "Kein Teil welsches auf AutoNull liegt!"

end if

MsgBox MsgList

StartEXCEL

Export

End Sub

Function CompareArrays(ByRef arr1(), ByRef arr2()) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If arr1(i) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next
    CompareArrays = True
End Function

'------------------------------------------------------------------------------------------------------------------------------------------------------

'******************************************************************************
Sub StartEXCEL()
'******************************************************************************
Err.Clear
On Error Resume Next
Set objGEXCELapp = GetObject (,"EXCEL.Application")

If Err.Number <> 0 Then
Err.Clear
Set objGEXCELapp = CreateObject ("EXCEL.Application")
End If
objGEXCELapp.Application.Visible = TRUE
Set objGEXCELwkBks = objGEXCELapp.Application.WorkBooks
Set objGEXCELwkBk = objGEXCELwkBks.Add
Set objGEXCELwkShs = objGEXCELwkBk.Worksheets(1)
Set objGEXCELSh = objGEXCELwkBk.Sheets (1)
objGEXCELSh.Cells (1,"A") = "Name"

End Sub
'******************************************************************************
Sub Export()
'******************************************************************************
For i = 1 To osel.Count
Set selection = osel.Selection
Set element = selection.Item(i).name
Set val = element.value
'Write PointData to Excel Sheet
objGEXCELSh.Cells (i+1,"A") = val

Next
End Sub

---

Das Ergebnis ist das ein Document in EXCEL ist geöffnet, und nur die erste Linie ist ausgefüllt.
Kann jemand der Code durch gucken und prüfen?

Danke im Voraus

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

---

Versuch mal folgende Code:

Code:

---

public objGEXCELSh
public j

Sub CATMain()

Dim val As String
Dim objGEXCELapp As Object
Dim objGEXCELwkBks As Object
Dim objGEXCELwkBk As Object
Dim objGEXCELwkShs As Object
'Dim objGEXCELSh As Object

Dim ProdDoc As ProductDocument
Dim osel As Selection
Dim objSel As Object
'Dim i As Integer
Dim PartProduct 'As Product
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------  ------------

j=1
'Dim fs, f, f1, fc, s
'Dim coords(2) As Integer
'Dim PartDocument1

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------  ------------

'Dokument geöffnet
If CATIA.Windows.Count = 0 Then
    Exit Sub
End If

'CATProduct geöffnet
If TypeName(CATIA.ActiveDocument) <> "ProductDocument" Then
    MsgBox "Keine CATProduct geöffnet"
    Exit Sub
End If

'Start
Set ProdDoc = CATIA.ActiveDocument
Set objSel = ProdDoc.Selection
Set osel = objSel

'Suche
osel.Clear
osel.Search "(CATAsmSearch.Part.Name=*ADAPTER* + CATAsmSearch.Part.Name=*DRUCK* + CATAsmSearch.Part.Name=*KONTUR* + CATAsmSearch.Part.Name=*AUFLAGE*),all"

'Vergleichsarray erstellen
Dim NullPosArray(11)
'NullPosArray = Array(1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0)
NullPosArray(0) = 1
NullPosArray(1) = 0
NullPosArray(2) = 0
NullPosArray(3) = 0
NullPosArray(4) = 1
NullPosArray(5) = 0
NullPosArray(6) = 0
NullPosArray(7) = 0
NullPosArray(8) = 1
NullPosArray(9) = 0
NullPosArray(10) = 0
NullPosArray(11) = 0

Dim PosArray(11)
Call StartEXCEL

'Position auslesen und vergleichen
For i = osel.Count2 To 1 Step -1
      Set PartProduct = osel.Item(i).Value
      PartProduct.Position.GetComponents PosArray
      'PartProduct.Position.GetComponents (PosArray)
      If Not CompareArrays(PosArray, NullPosArray) Then
      val = osel.Item(i).Value.Name
   
    Call Export(val)
'MsgList = osel.Item(i).Value.Name & Chr(10) & MsgList

End If
Next
If Len(MsgList) = 0 Then
MsgList = "Kein Teil welsches auf AutoNull liegt!"

End If

MsgBox MsgList

'StartEXCEL

'Export

End Sub

Function CompareArrays(ByRef arr1(), ByRef arr2()) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If arr1(i) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next
    CompareArrays = True
End Function

'------------------------------------------------------------------------------------------------------------------------------------------------------

'******************************************************************************
Sub StartEXCEL()
'******************************************************************************
Err.Clear
On Error Resume Next
Set objGEXCELapp = GetObject(, "EXCEL.Application")

If Err.Number <> 0 Then
Err.Clear
Set objGEXCELapp = CreateObject("EXCEL.Application")
End If
objGEXCELapp.Application.Visible = True
Set objGEXCELwkBks = objGEXCELapp.Application.WorkBooks
Set objGEXCELwkBk = objGEXCELwkBks.Add
Set objGEXCELwkShs = objGEXCELwkBk.Worksheets(1)
Set objGEXCELSh = objGEXCELwkBk.Sheets(1)
objGEXCELSh.Cells(1, "A") = "Name"

End Sub
'******************************************************************************
Sub Export(val)

j = j + 1
objGEXCELSh.Cells(j, "A") = val

End Sub

---

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

---

Das ist genau was ich meine! Viellen Dank für Augenblick-Antwort  

EDIT:

Irgendwas nicht i.O. ist...  Egal, ob die Parts in Auto-Null liegen oder nicht ein Excel-Datei ist erstellt. Mein Zeil ist, dass ich möchte ein Excel erstellt haben nur wenn es gibt ein Teil welcher ins Auto-Null nicht liegt ---> nicht immer. Wenn es gibt kein Teil, ein MsgBox soll eingeschaut sein: "Alle Teile sind in Auto-Null!" und kein xls-Datei ist erstellt.
Sorry für mein Deutsch. Ich habe das lang nicht genutzt - Ich hoffe dass alles klar ist.

[Diese Nachricht wurde von Sylas am 02. Dez. 2013 editiert.]

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

---

Halo

Weiß jemand wie kann ich das als TXT-Datei speichern? Unglücklicher, nicht jeder Rechner Excel-Lizenz hat...  

[Diese Nachricht wurde von Sylas am 03. Dez. 2013 editiert.]

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

---

Servus
Schau dir mal das Objekt "TextStream" in der API an (Beispiel siehe zB hier.

Gruß
Bernd

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

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

---

Code:

---

Sub CATMain()

Dim ProdDoc As ProductDocument
Dim osel 'As Selection
Dim objSel As Object
Dim i As Integer
Dim PartProduct 'As Product
Dim sFilePath As String

'Dokument geöffnet
If CATIA.Windows.Count = 0 Then
    Exit Sub
End If

'CATProduct geöffnet
If TypeName(CATIA.ActiveDocument) <> "ProductDocument" Then
    MsgBox "Keine CATProduct geöffnet"
    Exit Sub
End If

'Start
Set ProdDoc = CATIA.ActiveDocument

Set osel = ProdDoc.Selection

'Suche
osel.Clear
osel.Search "(CATAsmSearch.Part.Name=*ADAPTER* + CATAsmSearch.Part.Name=*DRUCK* + CATAsmSearch.Part.Name=*KONTUR* + CATAsmSearch.Part.Name=*AUFLAGE*),all"

'Vergleichsarray erstellen
Dim NullPosArray(11)
'NullPosArray = Array(1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0)
NullPosArray(0) = 1
NullPosArray(1) = 0
NullPosArray(2) = 0
NullPosArray(3) = 0
NullPosArray(4) = 1
NullPosArray(5) = 0
NullPosArray(6) = 0
NullPosArray(7) = 0
NullPosArray(8) = 1
NullPosArray(9) = 0
NullPosArray(10) = 0
NullPosArray(11) = 0

Dim PosArray(11)

'Position auslesen und vergleichen
For i = osel.Count2 To 1 Step -1
      Set PartProduct = osel.Item(i).Value
      PartProduct.Position.GetComponents PosArray
      If CompareArrays(PosArray, NullPosArray) Then
      'val = osel.Item(i).Value.Name
       
       
      'MsgList = osel.Item(i).Value.Name & Chr(10) & MsgList
        osel.Remove (i)

End If
Next
If osel.Count <> 0 Then
  
sFilePath = "c:\Import_CATIA.txt"

Set myDatei = CATIA.FileSystem.CreateFile(sFilePath, True)
Set t = myDatei.OpenAsTextStream("ForWriting")

t.Write ("NAME:") & Chr(10)

    For i = 1 To osel.Count
        t.Write osel.Item(i).Value.Name & Chr(10)
    Next

    MsgBox "TXT-Datei wurde erstellt!" & Chr(10) & sFilePath

Else
MsgList = "Alle Teile liegen auf AutoNull!"
MsgBox MsgList
   
End If

End Sub

Function CompareArrays(ByRef arr1(), ByRef arr2()) As Boolean
    Dim i As Integer
    For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If arr1(i) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next
    CompareArrays = True
End Function

---

[Diese Nachricht wurde von imation1999 am 05. Dez. 2013 editiert.]

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

---

CAD.zip

Halo imation1999

Danke für deine Antwort. Es ist jetzt fast fertig, aber....

Ich habe eine Probe gemacht, und ich habe ein Product erstellt mit zwei Componenten drin.
Ich habe zuerst deinen Code durchgeführt und alles war i.O.
Dann ich habe ein Part mit Kompass verschiebt und gedreht ---> leider i.O.
Dann ich habe genau das selber Part zuruck zum Auto-Null gesetzt und das Makro wieder durchgeführt ---> Makro gibts mir Ergebnis, das dieser Part nicht im Auto-Null liegt (erstellt mir TXT-Datei mit Names des Parts).
Sorry für mein Deutsch. Am Anhang CAD-Data.

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

---

Änder mal so ab:

Code:

---

For i = 0 To UBound(arr1) 'hier eben dieses erste element auslassen deshalb auch von 1
        If Round(arr1(i), 5) <> arr2(i) Then
            CompareArrays = False
            Exit Function
        End If
    Next

---

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

---

Halo

Das ist das! Vielen Dank für deine Hilfe! Wahrscheinlich läuft super! Danke noch Mal!

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

---

Hi

Sorry für die Störung wieder... Ich mochte noch ein Kirsch auf den Torte haben 

Ich will noch der Name vom TXT-Datei wie Aktive Product haben. Also z.B. wenn geöffnete Produkt heißt Baugruppe_1

das TXT-Datei soll Baugruppe_1.txt heißen.

P.S. Ich habe auch bemerkt, dass Makro zeigt Instance-Namen statt Part-Namen... Warum?

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

---

Ja, klar!
Änder mal so ab:

Code:

---

sFilePath = "c:\" & ProdDoc.Product.Name & ".txt"

---

Normaleweise ist das PartName gleich wie Instance Name, oder?

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

---

Zitat:

---

Original erstellt von imation1999:
Ja, klar!
Änder mal so ab:

Code:

---

sFilePath = "c:\" & ProdDoc.Product.Name & ".txt"

---

Normaleweise ist das PartName gleich wie Instance Name, oder?

---

Das Problem ist, dass durch Konstruktion Mann kann zwischenzeit Parts wechseln (austauschen) - dann Instance Name ist nicht synchronisiert. Das kann mir Probleme geben - wenn neues Part hat ändere Name als Instance-Name, makro wird mir falsche Ergebnis geben 

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

---

Änder mal so ab:

Code:

---

t.Write osel.Item(i).Value.PartNumber & Chr(10)

---

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