'---------------------------------------------------------------------------------------------------------------------------------- 'bib 23-07-2003 'creation of the bounding box with 1mm offset on each face 'the document must be a catpart 'inputs: ' - a local axis ' - a surface '---------------------------------------------------------------------------------------------------------------------------------- Set objXL = GetObject(, "Excel.Application") objXL.Visible = True Set oAWBook = objxl.Workbooks Dim AbmasseStueckl as String Dim LoescheBody as String Dim Offset_Bbox_Max_X_Loesch AS String Dim Offset_Bbox_Min_X_Loesch AS String Dim Offset_Bbox_Max_Y_Loesch AS String Dim Offset_Bbox_Min_Y_Loesch AS String Dim Offset_Bbox_Max_Z_Loesch AS String Dim Offset_Bbox_Min_Z_Loesch AS String Dim Bbox_dx_hidden_Loesch AS String Dim Bbox_dy_hidden_Loesch AS String Dim Bbox_dz_hidden_Loesch AS String Dim Bbox_dx_Loesch AS String Dim Bbox_dy_Loesch AS String Dim Bbox_dz_Loesch AS String Dim Formula_1_Losche AS String Dim Formula_2_Losche AS String Dim Formula_3_Losche AS String Dim Formula_4_Losche AS String Dim Formula_5_Losche AS String Dim Formula_6_Losche AS String Dim Formula_7_Losche AS String Dim Formula_8_Losche AS String Dim Formula_9_Losche AS String Sub CATMain() Dim specsAndGeomWindow1 As Window Set specsAndGeomWindow1 = CATIA.ActiveWindow Dim viewer3D1 As Viewer Set viewer3D1 = specsAndGeomWindow1.ActiveViewer viewer3D1.Reframe Dim viewpoint3D1 As Viewpoint3D Set viewpoint3D1 = viewer3D1.Viewpoint3D Box AusgabeAbmasse end Sub '#################################### '####################################################################################################################################### Sub AusgabeAbmasse() '************************************************************************************************************************************************++ Set productDocument1 = CATIA.ActiveDocument Set product1 = productDocument1.Product Name = product1.PartNumber 'Name_1 = mid(Name, InStrRev(Name, "_") + 1) 'Right Left Mid 'ZeichNr = Left(Name, InStrRev(Name, "_") -1) 'Right Left Mid 'Name_3 = Left(Name, InStrRev(Name, ".CAT") - 1) 'Right Left Mid '______________________________________________________Param Leden _____________________________________________________________________________________________ '############# Daten lesen ################# Name_Part = product1.PartNumber 'Name = CATIA.ActiveDocument.Name Pfad_Part = CATIA.ActiveDocument.path ZeichName_Part = Pfad + "\" + Name Dim Bodyname As String Bodyname = CATIA.ActiveDocument.Part.MainBody.Name Bodyname_Mat = Bodyname + "\Material" ParaX = Name_Part + "\Bbox_dx.2" ParaY = Name_Part + "\Bbox_dy.2" ParaZ = Name_Part + "\Bbox_dz.2" 'msgbox Bodyname_Mat '############# Daten lesen ################# 'Dim partDocument1 As Document Set partDocument1 = CATIA.ActiveDocument Dim product1 As CATBaseDispatch Set product1 = partDocument1.GetItem(Name_Part) Dim parameters1 As Parameters Set parameters1 = product1.UserRefProperties Dim strParam1 As StrParam Set product1 = partDocument1.GetItem(Name_Part) Set product1 = product1.ReferenceProduct 'Dim part1 As Part Set part1 = partDocument1.Part Set parameters1 = part1.Parameters 'Dim strParam1 As Parameter On Error Resume Next Set strParam1 = parameters1.Item(Bodyname_Mat)'("Hauptkörper"\Material")' strParam1.Value = (ZeichName_Part) Set product1 = product1.ReferenceProduct Material1 = strParam1.Value On Error Resume Next Material = Left(Material1, InStrRev(Material1, "_") - 2) 'msgbox Material If Err Then Material = "Kein Material" 'msgbox "Kein Prameter" end if 'On Error Resume Next Set strParam1 = parameters1.Item(ParaX) P_X = strParam1.Value Set strParam1 = parameters1.Item(ParaY) P_Y = strParam1.Value Set strParam1 = parameters1.Item(ParaZ) P_Z = strParam1.Value 'MsgBox "Abmasse= " & P_X & "x" & P_Y & "x" & P_Z & vbCrLf & "Material= " & Material wert1= CInt(P_X) wert2= CInt(P_Y) wert3= CInt(P_Z) '******************************************* 'http://www.tutorials.de/visual-basic-6-0/161663-3-zahlen-der-groesse-nach-sortieren.html If wert1 < wert2 Then temp = wert2 wert2 = wert1 wert1 = temp End If If wert1 < wert3 Then temp = wert3 wert3 = wert1 wert1 = temp End If If wert2 < wert3 Then temp = wert3 wert3 = wert2 wert2 = temp End If 'so wäre wert1 immer die grösste, wert2 immer die mittlere und wert3 immer die kleinste.. '************************************ if wert1 = "" Then 'msgbox "zeige nix an" else if wert1 = wert2 or wert2 = wert3 then RundBauteilErkannt = Msgbox("Das Skript hat ein Rund Teil erkannt." & vbCr &_ "ist dieses Korrekt?" , vbYesNo + vbQuestion, "Rund Bauteil erkannt") If RundBauteilErkannt = vbYes Then if wert1 = wert2 then AbmasseStueckl = "ø" & wert1 & "x" & wert3 end if if wert2 = wert3 then AbmasseStueckl = "ø" & wert2 & "x" & wert1 end if End if If RundBauteilErkannt = vbNo Then AbmasseStueckl = wert1 & "x" & wert2 & "x" & wert3 end if else AbmasseStueckl = wert1 & "x" & wert2 & "x" & wert3 end if end if '**************************************** Dim partDocument1 As Document Set partDocument1 = CATIA.ActiveDocument Dim selection1 As Selection Set selection1 = partDocument1.Selection selection1.Clear Dim part1 As Part Set part1 = partDocument1.Part Dim bodies1 As Bodies Set bodies1 = part1.Bodies Dim body1 As Body Set body1 = bodies1.Item(LoescheBody) selection1.Add body1 selection1.Delete selection1.Clear '************************************* '**************************** Loesche Formeln ******************************************* 'Dim partDocument1 As Document Set partDocument1 = CATIA.ActiveDocument 'Dim selection1 As Selection Set selection1 = partDocument1.Selection selection1.Clear 'Dim part1 As Part Set part1 = partDocument1.Part Dim relations1 As Relations Set relations1 = part1.Relations Dim formula1 As Relation Set formula1 = relations1.Item(Formula_9_Losche) selection1.Add formula1 Dim relations2 As Relations Set relations2 = part1.Relations Dim formula2 As Relation Set formula2 = relations2.Item(Formula_8_Losche) selection1.Add formula2 Dim relations3 As Relations Set relations3 = part1.Relations Dim formula3 As Relation Set formula3 = relations3.Item(Formula_7_Losche) selection1.Add formula3 Dim relations4 As Relations Set relations4 = part1.Relations Dim formula4 As Relation Set formula4 = relations4.Item(Formula_6_Losche) selection1.Add formula4 Dim relations5 As Relations Set relations5 = part1.Relations Dim formula5 As Relation Set formula5 = relations5.Item(Formula_5_Losche) selection1.Add formula5 Dim relations6 As Relations Set relations6 = part1.Relations Dim formula6 As Relation Set formula6 = relations6.Item(Formula_4_Losche) selection1.Add formula6 Dim relations7 As Relations Set relations7 = part1.Relations Dim formula7 As Relation Set formula7 = relations7.Item(Formula_3_Losche) selection1.Add formula7 Dim relations8 As Relations Set relations8 = part1.Relations Dim formula8 As Relation Set formula8 = relations8.Item(Formula_2_Losche) selection1.Add formula8 Dim relations9 As Relations Set relations9 = part1.Relations Dim formula9 As Relation Set formula9 = relations9.Item(Formula_1_Losche) selection1.Add formula9 selection1.Delete '**************************** Loesche Parameter ******************************************* Set parameters1 = part1.Parameters Dim length1 As Parameter Set length1 = parameters1.Item( Name_Part & "\" & Bbox_dz_hidden_Loesch) selection1.Add length1 Dim parameters2 As Parameters Set parameters2 = part1.Parameters Dim length2 As Parameter Set length2 = parameters2.Item(Name_Part & "\" & Bbox_dy_hidden_Loesch) selection1.Add length2 Dim parameters3 As Parameters Set parameters3 = part1.Parameters Dim length3 As Parameter Set length3 = parameters3.Item(Name_Part & "\" & Bbox_dx_hidden_Loesch) selection1.Add length3 Dim parameters4 As Parameters Set parameters4 = part1.Parameters Dim length4 As Parameter Set length4 = parameters4.Item(Name_Part & "\" & Offset_Bbox_Min_Z_Loesch) selection1.Add length4 Dim parameters5 As Parameters Set parameters5 = part1.Parameters Dim length5 As Parameter Set length5 = parameters5.Item(Name_Part & "\" & Offset_Bbox_Max_Z_Loesch) selection1.Add length5 Dim parameters6 As Parameters Set parameters6 = part1.Parameters Dim length6 As Parameter Set length6 = parameters6.Item(Name_Part & "\" & Offset_Bbox_Min_Y_Loesch) selection1.Add length6 Dim parameters7 As Parameters Set parameters7 = part1.Parameters Dim length7 As Parameter Set length7 = parameters7.Item(Name_Part & "\" & Offset_Bbox_Max_Y_Loesch) selection1.Add length7 Dim parameters8 As Parameters Set parameters8 = part1.Parameters Dim length8 As Parameter Set length8 = parameters8.Item(Name_Part & "\" & Offset_Bbox_Min_X_Loesch) selection1.Add length8 Dim parameters9 As Parameters Set parameters9 = part1.Parameters Dim length9 As Parameter Set length9 = parameters9.Item(Name_Part & "\" & Offset_Bbox_Max_X_Loesch) selection1.Add length9 selection1.Delete '************************************* 'Dim length1 As Parameter Set length1 = parameters1.Item(Name_Part & "\" & "Bbox_dz.2") selection1.Add length1 'Dim parameters2 As Parameters Set parameters2 = part1.Parameters 'Dim length2 As Parameter Set length2 = parameters2.Item(Name_Part & "\" & "Bbox_dy.2") selection1.Add length2 'Dim parameters3 As Parameters Set parameters3 = part1.Parameters 'Dim length3 As Parameter Set length3 = parameters3.Item(Name_Part & "\" & "Bbox_dx.2") selection1.Add length3 selection1.Delete '*************************************************** 'msgbox AbmasseStueckl Stuecklkompltt = objXL.Worksheets.Item("WarteAuf").Cells(1,1).Value If Stuecklkompltt = "nein_Stuecklkompl" or Stuecklkompltt = "" then BauteilMasse = InputBox ("Bauteile Maße" & vbCr &_ "Material : " & Material, "Abmasse" , AbmasseStueckl) end if if Stuecklkompltt = "Ja_Stuecklkompl" then objXL.Worksheets.Item("Stueckl").Cells(1,10).Value = AbmasseStueckl objXL.Worksheets.Item("Stueckl").Cells(1,11).Value = Material end if '################### 'CATIA.ActiveDocument.close End Sub Sub Box() 'declaration des variables CATIA.DisplayFileAlerts = False Dim Message, Style, Title, Response, MyString ' Message = ("This macro will find the bounding box of a solid or a JOINED Surface with 1mm offset on each face" &_ ' (chr(13)) &_ ' " - The active document must be a CATPart"&_ ' (chr(13)) &_ ' " - A local Axis must be previously created"&_ ' (chr(13)) &_ ' ""&(chr(13))&_ ' " Do you want to continue ?") 'Style = vbYesNo + vbDefaultButton2 'Define buttons. 'Title = "Purpose " 'Response = MsgBox(Message, Style, Title) 'Response = "Yes" 'If Response = "Yes" Then ' User chose Yes. MyString = "Yes" Dim axis Dim remake Dim partDocument1 As PartDocument Dim part1 As Part dim axisref as reference Dim ShapeFactory1 as ShapeFactory Dim hybridShapeFactory1 As HybridShapeFactory Dim sStatus As String Dim hybridShapeD1 , hybridShapeD2 ,hybridShapeD3 As HybridShapeDirection Dim Default, a1,a2,a3,a4,a5,a6 'servent au changement des dimensions de la box Dim bodies1 As Bodies Dim body1 As Body Dim reference1 As Reference 'la shape Dim HybridShapeExtremum1 ,HybridShapeExtremum2 ,HybridShapeExtremum3 As HybridShapeExtremum Dim HybridShapeExtremum4 ,HybridShapeExtremum5 ,HybridShapeExtremum6 As HybridShapeExtremum Dim originCoord(2) Set partDocument1 = CATIA.ActiveDocument If (Instr(partDocument1.Name,".CATPart"))<> 0 Then Set part1 = partDocument1.Part Set Selection = partDocument1.Selection part1.Update Set hybridShapeFactory1 = part1.HybridShapeFactory ReDim sFilter(0) '**************************** Dim partDocument12 As Document Set partDocument12 = CATIA.ActiveDocument Dim part12 As Part Set part12 = partDocument12.Part Dim hybridBodies12 As HybridBodies Set hybridBodies12 = part12.HybridBodies Dim hybridBody12 As HybridBody 'Set hybridBody12 = hybridBodies12.Add() Dim hybridShapeFactory12 As Factory Set hybridShapeFactory12 = part12.HybridShapeFactory Dim axisSystems12 As AxisSystems Set axisSystems12 = part12.AxisSystems Dim axisSystem12 As AxisSystem on Error Resume next Set axisSystem12 = axisSystems12.Item(1)'("Absolutes Achsensystem") if Err Then MsgBox "Es konnte kein Achsensytem gefunden werden." & vbCr & "" & vbCr & "Abmessungen werden nicht ausgelesen.", vbOKOnly + vbCritical, "kein Achsensystem" 'Dim Params() 'LibPath = FlexPfad & "\Bauteil-Abmasse\" ' Pfad wo das Makro liegt 'ScriptName = "Achsen-System-einfuegen.CATScript" ' Makroname 'FunctionName = "CATMain" ' Funktion die aufgerufen werden soll 'Call CATIA.SystemService.ExecuteScript(LibPath, catScriptLibraryTypeDirectory, ScriptName, FunctionName, Params) 'Set axisSystem12 = axisSystems12.Item(1)'("Absolutes Achsensystem") exit sub end if 'Dim reference12 As Reference 'Set reference12 = part12.CreateReferenceFromBRepName("RSur:(Face:(Brp:(AxisSystem.1;1);None:();Cf11:());WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)", axisSystem12) Dim Activdocu As document Set Activdocu = CATIA.ActiveDocument Activdocu.selection.Add axisSystem12 part12.Update '******************************** 'Msgbox "Select a local axis " sFilter(0) = "AxisSystem" 'sStatus = Selection.SelectElement2(sFilter, "select a local axis", False) dim axiscoord(2) dim axissyst Set axissyst = Selection.Item(1).value set axisref= Selection.Item(1).value ref_name_systaxis = axissyst.Name axissyst.IsCurrent = 1 axissyst.name ="gertrude.toto" axname = axissyst.Name dim originpoint as HybridShapePointCoord axisSyst.GetOrigin originCoord set originpoint= hybridShapeFactory1.AddNewPointCoord(originCoord(0) ,originCoord(1) ,originCoord(2) ) set axisref = Part1.CreateReferenceFromObject (originpoint) axissyst.GetXAxis AxisCoord Set hybridShapeD1 = hybridShapeFactory1.AddNewDirectionByCoord(AxisCoord(0), AxisCoord(1), AxisCoord(2)) axissyst.GetYAxis AxisCoord Set hybridShapeD2 = hybridShapeFactory1.AddNewDirectionByCoord(AxisCoord(0), AxisCoord(1), AxisCoord(2)) axissyst.GetZAxis AxisCoord Set hybridShapeD3 = hybridShapeFactory1.AddNewDirectionByCoord(AxisCoord(0), AxisCoord(1), AxisCoord(2)) dim Plane_line_1 as hybridshapelineptdir set Plane_line_1=hybridShapeFactory1.addnewlinePtDir(originpoint,hybridShapeD1,0,0,false) dim Plane_line_2 as hybridshapelineptdir set Plane_line_2=hybridShapeFactory1.addnewlinePtDir(originpoint,hybridShapeD2,0,0,false) Selection.Clear Set partDocument1 = CATIA.ActiveDocument Set part1 = partDocument1.Part Dim oBodies As Bodies Set oBodies = Part1.Bodies Dim j As Integer j = oBodies.Count Set bodies1 = part1.Bodies Set body1 = bodies1.Add() body1.name="Boundingbox." & j LoescheBody = "Boundingbox." & j Set hybridBodies1 = body1.HybridBodies Set hybridBody1 = hybridBodies1.Add hybridBody1.Name = "definition_points" 'demande a l'utilisateur de selectionner la face ReDim sFilter(0) '-------------------------------------------------------------------------------------------------------- Msgbox "Select a Face " sFilter(0) = "Face" sStatus = Selection.SelectElement2(sFilter, "select a face", False) If (sStatus = "Cancel") Then Exit Sub End If Set reference1= Selection.Item(1).Value dim hybridShapeExtract1 as HybridShapeExtract Set hybridShapeExtract1 = hybridShapeFactory1.AddNewExtract(reference1) hybridShapeExtract1.PropagationType = 1 hybridShapeExtract1.ComplementaryExtract = False hybridShapeExtract1.IsFederated = False set reference1 = hybridShapeExtract1 'creation des 6 points extremums de la shape selectionnée Set HybridShapeExtremum1 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeD1, 1) Set HybridShapeExtremum2 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeD1, 0) Set hybridShapeExtremum3 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeD2, 1) Set hybridShapeExtremum4 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeD2, 0) Set hybridShapeExtremum5 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeD3, 1) Set hybridShapeExtremum6 = hybridShapeFactory1.AddNewExtremum(reference1, hybridShapeD3, 0) part1.Update 'on se met dans l'open body "def_points" Dim hybridBody2 As HybridBody Set hybridBody2 = hybridBodies1.Item("definition_points") hybridBody2.AppendHybridShape HybridShapeExtremum1 part1.InWorkObject = HybridShapeExtremum1 HybridShapeExtremum1.Name = "max_X" hybridBody2.AppendHybridShape HybridShapeExtremum2 part1.InWorkObject = HybridShapeExtremum2 HybridShapeExtremum2.Name = "min_X" hybridBody2.AppendHybridShape hybridShapeExtremum3 part1.InWorkObject = hybridShapeExtremum3 hybridShapeExtremum3.Name = "max_Y" hybridBody2.AppendHybridShape hybridShapeExtremum4 part1.InWorkObject = hybridShapeExtremum4 hybridShapeExtremum4.Name = "min_Y" hybridBody2.AppendHybridShape hybridShapeExtremum5 part1.InWorkObject = hybridShapeExtremum5 hybridShapeExtremum5.Name = "max_Z" hybridBody2.AppendHybridShape hybridShapeExtremum6 part1.InWorkObject = hybridShapeExtremum6 hybridShapeExtremum6.Name = "min_Z" part1.update 'creation des points aux meme coordonnees que les extremums Dim Ref1 as reference Set Ref1 = part1.CreateReferenceFromObject(HybridShapeExtremum1) Dim Point1 As HybridShapePointCoord Set Point1 = hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, Ref1) hybridBody2.AppendHybridShape Point1 set point_ref11=part1.CreateReferenceFromObject(Point1) Dim Ref2 As Reference Set Ref2 = part1.CreateReferenceFromObject(HybridShapeExtremum2) Dim Point2 As HybridShapePointCoord Set Point2 = hybridShapeFactory1.AddNewPointCoordWithReference(0,0 , 0, Ref2) hybridBody2.AppendHybridShape Point2 set point_ref12=part1.CreateReferenceFromObject(Point2) Dim Ref3 As Reference Set Ref3 = part1.CreateReferenceFromObject(HybridShapeExtremum3) Dim Point3 As HybridShapePointCoord Set Point3 = hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, Ref3) hybridBody2.AppendHybridShape Point3 set point_ref13=part1.CreateReferenceFromObject(Point3) Dim Ref4 As Reference Set Ref4 = part1.CreateReferenceFromObject(HybridShapeExtremum4) Dim Point4 As HybridShapePointCoord Set Point4 = hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, Ref4) hybridBody2.AppendHybridShape Point4 set point_ref14=part1.CreateReferenceFromObject(Point4) Dim Ref5 As Reference Set Ref5 = part1.CreateReferenceFromObject(HybridShapeExtremum5) Dim Point5 As HybridShapePointCoord Set Point5 = hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, Ref5) hybridBody2.AppendHybridShape Point5 set point_ref5=part1.CreateReferenceFromObject(Point5) Dim Ref6 As Reference Set Ref6 = part1.CreateReferenceFromObject(HybridShapeExtremum6) Dim Point6 As HybridShapePointCoord Set Point6 = hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, Ref6) hybridBody2.AppendHybridShape Point6 set point_ref6= part1.CreateReferenceFromObject(Point6) ' Update pour les points avant creation du skrtch (12/09/2003) part1.update ' Fin Update axissyst.IsCurrent = 1 'creation d'un sketch Set sketches1 = hybridBody1.HybridSketches Set reference_axis_syst = part1.CreateReferenceFromName("Selection_RSur:(Face:(Brp:(gertrude.toto;1);None:());gertrude.toto)") Set standard_body_sketch1 = sketches1.Add(reference_axis_syst) Set factory2D1 = standard_body_sketch1.OpenEdition() Set geometricElements1 =standard_body_sketch1.GeometricElements Set axis2D1 = geometricElements1.Item("Absolute Achse") Set line_HDirection = axis2D1.GetItem("H-Richtung") line_HDirection.ReportName = 1 Set line_VDirection = axis2D1.GetItem("V-Richtung") line_VDirection.ReportName = 2 'Creation d'un carré dans le sketch ponto = 20000 Set point_ref_1 = factory2D1.CreatePoint(-ponto, -ponto) point_ref_1.ReportName = 3 Set point_ref_2 = factory2D1.CreatePoint(ponto, -ponto) point_ref_2.ReportName = 4 Set point_ref_3 = factory2D1.CreatePoint(ponto, ponto) point_ref_3.ReportName = 5 Set point_ref_4 = factory2D1.CreatePoint(-ponto, ponto) point_ref_4.ReportName = 6 Set line_ref_1_2 = factory2D1.CreateLine(-ponto, -ponto, ponto, -ponto) line_ref_1_2.ReportName = 7 line_ref_1_2.StartPoint = point_ref_1 line_ref_1_2.EndPoint = point_ref_2 Set line_ref_2_3 = factory2D1.CreateLine(ponto, -ponto, ponto, ponto) line_ref_2_3.ReportName = 8 line_ref_2_3.StartPoint = point_ref_2 line_ref_2_3.EndPoint = point_ref_3 Set line_ref_3_4 = factory2D1.CreateLine(-ponto, ponto, ponto, ponto) line_ref_3_4.ReportName = 9 line_ref_3_4.StartPoint = point_ref_4 line_ref_3_4.EndPoint = point_ref_3 Set line_ref_4_1 = factory2D1.CreateLine(-ponto, -ponto, -ponto, ponto) line_ref_4_1.ReportName = 10 'line_ref_4_1.Construction = True line_ref_4_1.StartPoint = point_ref_1 line_ref_4_1.EndPoint = point_ref_4 'Referencement et creation des contraintes Set reference_line_ref_1_2 = part1.CreateReferenceFromObject(line_ref_1_2) Set reference_line_ref_2_3 =part1.CreateReferenceFromObject(line_ref_2_3) Set reference_line_ref_3_4 =part1.CreateReferenceFromObject(line_ref_3_4) Set reference_line_ref_4_1 =part1.CreateReferenceFromObject(line_ref_4_1) Set electrode_constraints = standard_body_sketch1.Constraints ' Modif de la refrence des points du 12/09/2003) Set constraint_toto_2 = electrode_constraints.AddBiEltCst(catCstTypeDistance,point_ref11, reference_line_ref_2_3) Set constraint_toto_3 = electrode_constraints.AddBiEltCst(catCstTypeDistance, point_ref13, reference_line_ref_3_4) Set constraint_toto_4 = electrode_constraints.AddBiEltCst(catCstTypeDistance, reference_line_ref_4_1, point_ref12) Set constraint_toto_1 = electrode_constraints.AddBiEltCst(catCstTypeDistance,reference_line_ref_1_2, point_ref14 ) 'Fin modif Dim length1 As Dimension Set length1 =constraint_toto_1.Dimension length1.Value =0 Dim length2 As Dimension Set length2 =constraint_toto_2.Dimension length2.Value = 0 Dim length3 As Dimension Set length3 =constraint_toto_3.Dimension length3.Value = 0 Dim length4 As Dimension Set length4 =constraint_toto_4.Dimension length4.Value = 0 standard_body_sketch1.closeEdition() part1.update '---------------------------------------------------------------------------------------------------------------------------------- 'creation des plans inférieur et superieur matches sur les extremums '---------------------------------------------------------------------------------------------------------------------------------- dim plan_inferieur as hybridshapeplaneoffsetpt dim plan_origin as hybridshapePlanes2lines dim Origin_line_1 as reference set Origin_line_1 = part1.createreferencefromobject(line_HDirection) dim Origin_line_2 as reference set Origin_line_2 = part1.createreferencefromobject(line_VDirection) set plan_origin = hybridShapeFactory1.addnewplane2lines(Origin_line_1,Origin_line_2) dim ref_plan_origin as reference set ref_plan_origin = part1.createreferencefromobject(plan_origin) Set Ref6 = part1.CreateReferenceFromObject(HybridShapeExtremum6) set plan_inferieur=hybridshapefactory1.addnewplaneOffsetPt(ref_plan_origin,point_ref6) hybridBody2.AppendHybridShape plan_inferieur part1.InWorkObject = plan_inferieur dim plan_superieur as hybridshapeplaneoffsetpt Set Ref5 = part1.CreateReferenceFromObject(HybridShapeExtremum5) set plan_superieur=hybridshapefactory1.addnewplaneOffsetPt(ref_plan_origin,point_ref5) hybridBody2.AppendHybridShape plan_superieur part1.InWorkObject = plan_superieur part1.Update '---------------------------------------------------------------------------------------------------------------------------------- 'creation des plans inférieur et superieur offsetes '---------------------------------------------------------------------------------------------------------------------------------- Dim Point_inf As HybridShapePointCoord Set Point_inf = hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, point_ref6) hybridBody2.AppendHybridShape Point_inf dim ref_point_inf as reference set ref_point_inf =part1.createreferencefromobject(Point_inf) 'projection du point inferieur sur le plan superieur dim proj_pt_inf as hybridshapeproject set proj_pt_inf = hybridshapefactory1.addnewproject(point_ref6, plan_superieur ) hybridBody2.AppendHybridShape proj_pt_inf part1.InWorkObject = proj_pt_inf Dim Point_sup As HybridShapePointCoord Set Point_sup= hybridShapeFactory1.AddNewPointCoordWithReference(0, 0, 0, proj_pt_inf) hybridBody2.AppendHybridShape Point_sup dim ref_point_sup as reference set ref_point_sup =part1.createreferencefromobject(Point_sup) dim line_guide as hybridshapelineptpt set line_guide=hybridshapefactory1.addnewlineptpt( ref_point_sup,ref_point_inf) hybridBody2.AppendHybridShape line_guide part1.InWorkObject = line_guide set ref_guideline =part1.createreferencefromobject(line_guide) dim oStart as length set oStart=line_guide.beginoffset oStart.value =1 dim oEnd as length set oEnd=line_guide.endoffset oEnd.value =1 Set constraints_for_z = part1.Constraints Set constraint_dz =constraints_for_z.AddMonoEltCst(catCstTypeLength,ref_guideline ) set length_dz= constraint_dz.Dimension part1.update '---------------------------------------------------------------------------------------------------------------------------------- 'creation second sketch '---------------------------------------------------------------------------------------------------------------------------------- Set sketches2 = hybridBody1.HybridSketches Set standard_body_sketch2 = sketches2.Add(plan_inferieur) Set factory2D2 = standard_body_sketch2.OpenEdition() Set geometricElements2 =standard_body_sketch2.GeometricElements Set axis2D1 = geometricElements1.Item("Absolute Achse") 'Creation d'un carré dans le sketch pont = 200000 Set point_ref1_1 = factory2D2.CreatePoint(-pont, -pont) Set point_ref1_2 = factory2D2.CreatePoint(pont, -pont) Set point_ref1_3 = factory2D2.CreatePoint(pont, pont) Set point_ref1_4 = factory2D2.CreatePoint(-pont, pont) Set line_ref1_1_2 = factory2D2.CreateLine(-pont, -pont, pont, -pont) line_ref1_1_2.StartPoint = point_ref1_1 line_ref1_1_2.EndPoint = point_ref1_2 Set line_ref1_2_3 = factory2D2.CreateLine(pont, -pont, pont, pont) line_ref1_2_3.StartPoint = point_ref1_2 line_ref1_2_3.EndPoint = point_ref1_3 Set line_ref1_3_4 = factory2D2.CreateLine(-pont, pont, pont, pont) line_ref1_3_4.StartPoint = point_ref1_4 line_ref1_3_4.EndPoint = point_ref1_3 Set line_ref1_4_1 = factory2D2.CreateLine(-pont, -pont, -pont, pont) line_ref1_4_1.StartPoint = point_ref1_1 line_ref1_4_1.EndPoint = point_ref1_4 'Referencement et creation des contraintes Set reference_line_ref1_1_2 =part1.CreateReferenceFromObject(line_ref1_1_2) Set reference_line_ref1_2_3 =part1.CreateReferenceFromObject(line_ref1_2_3) Set reference_line_ref1_3_4 =part1.CreateReferenceFromObject(line_ref1_3_4) Set reference_line_ref1_4_1 =part1.CreateReferenceFromObject(line_ref1_4_1) Set reference_line_ref_1_2 =part1.CreateReferenceFromObject(line_ref_1_2) Set reference_line_ref_2_3 =part1.CreateReferenceFromObject(line_ref_2_3) Set reference_line_ref_3_4 =part1.CreateReferenceFromObject(line_ref_3_4) Set reference_line_ref_4_1 =part1.CreateReferenceFromObject(line_ref_4_1) set proj_1_2 = factory2D2.CreateProjection(reference_line_ref_1_2) set proj_2_3 = factory2D2.CreateProjection(reference_line_ref_2_3) set proj_3_4= factory2D2.CreateProjection(reference_line_ref_3_4) set proj_4_1 = factory2D2.CreateProjection(reference_line_ref_4_1) set ref_line_sk1_1_2=part1.createreferencefromobject(proj_1_2) set ref_line_sk1_2_3=part1.createreferencefromobject(proj_2_3) set ref_line_sk1_3_4=part1.createreferencefromobject(proj_3_4) set ref_line_sk1_4_1=part1.createreferencefromobject(proj_4_1) Set electrode_constraints = standard_body_sketch2.Constraints Set constraint_toto_11 = electrode_constraints.AddBiEltCst(catCstTypeDistance, reference_line_ref1_1_2, ref_line_sk1_1_2) Set constraint_toto_12 = electrode_constraints.AddBiEltCst(catCstTypeDistance, ref_line_sk1_2_3, reference_line_ref1_2_3) Set constraint_toto_13 = electrode_constraints.AddBiEltCst(catCstTypeDistance, ref_line_sk1_3_4, reference_line_ref1_3_4) Set constraint_toto_14 = electrode_constraints.AddBiEltCst(catCstTypeDistance, reference_line_ref1_4_1,ref_line_sk1_4_1 ) 'Dim length11 As Dimension Set length11 =constraint_toto_11.Dimension length11.Value =1 Dim length12 As Dimension Set length12 =constraint_toto_12.Dimension length12.Value = 1 Dim length13 As Dimension Set length13 =constraint_toto_13.Dimension length13.Value = 1 Dim length14 As Dimension Set length14 =constraint_toto_14.Dimension length14.Value = 1 standard_body_sketch2.closeEdition() part1.update '---------------------------------------------------------------------------------------------------------------------------------- 'creation third sketch '---------------------------------------------------------------------------------------------------------------------------------- Set sketches3 = hybridBody1.HybridSketches Set standard_body_sketch3 = sketches3.Add(plan_inferieur) Set factory2D3 = standard_body_sketch3.OpenEdition() Set geometricElements3 =standard_body_sketch3.GeometricElements Set axis2D1 = geometricElements1.Item("Absolute Achse") 'Referencement et creation des contraintes Set reference_line_ref1_1_2 =part1.CreateReferenceFromObject(line_ref1_1_2) Set reference_line_ref1_2_3 =part1.CreateReferenceFromObject(line_ref1_2_3) Set reference_line_ref1_3_4 =part1.CreateReferenceFromObject(line_ref1_3_4) Set reference_line_ref1_4_1 =part1.CreateReferenceFromObject(line_ref1_4_1) set proj1_1_2 = factory2D3.CreateProjection(reference_line_ref1_1_2) set proj1_2_3 = factory2D3.CreateProjection(reference_line_ref1_2_3) set proj1_3_4= factory2D3.CreateProjection(reference_line_ref1_3_4) set proj1_4_1 = factory2D3.CreateProjection(reference_line_ref1_4_1) set ref_proj1_1_2 = part1.CreateReferenceFromObject(proj1_1_2) set ref_proj1_2_3 = part1.CreateReferenceFromObject(proj1_2_3) set ref_proj1_3_4= part1.CreateReferenceFromObject(proj1_3_4) set ref_proj1_4_1 = part1.CreateReferenceFromObject(proj1_4_1) set constraints_dim= standard_body_sketch3.constraints Set constraint_dx = constraints_dim.AddMonoEltCst(catCstTypeLength,ref_proj1_1_2 ) Set constraint_dy = constraints_dim.AddMonoEltCst(catCstTypeLength,ref_proj1_2_3 ) Set length_dx =constraint_dx.Dimension dx_value=length_dx.value Set length_dy=constraint_dy.Dimension dy_value=length_dy.value standard_body_sketch3.closeEdition() part1.update 'creation des 6 parametres pour changer la dimension dim string_1 as string string_1="Offset_Bbox_Max_X." & j dim string_2 as string string_2="Offset_Bbox_Min_X." & j dim string_3 as string string_3="Offset_Bbox_Max_Y." & j dim string_4 as string string_4="Offset_Bbox_Min_Y." & j dim string_5 as string string_5="Offset_Bbox_Max_Z." & j dim string_6 as string string_6="Offset_Bbox_Min_Z." & j dim string_7 as string string_7="Bbox_dx." & j dim string_8 as string string_8="Bbox_dy." & j dim string_9 as string string_9="Bbox_dz." & j '******************************* Dim Offset_Bbox_Max_X As RealParam Set Offset_Bbox_Max_X = part1.Parameters.CreateDimension( string_1,"Length", 0) Offset_Bbox_Max_X_Loesch = string_1 Dim Offset_Bbox_Min_X As RealParam Set Offset_Bbox_Min_X= part1.Parameters.CreateDimension( string_2,"Length", 0) Offset_Bbox_Min_X_Loesch = string_2 Dim Offset_Bbox_Max_Y As RealParam Set Offset_Bbox_Max_Y= part1.Parameters.CreateDimension( string_3,"Length", 0) Offset_Bbox_Max_Y_Loesch = string_3 Dim Offset_Bbox_Min_Y As RealParam Set Offset_Bbox_Min_Y= part1.Parameters.CreateDimension( string_4,"Length", 0) Offset_Bbox_Min_Y_Loesch = string_4 Dim Offset_Bbox_Max_Z As RealParam Set Offset_Bbox_Max_Z= part1.Parameters.CreateDimension( string_5,"Length", 0) Offset_Bbox_Max_Z_Loesch = string_5 Dim Offset_Bbox_Min_Z As RealParam Set Offset_Bbox_Min_Z= part1.Parameters.CreateDimension( string_6,"Length", 0) Offset_Bbox_Min_Z_Loesch = string_6 Set Bbox_dx_hidden = part1.Parameters.CreateDimension(string_7,"Length",dx_value) Bbox_dx_hidden_Loesch = string_7 Set Bbox_dy_hidden = part1.Parameters.CreateDimension(string_8,"Length",dy_value) Bbox_dy_hidden_Loesch = string_8 Set Bbox_dz_hidden = part1.Parameters.CreateDimension(string_9, "Length",length_dz.value) Bbox_dz_hidden_Loesch = string_9 Bbox_dx_hidden.hidden=True Bbox_dy_hidden.hidden=True Bbox_dz_hidden.hidden=True Set Bbox_dx= part1.Parameters.CreateDimension(string_7,"Length",0) Bbox_dx_Loesch = string_7 Set Bbox_dy= part1.Parameters.CreateDimension(string_8,"Length",0) Bbox_dy_Losch = string_8 Set Bbox_dz= part1.Parameters.CreateDimension(string_9,"Length",0) Bbox_dz_Losch = string_9 'creation des formules pour modifier les dimensions de la boite Dim Formula_1 As Formula Set Formula_1 = part1.Relations.CreateFormula ("formula_Bbox_1."& j, "",length14, "Offset_Bbox_Min_X." & j ) Formula_1_Losche = "formula_Bbox_1."& j Dim Formula_2 As Formula Set Formula_2 = part1.Relations.CreateFormula ("formula_Bbox_2."& j, "",length12, "Offset_Bbox_Max_X."& j ) Formula_2_Losche = "formula_Bbox_2."& j Dim Formula_3 As Formula Set Formula_3 = part1.Relations.CreateFormula ("formula_Bbox_4."& j, "",length11, "Offset_Bbox_Min_Y." & j ) Formula_3_Losche = "formula_Bbox_4."& j Dim Formula_4 As Formula Set Formula_4 = part1.Relations.CreateFormula ("formula_Bbox_4."& j, "",length13, "Offset_Bbox_Max_Y."& j ) Formula_4_Losche = "formula_Bbox_4."& j Dim Formula_5 As Formula Set Formula_5 = part1.Relations.CreateFormula ("formula_Bbox_5."& j, "",oEnd , " Offset_Bbox_Min_Z." & j ) Formula_5_Losche = "formula_Bbox_5."& j Dim Formula_6 As Formula Set Formula_6 = part1.Relations.CreateFormula ("formula_Bbox_6."& j, "",oStart, " Offset_Bbox_Max_Z." & j ) Formula_6_Losche = "formula_Bbox_6."& j Dim Formula_7 As Formula Set Formula_7 = part1.Relations.CreateFormula ("formula_Bbox_7."& j, "", Bbox_dx ,"Bbox_dx." & j & "+Offset_Bbox_Min_X." & j & "+Offset_Bbox_Max_X." & j &"-2mm") Formula_7_Losche = "formula_Bbox_7."& j Dim Formula_8 As Formula Set Formula_8 = part1.Relations.CreateFormula ("formula_Bbox_8."& j, "", Bbox_dy ,"Bbox_dy." & j & "+Offset_Bbox_Min_Y." & j & "+Offset_Bbox_Max_Y." & j &"-2mm") Formula_8_Losche = "formula_Bbox_8."& j Dim Formula_9 As Formula Set Formula_9 = part1.Relations.CreateFormula ("formula_Bbox_9."& j, "", Bbox_dz ,"Bbox_dz." & j & "+Offset_Bbox_Min_Z." & j & "+Offset_Bbox_Max_Z." & j &"-2mm") Formula_9_Losche = "formula_Bbox_9."& j '---------------------------------------------------------------------------------------------------------------------------------- 'creation sweep '---------------------------------------------------------------------------------------------------------------------------------- set sweepref_1 = part1.createreferencefromobject(standard_body_sketch3 ) set guide1 = part1.createreferencefromobject(line_guide ) Dim sweep1 as HybridShapeSweepExplicit set sweep1 =hybridShapeFactory1.AddNewSweepExplicit(sweepref_1,guide1 ) hybridBody2.AppendHybridShape sweep1 part1.InWorkObject = sweep1 part1.update 'creation de la closed surface Set shapeFactory1 = part1.ShapeFactory Set hybridBodies1 = body1.HybridBodies Set hybridBody1 = hybridBodies1.Item("definition_points") Dim hybridShapes1 As HybridShapes Set hybridShapes1 = hybridBody1.HybridShapes Dim refer1 As Reference Set refer1 = part1.CreateReferenceFromObject(sweep1) Dim closeSurface1 As CloseSurface Set closeSurface1 = shapeFactory1.AddNewCloseSurface(refer1 ) closeSurface1.name = "BoundingBox" part1.Update selection.Clear selection.Add(hybridBody1) selection.VisProperties.SetShow catVisPropertyNoShowAttr selection.Clear selection.Add(Body1) selection.VisProperties.SetRealColor 255,255,128,0 selection.visProperties.SetRealOpacity 150,1 selection.Visproperties.SetRealWidth 4,1 part1.Update axissyst.Name=ref_name_systaxis else Msgbox "The active document must be a CATPart" end if 'Else ' User chose No. 'MyString = "No" 'End If '####################################################################################################################################### End Sub