Code:
Language="VBSCRIPT"Sub CATMain()
'--------------A----------------------------------------
'2D-Komponenten zerlegen
Dim oDRWDoc As DrawingDocument
Dim oSheet As DrawingSheet
Dim oView As DrawingView
Dim oDRWComp As DrawingComponent
Set oDRWDoc = CATIA.ActiveDocument
'Schleife für alle Sheets
For i = 1 To oDRWDoc.Sheets.Count
Set oSheet = oDRWDoc.Sheets.Item(i)
'Ist das Sheet kein Detail-Sheet?
If Not oSheet.IsDetail Then
'Schleife für alle Views im Sheet
For j = 1 To oSheet.Views.Count
Set oView = oSheet.Views.Item(j)
'Schleife für alle 2D-Komponenten der View
For k = 1 To oView.Components.Count
Set oDRWComp = oView.Components.Item(k)
'2D-Komponente zerlegen
oDRWComp.Explode
Next
Next
End If
Next
'--------------B----------------------------------------
' Blatt Modell in Model umbenennen-------------------
Dim oSheets As DrawingSheets
Set oSheets = oDRWDoc.Sheets
Dim Box
Box = MsgBox ("Gibt es ein Blatt mit Namen Modell ?" & Chr(13) & _
"Achtung auf die letzen 2 Buchstaben achten!", 4, "BORBET")
If Box = 6 Then
Set oSheet=oSheets.Item("Modell")
oSheet.Name= "Model"
oSheet.Activate
End If
oSheets.Item("Model").Activate
'------------------C-------------------------
' Elemete Auswählen und Blau färben-------------------
' Auswahl erstellen----------------
Dim Was(1)
Was(0) = "Line2D"
Was(1) = "DrawingText"
' Selektion definieren und leeren ---------------------------------
Dim oDoc As Object
Set oDoc= CATIA.ActiveDocument
Set UserSel= oDoc.Selection
UserSel.Clear
MsgBox "Bitte nach OK die Auswahl treffen!" & Chr (13) & "(Mehrfachauswahl mit Strg)", 48, "BORBET"
' Selektion vornehmen lassen --------------------------------------
Dim E As CATBSTR
E = UserSel.SelectElement3 (Was, " Auswahl", False, CATMultiSelTriggWhenUserValidatesSelection, False)
If E = "Normal" Then
If MsgBox ("Die Ausgwählten Objekte werden Blau eingefärbt", 4, "BORBET") = 6 Then
UserSel.VisProperties.SetRealColor 0, 0, 255, 1
Else
UserSel.Clear
Exit Sub
End If
Else
MsgBox "Abbruch", 16, "Cancel"
Exit Sub
End If
' Selektion freigeben --------------------------------------------
UserSel.Clear
'-----------------D-----------------------
' Blaue Elemente verschieben und Blätter löschen----------------
Dim selection1 As Selection
Set selection1 = oDRWDoc.Selection
selection1.Clear
'---> Blaue Elemente von Layer 4 und 5 Auswählen
selection1.Search "(Layer=4 + Layer=5 + Color='(0,0,255)'),all"
'--> Auswahl auf Layer 4 schieben
selection1.VisProperties.SetLayer catVisLayerBasic, 4
selection1.Clear
'--> Alles löschen außer Layer 4
selection1.Search "(Layer <4 + Layer >4 + CATDrwSearch.DrwSheet.Name!=Model),all"
selection1.Delete
selection1.Clear
End Sub
Foren auf CAD.de
| 
