' Makro: PropertiesToExcel
' Version:  1.0
' Code:     CATScript
' Zweck:    Auslesen der eingefügten benutzer definierten Parameter
'           aller Parts vom aktiven Product, mit automatischem Einfügen
'           in ein vorhandenes Excel File an vorgegebener Position
' Autor: Christoph Laengle, Escad Academy GmbH
' Datum: 13.08.09

'*********************************************************************************

'Deklaration von Variablen die im ganzen Programm verwendet werden
   
   Public oExcel As Object 'Excel als globale Variable deklarieren
   Public CATIA As Application
   Public aProps(), aAGZ(), aArBe(3) As String
   Public iArZ, iArCo  As Integer
   
   Public aSort As Variant
   Public index As Integer
   Public lngStart As Variant
   Public lngEnd As Variant

'*********************************************************************************

'Hauptprogramm

Sub CATMain()
 
Dim P As Object

'Kontrolle ob CATIA geöffnet und ein Produkt geladen ist
 
   Set CATIA = CreateObject("CATIA.Application")
   
'erfassen des Produkts
   
   Set P = CATIA.ActiveDocument.Product
   
' Array für die Beschreibungs Nummerierung einen Startwert zuweisen

aArBe(0) = 1
aArBe(1) = 1
aArBe(2) = 1
aArBe(3) = 1
               
'Analysieren und Schreiben der Daten in Array
               
   iArZ = 0
   Call fAnalysieren(P)

'Sortieren des Arrays

   Call sortArr(aProps, 11, "", "")
   
'Nummerierung für Beschreibung hinzufügen

   Call besNum
   
'Excel öffnen und/oder aktivieren

   Call fStartExcel
   
'einfügen der Daten an gewünschte Position

   Call fPositionierung

'MsgBox "Die Übertragung der Daten an Excel wurde erfolgreich abgeschlossen!", , _
'             "Erfolgreich beendet"
  
End Sub

'*********************************************************************************
'*********************************************************************************
'CATIA Arbeitsschritte


Function fAnalysieren(P As Product)

    Dim PP As Products
    Dim i As Integer
    Dim myAktiProd As Product
    Dim myRefProduct As Product
    Dim myRootUserRefs As Parameters
    Dim myPartUserRefs As Parameters
       
    'Auslesen der UserRefProperties des Root-Produkts
'    Set myRootUserRefs = P.UserRefProperties
       
   Call fParaCont(P, iArZ)
    
    Set PP = P.Products
    i = 0
    Do While i < PP.Count
      i = i + 1
        Set myAktiProd = PP.Item(i)
        Set myRefProduct = myAktiProd.ReferenceProduct
        'Hier werden die UserRefProperties von Parts und Untreprodukten ausgelesen
        Set myPartUserRefs = myRefProduct.UserRefProperties
        Call fParaCont(myPartUserRefs, iArZ)
       Call fAnalysieren(PP.Item(i))
    Loop

End Function

'*********************************************************************************

'Kontrolle ob ein Benutzerdefinierter Parameter vorhanden ist,
'wenn ja wird fortgesetzt

Function fParaCont(P, iArZ)

Dim bParKey As Boolean

On Error Resume Next
Par = ""
Set Par = P.GetItem("STATION")
Call ParCheck(Par, bParKey)

If bParKey = False Then
   Par = ""
   Set Par = P.GetItem("BESCHREIBUNG")
   Call ParCheck(Par, bParKey)
   If bParKey = False Then
      Par = ""
      Set Par = P.GetItem("ZEICHNUNGSNUMMER")
      Call ParCheck(Par, bParKey)
      If bParKey = False Then
         Par = ""
         Set Par = P.GetItem("STELLGLIED")
         Call ParCheck(Par, bParKey)
         If bParKey = False Then
            Par = ""
            Set Par = P.GetItem("AZ_ENDSCHALTER")
            Call ParCheck(Par, bParKey)
            If bParKey = False Then
               Par = ""
               Set Par = P.GetItem("TYP")
               Call ParCheck(Par, bParKey)
               If bParKey = False Then
                  Par = ""
                  Set Par = P.GetItem("BESTELLNUMMER")
                  Call ParCheck(Par, bParKey)
                  If bParKey = False Then Exit Function
               End If
            End If
         End If
      End If
   End If
