Code:
Sub CATMain()'Prüfen ob noch Dateien geöffnet sind
On Error Resume Next
Set testdoc = CATIA.ActiveDocument
If Err.Number = 0 Then
MsgBox "Schließen Sie bitte zuerst alle offenen Dateien", 16, makroname + " " + Version
Exit Sub
Else
Err.Clear
End If
'Neues Produkt erzeugen
Dim documents1 As Documents
Set documents1 = CATIA.Documents
Dim productDocument1 As ProductDocument
Set productDocument1 = documents1.Add("Product")
Dim product1 As Product
Set product1 = productDocument1.Product
Dim products1 As Products
Set products1 = product1.Products
'Daten in das Produkt einbinden
Dim partfile1, partfile2
partfile1 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.CATPart;*.cgr;*.model", CatFileSelectionModeOpen)
If partfile1 <> "" Then
Set PP = CATIA.ActiveDocument.Product.Products
Dim Liste1(0)
Liste1(0) = partfile1
PP.AddComponentsFromFiles Liste1, "All"
Else
MsgBox "Makro wurde abgebrochen", 16, makroname + " " + Version
Exit Sub
End If
partfile2 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil2", "*.CATPart;*.cgr;*.model", CatFileSelectionModeOpen)
If partfile2 <> "" Then
Set PP = products1
Dim Liste2(0)
Liste2(0) = partfile2
PP.AddComponentsFromFiles Liste2, "All"
Else
MsgBox "Makro wurde abgebrochen", 16, makroname + " " + Version
Exit Sub
End If
Dim added As Double
Dim removed As Double
'Produkte vergleichen
Dim optimizerWorkBench1 As Workbench
Set optimizerWorkBench1 = productDocument1.GetWorkbench("OptimizerWorkBench")
'Zu vergleichende Produkte
Dim product2 As Product
Set product2 = products1.Item(1)
Dim product3 As Product
Set product3 = products1.Item(2)
'Vergleich
Dim partComps1 As PartComps
Set partComps1 = optimizerWorkBench1.PartComps
Dim partComp1 As PartComp
'Parameter :
'product2 : Erstes Produkt (alte Version)
'product3 : Zweites Produkt (neue Version)
'2.000000 : Berechnungs Genauigkeit (mm)
'2.000000 : Anzeigegenauigkeit (mm)
'2 : Berechnungstyp : 0=hinzugefügt, 1=enfternt, 2=hinzugefügt&enfernt
Dim Box
Box = MsgBox("Die Berechnungsgenauigkeit und die Anzeigegenauigkeit beeträgt 1mm." & Chr(13) & "Standardwerte ändern?", 3, "Standardwerte")
Select Case Box
Case "6"
Dim BGenauigkeit
BGenauigkeit = "2"
BGenauigkeit = InputBox("Geben Sie die Genauigkeit der Berechnung in Millimetern ein.", "Berechnungsgenauigkeit", Eingabe)
Dim AGenauigkeit
AGenauigkeit = "2"
AGenauigkeit = InputBox("Geben Sie die Genauigkeit der Anzeige in Millimetern ein.", "Anzeigegenauigkeit", Anzeige)
Set partComp1 = partComps1.Add(product2, product3, BGenauigkeit, AGenauigkeit, 2)
'Abrufen des hinzugefügten Volumen (%, Wärte zwischen 0.0 und 1.0)
Dim PercentAdded As Double
PercentAdded = partComps1.AddedMaterialPercentage
'Abrufen des entfernten Volumens (%, Wärte zwischen 0.0 und 1.0)
Dim PercentRemoved As Double
PercentRemoved = partComps1.RemovedMaterialPercentage
If PercentAdded > MinDiff And PercentRemoved > MinDiff Then
MsgBox ("Eine Geometrieänderung durch hinzugefügtes und entferntes Volumen liegt vor.")
' Speichern beider Daten
Dim document1 As Document
Set document1 = documents1.Item("AddedMaterial.3dmap")
document1.Activate
Dim sPathAddDocument1 As String
sPathAddDocument1 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document1.SaveAs sPathAddDocument1
Dim document2 As Document
Set document2 = documents1.Item("RemovedMaterial.3dmap")
document2.Activate
Dim sPathAddDocument2 As String
sPathAddDocument2 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document2.SaveAs sPathAddDocument2
document2.Close
document1.Close
'Import des hinzugefügten und entfernten Materials
Dim sFileList1(0)
sFileList1(0) = sPathAddDocument1
PP.AddComponentsFromFiles sFileList1, "All"
Dim sFileList2(0)
sFileList2(0) = sPathAddDocument2
PP.AddComponentsFromFiles sFileList2, "All"
'Ausrichten
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutSightDirection Array(1#, 1, 0)
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutUpDirection Array(0, 0, 1)
CATIA.ActiveWindow.ActiveViewer.Reframe
CATIA.ActiveWindow.ActiveViewer.ZoomIn
CATIA.ActiveWindow.ActiveViewer.ZoomIn
Else
If PercentAdded > MinDiff Then
MsgBox ("Eine Geometrieänderung durch hinzugefügtes Volumen liegt vor.")
'Speichern hinzugefügtes Material
Dim document3 As Document
Set document3 = documents1.Item("AddedMaterial.3dmap")
document3.Activate
Dim sPathAddDocument3 As String
sPathAddDocument3 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document3.SaveAs sPathAddDocument3
document3.Close
'Import des hinzugefügten Materials
Dim sFileList3(0)
sFileList3(0) = sPathAddDocument3
PP.AddComponentsFromFiles sFileList3, "All"
' Ausrichten
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutSightDirection Array(1#, 1, 0)
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutUpDirection Array(0, 0, 1)
CATIA.ActiveWindow.ActiveViewer.Reframe
CATIA.ActiveWindow.ActiveViewer.ZoomIn
CATIA.ActiveWindow.ActiveViewer.ZoomIn
Else
If PercentRemoved > MinDiff Then
MsgBox ("Eine Geometrieänderung durch entferntes Volumen liegt vor.")
Dim document4 As Document
Set document4 = documents1.Item("RemovedMaterial.3dmap")
document4.Activate
Dim sPathAddDocument4 As String
sPathAddDocument4 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document4.SaveAs sPathAddDocument4
document4.Close
'Hinzufügen von entferntem Material
Dim sFileList4(0)
sFileList4(0) = sPathAddDocument4
PP.AddComponentsFromFiles sFileList4, "All"
'Ausrichten
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutSightDirection Array(1#, 1, 0)
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutUpDirection Array(0, 0, 1)
CATIA.ActiveWindow.ActiveViewer.Reframe
CATIA.ActiveWindow.ActiveViewer.ZoomIn
CATIA.ActiveWindow.ActiveViewer.ZoomIn
Else
MsgBox ("Keine Geometrieänderung")
Exit Sub
End If
End If
End If
Case "7"
Set partComp1 = partComps1.Add(product2, product3, 1#, 1#, 2)
'Abrufen des hinzugefügten Volumen (%, Wärte zwischen 0.0 und 1.0)
Dim PercentAdded2 As Double
PercentAdded2 = partComps1.AddedMaterialPercentage
'Abrufen des entfernten Volumens (%, Wärte zwischen 0.0 und 1.0)
Dim PercentRemoved2 As Double
PercentRemoved2 = partComps1.RemovedMaterialPercentage
If PercentAdded > MinDiff And PercentRemoved > MinDiff Then
MsgBox ("Eine Geometrieänderung durch hinzugefügtes und entferntes Volumen liegt vor.")
' Speichern beider Daten
Dim document12 As Document
Set document12 = documents1.Item("AddedMaterial.3dmap")
document12.Activate
Dim sPathAddDocument12 As String
sPathAddDocument12 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document12.SaveAs sPathAddDocument12
Dim document22 As Document
Set document22 = documents1.Item("RemovedMaterial.3dmap")
document22.Activate
Dim sPathAddDocument22 As String
sPathAddDocument22 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document22.SaveAs sPathAddDocument22
document22.Close
document12.Close
'Import des hinzugefügten und entfernten Materials
Dim sFileList12(0)
sFileList12(0) = sPathAddDocument12
PP.AddComponentsFromFiles sFileList12, "All"
Dim sFileList22(0)
sFileList22(0) = sPathAddDocument22
PP.AddComponentsFromFiles sFileList22, "All"
'Ausrichten
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutSightDirection Array(1#, 1, 0)
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutUpDirection Array(0, 0, 1)
CATIA.ActiveWindow.ActiveViewer.Reframe
CATIA.ActiveWindow.ActiveViewer.ZoomIn
CATIA.ActiveWindow.ActiveViewer.ZoomIn
Else
If PercentAdded > MinDiff Then
MsgBox ("Eine Geometrieänderung durch hinzugefügtes Volumen liegt vor.")
'Speichern hinzugefügtes Material
Dim document32 As Document
Set document32 = documents1.Item("AddedMaterial.3dmap")
document32.Activate
Dim sPathAddDocument32 As String
sPathAddDocument32 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document32.SaveAs sPathAddDocument32
document32.Close
'Import des hinzugefügten Materials
Dim sFileList32(0)
sFileList32(0) = sPathAddDocument32
PP.AddComponentsFromFiles sFileList32, "All"
' Ausrichten
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutSightDirection Array(1#, 1, 0)
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutUpDirection Array(0, 0, 1)
CATIA.ActiveWindow.ActiveViewer.Reframe
CATIA.ActiveWindow.ActiveViewer.ZoomIn
CATIA.ActiveWindow.ActiveViewer.ZoomIn
Else
If PercentRemoved > MinDiff Then
MsgBox ("Eine Geometrieänderung durch entferntes Volumen liegt vor.")
Dim document42 As Document
Set document42 = documents1.Item("RemovedMaterial.3dmap")
document42.Activate
Dim sPathAddDocument42 As String
sPathAddDocument42 = CATIA.FileSelectionBox(makroname + " " + Version + " - Bauteil1", "*.3dmap", CatFileSelectionModeSave)
document42.SaveAs sPathAddDocument42
document42.Close
'Hinzufügen von entferntem Material
Dim sFileList42(0)
sFileList42(0) = sPathAddDocument42
PP.AddComponentsFromFiles sFileList42, "All"
'Ausrichten
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutSightDirection Array(1#, 1, 0)
CATIA.ActiveWindow.ActiveViewer.Viewpoint3D.PutUpDirection Array(0, 0, 1)
CATIA.ActiveWindow.ActiveViewer.Reframe
CATIA.ActiveWindow.ActiveViewer.ZoomIn
CATIA.ActiveWindow.ActiveViewer.ZoomIn
Else
MsgBox ("Keine Geometrieänderung")
Exit Sub
End If
End If
End If
Case "2"
MsgBox ("Das Makro wurde abgebrochen.")
Exit Sub
End Select
End Sub