'Option Explicit 
'arrays fangen beim Index 0 an...
Dim aAssyArray() As String 'input array
Dim iAssyArrayCount As Integer
Dim aStuliPartNumbers() As String 'output array, Benennung
Dim aStuliCounts() As Integer 'output array, Anzahl 


Sub CATMain()

Dim Box, Datei As String

Box = MsgBox ("Das Skript erzeugt eine Stueckliste:" &Chr(13) & Chr (10)  & "Sollte das Skript einen String nicht aufteilen koennen wird dieser als letztes in die Spalte (J) geschrieben ohne die Zellen davor zu befuellen." &"", 64, "Stückliste")

X

end Sub

Sub X


Dim oActDoc As Document
If CATIA.Documents.Count = 0 Then
MsgBox ("Kein Dokument geöffnet!")
Exit Sub
End If

Set oActDoc = CATIA.ActiveDocument

If TypeName(oActDoc) <> "ProductDocument" Then
MsgBox ("Kein Product geladen!")
Exit Sub
End If 

'Array wird auf 100 Einträge initialisiert
'im RekursivDurchBaum ist die Redimensionierung vorhanden
ReDim aAssyArray(100)
iAssyArrayCount = 0 
Dim oProduct As Product
Set oProduct = oActDoc.Product
Dim oProducts As Products
Set oProducts = oProduct.Products 
'Alle CATParts aus Baum ins globale Array sammeln
RekursivDurchBaum oProducts 
If iAssyArrayCount > 0 Then


'Arraydimension zurechtschneiden
ReDim Preserve aAssyArray(iAssyArrayCount - 1) 
StuliEintraegeZaehlen 
'Ausgabe der Ergebnis ins Immedate Window (VBA)

Dim i As Integer
Dim sTemp As String
Dim sTempAnz As String
Dim vTXT As String
Dim BenennTXT As String
Dim PosTXT1 As String
Dim PosTXT2 As String
Dim AuftragNrTXT1 As String

Dim bgTXT1 As String
Dim bgTXT2 As String

Dim TXT_W_Teil As String
Dim TXT_1_W_Teil As String
Dim W_Teil As String
Dim KT_Teil As String
Dim Bestell As String
Dim Bestellx As String
Dim Liefer As String
Dim Lieferx As String
Dim Name As String
Dim Namex As String

Dim Baugr1 As String
Dim Baugr2 As String
Dim Baugr As String

Dim TXT_ As String
Dim TXT_1 As String
Dim TXT_2 As String
Dim TXT_3 As String
Dim TXT_4 As String
Dim TXT_5 As String
Dim TXT_6 As String
Dim TXT_7 As String
Dim TXT_8 As String
Dim TXT_9 As String
Dim BG_B As String
Dim BauGru_B As String
Dim BauGru_U As String

Dim TXT1 As String
Dim TXT2 As String
Dim TXT3 As String
Dim TXT4 As String
Dim TXT5 As String
Dim TXT6 As String
Dim TXT7 As String
Dim TXT8 As String

Dim prod As Product 
'Set prod = CATIA.ActiveDocument.Product 
Set objXL = CreateObject("Excel.Application")

objXL.Visible = True 
Set oAWBook = objxl.Workbooks.Add 

'For I = 1 to 15 'UserSelektion.Count 
'For i = 1 To prod.Parameters.Count 'Parameters
'objXL.Cells(i,1).Value = "DAS IST Spalte" &  i 
'objXL.Cells(i,2).Value = "DAS IST Spalte" &  i & "Zelle 2"
'objXL.Cells(i,3).Value = "DAS IST Spalte" &  i &  "Zelle 3"

'next

For i = LBound(aStuliPartNumbers) To UBound(aStuliPartNumbers)
sTemp = CInt(aStuliCounts(i)) & " St. von " & aStuliPartNumbers(i)
'Debug.Print sTemp
'hier kann auch ein Msgbox stehen
'MsgBox (sTemp)
sTempAnz = "" & CInt(aStuliCounts(i))
'Msgbox sTempAnz


'######################################## ETZ ###############################################


On Error Resume Next

vTXT =  aStuliPartNumbers(i)
'vTXT = Left(Name, InStrRev(Name, ".CAT") - 1) 

BenennTXT = Right( vTXT, Len( vTXT) -18 ) 'Right Left
 
PosTXT1 = Left(vTXT, InStrRev(vTXT, "_") - 1)
PosTXT2 = Right( PosTXT1, Len(PosTXT1) -14 ) 'Right Left
 
AuftragNrTXT1 = Left( PosTXT1, Len( PosTXT1) -9 ) 'Right Left 

