Seznam příspěvků uživatele

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

' original Makroname = copyPARTtoPRODUCT.CATScript

' Makroname = PARTtoPRODUCT_R19.CATScript

'

' Author:   Filippo Gozza

' Version:  V5R10, V5R12

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

' Konvertiert ein CATPart in ein CATProduct

' Alle Koerper werden in CATPart's konvertiert

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



Language = "VBSCRIPT"



Dim KomponenteNeu As Products

Dim KoerperName

Dim OpenKoerperName

Dim hybridBodies As document

Dim Koerper  As Object

Dim QuellFenster As Window

Dim Letztekoerper

Dim UserSel As selection





Sub CATMain()

    

    Dim Activdocu As document

    Set Activdocu = CATIA.ActiveDocument

    

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

    ' Neue Product

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

    Dim PosString As Long

    

    partName = CATIA.ActiveDocument.Name

    

    Dim docu As Documents

    Set docu = CATIA.Documents

    

    Dim productDocu As document

    Set productDocu = docu.Add("Product")

    

    Dim ProductNeu  As product

    Set ProductNeu = productDocu.product

    

    PosString = InStr(1, partName, ".CATPart")

    ProductNeu.PartNumber = Mid(partName, 1, PosString - 1)

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

    

    FensterNebeneinander

    

    Set QuellFenster = CATIA.Windows.Item(1)

    QuellFenster.Activate

    

    Dim partBodies As Bodies

    'Set Activdocu = CATIA.ActiveDocument

    Set partBodies = Activdocu.Part.Bodies

    

    Dim koerperAnzahl

    koerperAnzahl = partBodies.Count

    

    Dim UserSel As Object

    Dim PartNeu As product

    Dim workPart As PartDocument

    For I = 1 To koerperAnzahl

        

        Set Koerper = partBodies.Item(I)

		'Koerper in Boole'sche Operation verwendet

		If Koerper.InBooleanOperation = False Then		

		

			KoerperName = Koerper.Name

        

			If Right(KoerperName, 1) = "\" Then

				KoerperName = Left(KoerperName, Len(KoerperName) - 1)

				End If

        

			KoerperName = Replace(KoerperName, "\", "_")

        

			'Koerper kopieren

			Activdocu.selection.Clear

			Activdocu.selection.Add Koerper

			Activdocu.selection.Copy

			Activdocu.selection.Clear

        

			'Part erzeugen und Koerper einfuegen

			On Error Resume Next

			Set PartNeu = ProductNeu.Products.AddNewComponent("Part", CStr(KoerperName))

			If Err.Number <> 0 Then

				On Error GoTo 0

				l = ProductNeu.Products.Count

				Set PartNeu = ProductNeu.Products.Item(l)

				KoerperName = KoerperName & "." & I

				PartNeu.PartNumber = KoerperName

				ProductNeu.Products.Item(l).Name = KoerperName & ".1"

			Else

				On Error GoTo 0

			End If

			

			' Fenster mit neue Product activieren

			ProductNeu.Parent.Activate

			

			' Alle Parts suchen

			PartSuchen ProductNeu.Parent, UserSel

			

			ProductNeu.Parent.selection.Clear

			ProductNeu.Parent.selection.Add ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent.Part

			'Variante 2: Einfuegen als "toter Solid"

			ProductNeu.Parent.selection.PasteSpecial "CATPrtResult"

			ProductNeu.Parent.selection.Clear

			

			'eingefuegten Koerper zum PartBody machen und Ex-PartBody loeschen

			Set workPart = ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent

			If workPart.Part.Bodies.Count > 1 Then

				workPart.Part.MainBody = workPart.Part.Bodies.Item(workPart.Part.Bodies.Count)

				ProductNeu.Parent.selection.Add workPart.Part.Bodies.Item(1)

				ProductNeu.Parent.selection.Delete

				ProductNeu.Parent.selection.Clear

			End If

        End if	

    Next

    

       

    ' Product actualisieren

    ProductNeu.ApplyWorkMode DESIGN_MODE

    On Error Resume Next

    ProductNeu.Update

    If Err <> 0 Then

        MsgBox "Problem with update!" & vbLf & vbLf & "Please update manual!", vbCritical + vbOKOnly, "Update-Error"

    End If

    On Error GoTo 0

    

End Sub





Sub PartSuchen(oPartDoc1, UserSel)

    

    Dim E As Object 'CATBSTR

    Dim Was(0)

    Was(0) = "Part"

    

    'Dim UserSel As Object

    Set UserSel = oPartDoc1.selection

    UserSel.Clear

    

    'Let us first fill the CSO with all the objects of the model

    UserSel.Search ("CATPrtSearch.PartFeature,all")

    

    'E = UserSel.SelectElement2(Was, "Alle CATPart wahlen", True)

    'Letztekoerper = UserSel.Count

    

End Sub





Sub FensterNebeneinander()

    

    Dim windows1 As Windows

    Set windows1 = CATIA.Windows

    

    windows1.Arrange catArrangeTiledVertical

    

End Sub