End If

On Error GoTo 0
Call fSchreiben(P, iArZ)

End Function
'*********************************************************************************

'Kontrolle ob der Parameter vorhanden ist und einen Wert hat,
'dann bParKey = True

Function ParCheck(Par, bParKey)

On Error Resume Next

If Par <> "" Then
   If Par.Value <> "" Then
      bParKey = True
   Else
      bParKey = False
   End If
Else
   bParKey = False
End If

On Error GoTo 0

End Function

'*********************************************************************************
'die benutzerdefinierten Parameter werden in das Array geschrieben

Function fSchreiben(P, iArZ)
Dim Par As Object
Dim x As Integer
x = 2


iArZ = iArZ + 1

'anpassen der Arraygröße
ReDim Preserve aProps(15, iArZ - 1)

On Error Resume Next

Set Par = Nothing
Set Par = P.GetItem("STATION")
Call fArraySchreib(Par, x)

'der Beschreibung wird eine laufende Nummer angefügt
Set Par = Nothing
Set Par = P.GetItem("BESCHREIBUNG")
   Call fArraySchreib(Par, x)
   
x = x + 5

Set Par = Nothing
Set Par = P.GetItem("ZEICHNUNGSNUMMER")
Call fArraySchreib(Par, x)

Set Par = Nothing
Set Par = P.GetItem("STELLGLIED")
Call fArraySchreib(Par, x)

'einfügen des Antriebsglied mit Abfrage ob Wert zugewiesen werden soll
'mit einem Array werden verschieden Laufzahlen für die Stellglieder handgehabt

If Par.Value <> "" Then
   If iArCo < Par.Value Then
      iArCo = Par.Value
      ReDim Preserve aAGZ(iArCo)
      Call fArInit(aAGZ, iArCo)
   End If
   aProps(x, iArZ - 1) = Par.Value & "." & aAGZ(Par.Value) & "."
End If
x = x + 1

If Par.Value <> "" Then
   aProps(x, iArZ - 1) = "B" & Par.Value & "ERV" & aAGZ(Par.Value)
   aAGZ(Par.Value) = aAGZ(Par.Value) + 1
'Else
   'aProps(x, iArZ - 1) = "B" & "Par.Value" & "TK" & "aAGZ(Par.Value)"
End If
x = x + 1

Set Par = Nothing
Set Par = P.GetItem("AZ_ENDSCHALTER")
Call fArraySchreib(Par, x)

x = x + 1

Set Par = Nothing
Set Par = P.GetItem("TYP")
Call fArraySchreib(Par, x)

Set Par = Nothing
Set Par = P.GetItem("BESTELLNUMMER")
Call fArraySchreib(Par, x)

On Error GoTo 0

End Function

'*********************************************************************************

' schreiben des Parameterwerts in das Array

Function fArraySchreib(Par, x)

On Error Resume Next

If Par <> "" Then
   If Par.Value <> "" Then
      aProps(x, iArZ - 1) = Par.Value
   End If
End If

On Error GoTo 0
   
x = x + 1

End Function

'*********************************************************************************

'weist allen leeren Array Plätzen den Wert 1 zu

Function fArInit(aAGZ, iArCo)
Dim z As Integer
z = 0
Do
If aAGZ(z) <> "" Then
   Else
      aAGZ(z) = 1
End If
z = z + 1
Loop Until z > iArCo


End Function

'*********************************************************************************

'Function sortArr(aSort, index, Optional lngStart, Optional lngEnd)
Function sortArr(aSort, index, lngStart, lngEnd)

' aSort: 2-dimensionales Array
' index: Spalte, nach der sortiert werden soll (1, 2, 3, ...)
 