bgTXT1 = Left( PosTXT1, Len( PosTXT1) -5 ) 'Right Left
bgTXT2 = Right( bgTXT1, Len( bgTXT1) -9 ) 'Right Left

'________________________________________________________________________________________________

TXT_W_Teil = Left(vTXT, InStrRev(vTXT, "_") -1)   'Right Left Mid
TXT_1_W_Teil = Right(TXT_W_Teil, InStrRev(TXT_W_Teil, "_") -5)   'Right Left Mid
W_Teil = Left(TXT_1_W_Teil, Len(TXT_1_W_Teil) -7)   'Right Left

'##############################################################################################



'########################### Kaufteile #######################################################

KT_Teil = Left(vTXT, InStrRev(vTXT, "KT_") +2)   'Right Left Mid

Bestell = mid(vTXT, InStrRev(vTXT, "_") +1)   'Right Left Mid
Bestellx = Left(vTXT, InStrRev(vTXT, "_") -1)   'Right Left Mid

Liefer = mid(Bestellx, InStrRev(Bestellx, "_") +1)   'Right Left Mid
Lieferx = Left(Bestellx, InStrRev(Bestellx, "_") -1)   'Right Left Mid

Name = mid(Lieferx, InStrRev(Lieferx, "_") +1)   'Right Left Mid
Namex = Left(Lieferx, InStrRev(Lieferx, "_") -1)   'Right Left Mid

'###################################### Baugruppe untersch #######################################################

Baugr1 = Left(vTXT, InStrRev(vTXT, "_") -1)   'Right Left Mid
Baugr2 = Left(Baugr1, InStrRev(Baugr1, "_") +1)   'Right Left Mid
Baugr = mid(Baugr2, InStrRev(Baugr2, "_") -0)   'Right Left Mid

'#################################################################################################

TXT_5 = Right(TXT_4, InStrRev(TXT_4, "_") -0)   'Right Left Mid
TXT_6 = Left(TXT_5, InStrRev(TXT_, "_") -6)   'Right Left Mid

TXT_8 = Left(TXT_5, InStrRev(TXT_, "_") -6)   'Right Left Mid
TXT_9 = Right(TXT_8, Len(TXT_8) - 1)

TXT_1_BG_B = Left(TXT_2_BG_U, InStrRev(TXT_, "_") -6)   'Right Left Mid
BG_B = Right(TXT_1_BG_B, Len(TXT_1_BG_B) - 1)


'msgbox oName + Chr(13) + "oName"
'msgbox TXT_1 + Chr(13) + "TXT_1"
'msgbox W_Teil + Chr(13) + "W_Teil"
'msgbox Baugr1 + Chr(13) + "Baugr1"
'msgbox Baugr2 + Chr(13) + "Baugr2"
'msgbox Baugr + Chr(13) + "Baugr"
'msgbox TXT_6 + Chr(13) + "TXT_6"
'msgbox TXT_7 + Chr(13) + "TXT_7"
'msgbox TXT_8 + Chr(13) + "TXT_8"
'msgbox TXT_9 + Chr(13) + "TXT_9"


'#############################################################################################

BauGru_B = vTXT & Chr(10) & "Baugruppe"

BauGru_U = vTXT & Chr(10) & "Unterbaugruppe"

'######################## IF ABFRAGE #########################################################

if W_Teil = "-B" Then

	TXT1= sTempAnz
	TXT2= BenennTXT
	TXT3= PosTXT1
	TXT4= ""
	TXT5= PosTXT2
	TXT6= ""
	TXT7= "Werner"

end if

if KT_Teil = "KT_" Then

	TXT1 = sTempAnz
	TXT2 = Name
	TXT3 = ""
	TXT4 = ""
	TXT5 = ""
	TXT6 = Bestell
	TXT7 = Liefer

end if

'msgbox "Name:" + vTXT + Chr(13) + Chr(13) +  "Anz.:                             " + TXT1 + Chr(13) + "Bennennung:               " + TXT2 + Chr(13) + "Best-Nr.Werner:          " + TXT3 +  Chr(13) + "Werkstoff:                   " + TXT4 + Chr(13)  + "Pos.                            " +  TXT5 + Chr(13) + "Rohmasse-DIN:         "  + TXT6 + Chr (13) +  "Lifer:                         " + TXT7 

'http://ww3.cad.de/foren/ubb/Forum137/HTML/000866.shtml#000006

objXL.Cells(i,1).Value = TXT1 '"DAS IST Spalte" &  i & "Zelle 2"
objXL.Cells(i,2).Value = TXT2 ' "DAS IST Spalte" &  i &  "Zelle 3"
objXL.Cells(i,3).Value = TXT3 ' "DAS IST Spalte" &  i &  "Zelle 4"
objXL.Cells(i,4).Value = TXT4 ' "DAS IST Spalte" &  i &  "Zelle 5"
objXL.Cells(i,5).Value = TXT5 ' "DAS IST Spalte" &  i &  "Zelle 6"
objXL.Cells(i,6).Value = TXT6 ' "DAS IST Spalte" &  i &  "Zelle 7"
objXL.Cells(i,7).Value = TXT7 ' "DAS IST Spalte" &  i &  "Zelle 8"
objXL.Cells(i,10).Value = vTXT ' "DAS IST Spalte" &  i
objXL.Cells(i,11).Value = TXT1 ' "DAS IST Spalte" &  i 

vTXT = " "
TXT1 = " "
TXT2 = " "
TXT3 = " "
TXT4 = " "
TXT5 = " "
TXT6 = " "
TXT7 = " "

Next	 

End If

End Sub 

Function RekursivDurchBaum(oProducts As Products)
Dim oProduct As Product
Dim oRefProduct As Product
Dim oRefDocument As Document
For Each oProduct In oProducts
If oProduct.Products.Count > 0 Then
RekursivDurchBaum oProduct.Products
Else
Set oRefProduct = oProduct.ReferenceProduct
Set oRefDocument = oRefProduct.Parent
If TypeName(oRefDocument) = "PartDocument" Then
'Du bist an einen Part
'jetzt kannst du entscheiden, nach was du zählen willst: 
' 'Dateiname
aAssyArray(iAssyArrayCount) = oRefDocument.Name 
'PartNumber
aAssyArray(iAssyArrayCount) = oRefProduct.PartNumber 
iAssyArrayCount = iAssyArrayCount + 1 
'dieser Block ist nur da, falls die Anzahl der Products über 100 kommen sollte
If UBound(aAssyArray) <= iAssyArrayCount Then
ReDim Preserve aAssyArray(iAssyArrayCount + 20)
End If
End If
End If
Next
End Function 
Sub StuliEintraegeZaehlen()
Dim i1stLoop As Integer
Dim i2ndLoop As Integer
Dim iSearchStringCount As Integer
Dim sSearchString As String
Dim iStuliArrayCount As Integer
Dim s2ndLoopString As String 
ReDim aStuliPartNumbers(20) 'output array, Benennung
ReDim aStuliCounts(20) 'output array, Anzahl
iStuliArrayCount = 0 
'Algorithmus:
'Es wird die aAssyArray durchgelaufen. Jede Zeile dieser Array wird in aStuli*
'geschrieben, falls es noch nicht existiert. Falls ein Eintrag mit der selber Name
'schon vorhanden war, wird der Zähler (2. Spalte) inkrementiert
'Bei jeder Treffer wird der Eintrag aus der Originalarray gelöscht
'habe im Vergleich zur Vorgänger lieber zwei Eindimensionale Arrays genommen, somit sind die
'einfacher zu handhaben 
'äußere Schleife
For i1stLoop = 0 To iAssyArrayCount - 1
iSearchStringCount = 0
sSearchString = CStr(aAssyArray(i1stLoop)) 'nach diesen wird weitergesucht
If Len(sSearchString) > 0 Then 'also Eintrag im Original noch nicht gelöscht
iSearchStringCount = iSearchStringCount + 1 'ein Eintrag haben wir jedenfalls schon gefunden 
'innere Schleife
For i2ndLoop = i1stLoop + 1 To iAssyArrayCount - 1
s2ndLoopString = CStr(aAssyArray(i2ndLoop))
If Len(s2ndLoopString) > 0 Then 'also Eintrag im Original noch nicht gelöscht
If s2ndLoopString = sSearchString Then 'wir haben noch ein Exemplar gefunden
iSearchStringCount = iSearchStringCount + 1
aAssyArray(i2ndLoop) = "" 'OriginalEintrag löschen
End If
End If
Next 
'nachdem die Gesamtstückzahl ermittelt wurde, wird es ins Ausgangsarray geschreiben
aStuliPartNumbers(iStuliArrayCount) = sSearchString
aStuliCounts(iStuliArrayCount) = iSearchStringCount 
'wieder der Array Dimensionscheck
iStuliArrayCount = iStuliArrayCount + 1
If UBound(aStuliPartNumbers) <= iStuliArrayCount Then
ReDim Preserve aStuliPartNumbers(iStuliArrayCount + 5)
ReDim Preserve aStuliCounts(iStuliArrayCount + 5)
End If
End If
Next 
If iStuliArrayCount > 0 Then
'Arraydimension zurechtschneiden
ReDim Preserve aStuliPartNumbers(iStuliArrayCount - 1)
ReDim Preserve aStuliCounts(iStuliArrayCount - 1)
End If
End Sub