' Wird die Bereichsgrenze nicht angegeben,
' so wird das gesamte Array sortiert


  If lngStart = "" Then lngStart = LBound(aSort, 2)
  If lngEnd = "" Then lngEnd = UBound(aSort, 2)

  Dim i As Long
  Dim j As Long
  Dim h As Variant
  Dim x As Variant
  Dim u As Long
  Dim lb_dim As Integer
  Dim ub_dim As Integer
 
' Anzahl Elemente pro Datenzeile
  lb_dim = LBound(aSort, 1)
  ub_dim = UBound(aSort, 1)
 
  i = lngStart
  j = lngEnd
  
  x = CSng(aSort(index, (lngStart + lngEnd) / 2))
 
' Array aufteilen
  Do
 
   While (CSng(aSort(index, i)) < x)
      i = i + 1
   Wend
   While (CSng(aSort(index, j)) > x)
      j = j - 1
   Wend

' Wertepaare miteinander tauschen

    If (i <= j) Then
      For u = lb_dim To ub_dim
        h = aSort(u, i)
        aSort(u, i) = aSort(u, j)
        aSort(u, j) = h
      Next
      i = i + 1
      j = j - 1
    End If
  Loop Until (i > j)
 
' Rekursion (Funktion ruft sich selbst auf)

  If (lngStart < j) Then sortArr aSort, index, lngStart, j
  If (i < lngEnd) Then sortArr aSort, index, i, lngEnd
  
End Function

'*********************************************************************************

Function besNum()

'den Beschriftungen werden Nummern angefügt
   
   i = 0
   
   Do
      Select Case aProps(3, i)
         Case "Spanner"
            If aArBe(0) < 10 Then
               aProps(3, i) = aProps(3, i) & " 0" & aArBe(0)
            Else
               aProps(3, i) = aProps(3, i) & " " & aArBe(0)
            End If
            aArBe(0) = aArBe(0) + 1
         Case "Bauteilkontrolle"
            If aArBe(1) < 10 Then
               aProps(3, i) = aProps(3, i) & " 0" & aArBe(1)
            Else
               aProps(3, i) = aProps(3, i) & " " & aArBe(1)
            End If
            aArBe(1) = aArBe(1) + 1
         Case "Zentrierung"
            If aArBe(2) < 10 Then
               aProps(3, i) = aProps(3, i) & " 0" & aArBe(2)
            Else
               aProps(3, i) = aProps(3, i) & " " & aArBe(2)
            End If
            aArBe(2) = aArBe(2) + 1
         Case "Schwenk"
            If aArBe(3) < 10 Then
               aProps(3, i) = aProps(3, i) & " 0" & aArBe(3)
            Else
               aProps(3, i) = aProps(3, i) & " " & aArBe(3)
            End If
            aArBe(3) = aArBe(3) + 1
      End Select
   
      i = i + 1
   
   Loop Until i > iArZ - 1

End Function

'*********************************************************************************
'*********************************************************************************
'Excel Arbeitsschritte

'*********************************************************************************

'Excel Starten und/oder erfassen

Function fStartExcel()

    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")
    On Error GoTo 0
    '    If oExcel = "" Then
    'Set oExcel = CreateObject("Excel.Application")
    '    End If
    'Set oExcel = GetObject(, "Excel.Application")
    oExcel.Application.Visible = True
   
End Function

'****************************************************************************************************

'schreiben der Daten in Excel

Function fPositionierung()

'vr ist die Verschiebung des Einfügepunkts in Reihen
'vs ist die Verschiebung des Einfügepunkts in Spalten
'sh ist die Nummer des Blattes in das eingetragen werden soll,
'dabei werden die Reiter von links (1) bis rechts (n = Anzahl der Blätter) gezählt.
'!!!durch verschieben und einfügen kann die Reihenfolge der Nummern verändert werden!!!

Dim i, j, k As Integer

Const vs = 0
Const vr = 63
Const sh = 3

i = 1
j = 1
k = 0

Do While k < iArZ
      Do While i - 1 < 16
            oExcel.Worksheets(sh).Cells(j + vr, i + vs) = aProps(i - 1, k)
            i = i + 1

      Loop
            
            i = 1
            j = j + 1
            k = k + 1

Loop

End Function