updated code that is faster now in large assemblies, use as ilogic code.
Imports System.Windows.Forms
Imports Inventor
Imports System.Runtime.InteropServices
Imports Microsoft.Win32
Imports System
AddReference "System.Drawing.dll"
Class Teile_platzieren
Dim oAllOccsCollection As ObjectCollection
Dim oAllCOnstraintsCollection As ObjectCollection
Private ExitSub As Boolean = False
Private IsMateConst As Boolean = True
Dim oCurrentTopOcc As ComponentOccurrence
Sub Main()
SendKeys.SendWait("{ESC}")
AppActivate(ThisApplication.Caption)
'oVault = ThisApplication.ApplicationAddIns.ItemById("{48B682BC-42E6-4953-84C5-3D253B52E77B}")
'Auf Bg zugreifen
Dim oApp As Inventor.Application = ThisApplication
Dim oAsmDoc As AssemblyDocument = oApp.ActiveDocument
Dim oAsmCompDef As AssemblyComponentDefinition = oAsmDoc.ComponentDefinition
Dim oMasterAsmCompDef As AssemblyComponentDefinition = oAsmCompDef
'Kreis von Normteil/Fläche greifen
Dim oNormteilKreisProxy As EdgeProxy = ThisApplication.CommandManager.Pick(kPartEdgeCircularFilter, "Select Circle From Part")
If oNormteilKreisProxy Is Nothing Then Exit Sub
'If oNormteilKreisProxy.GeometryType <> CurveTypeEnum.kCircleCurve Or Then Exit Sub
Dim oFlaechenKreisProxy As EdgeProxy = ThisApplication.CommandManager.Pick(kPartEdgeCircularFilter, "Pick Circle where you are placing part")
If oFlaechenKreisProxy Is Nothing Then Exit Sub
'If oFlaechenKreisProxy.GeometryType <> CurveTypeEnum.kCircleCurve Then Exit Sub
oApp.AssemblyOptions.EnableAssemblyExpress = True
oApp.ScreenUpdating = True
Dim oTrans As Transaction = ThisApplication.TransactionManager.StartTransaction(oAsmDoc, "PlaceParts")
'oUnit = UnitsTypeEnum.kMillimeterLengthUnits
'Wenn unterbaugruppe in Bearbeitung ist, dann Fokus auf aktive Occurrence legen
If Not oAsmCompDef.ActiveOccurrence Is Nothing Then
oAsmCompDef = oAsmCompDef.ActiveOccurrence.Definition
oAsmDoc = oAsmCompDef.Document
End If
'Dim cmdMgr As CommandManager
'cmdMgr = ThisApplication.CommandManager
'Dim copyDef As ControlDefinition
'copyDef = cmdMgr.ControlDefinitions.Item("AppCopyCmd")
'Dim pasteDef As ControlDefinition
'pasteDef = cmdMgr.ControlDefinitions.Item("AppPasteCmd")
'sets master representation
If oAsmCompDef.RepresentationsManager.ActivePositionalRepresentation.Master=False Then oAsmCompDef.RepresentationsManager.PositionalRepresentations(1).Activate
'Form einblenden
CreateForm("Place Parts (Cancel With Esc)")
MyForm.ShowDialog()
If ExitSub = True Then Exit Sub
'Dim Msg As Integer = MsgBox("Flächennormale identisch?", vbYesNoCancel, "Einfügerichtung")
'If Msg = vbCancel Then Exit Sub
'Dim Offset As String = InputBox("Distanz", "Eingabe", 0)
Dim Offset As String
Dim Winkel As String
Try 'Wenn Fehleingaben gemacht wurden
Offset = TextBox(0).Text
Offset = StrToDbl(Offset) 'Konvertieren, damit mm u. co egal ist
Winkel = TextBox(1).Text
Winkel = StrToDbl(Winkel) 'Konvertieren, damit mm u. co egal ist
Catch
Exit Sub
End Try
'Occurrences bestimmen
Dim oNormteilOcc As ComponentOccurrence = oNormteilKreisProxy.ContainingOccurrence
Dim oFlächenOcc As ComponentOccurrence = oFlaechenKreisProxy.ContainingOccurrence
'Rausspringen wenn gleiche Occ angewählt wurde
If oNormteilOcc Is oLanglochOcc Then Exit Sub
'Suchen ob oNormteilOcc auf aktuellem Bauteillevel liegt
SearchForTopOccFinal(oNormteilOcc, oMasterAsmCompDef)
Dim oTopNormteilOcc As ComponentOccurrence = oCurrentTopOcc
oCurrentTopOcc = Nothing
Dim NormOccIstInBG As Boolean = False
If Not oTopNormteilOcc Is oNormteilOcc Then NormOccIstInBG = True
'Nach Itemnumber In Leafoccurrences schauen, wichtig für die Identifizierung der NewNormteilOcc nach dem Kopieren
Dim TopNormteilOccItem As Integer
Dim oOccProxy As ComponentOccurrenceProxy
If TypeOf oTopNormteilOcc.Definition.Document Is AssemblyDocument Then
For TopNormteilOccItem = 1 To oTopNormteilOcc.Definition.Occurrences.AllLeafOccurrences.Count
oTopNormteilOcc.CreateGeometryProxy(oTopNormteilOcc.Definition.Occurrences.AllLeafOccurrences.Item(TopNormteilOccItem), oOccProxy)
If oOccProxy Is oNormteilOcc Then Exit For
Next
End If
'Prüfen ob einzufügendes Teil ein Normteil ist, dann ist LockRot ist True außer es ist eine Außnahme definiert
Dim LockRot As Boolean = False
If TypeOf oNormteilOcc.Definition.Document Is PartDocument Then
If oNormteilOcc.Definition.IsContentMember = True _
Or InStr(UCase(oNormteilOcc.Definition.Document.PropertySets("Design Tracking Properties")("Description").value), "LINSEN-FLANSCH") Then
LockRot = True
If CheckBox(0).Checked = True Then LockRot = False
End If
End If
If CheckBox(1).Checked = False Then LockRot = True
'Senkrechte Ebenen zu NormteilKreis ermitteln
'RichungunsVektor
Dim oNormteilKreisNormal As UnitVector = oNormteilKreisProxy.Geometry.Normal
'Proxies
Dim oNormteilPerpendWorkPlaneProxy As WorkPlaneProxy
Dim oNormteilPerpendWorkAxisProxy As WorkAxisProxy
'WorkplaneProxies
Dim oWorkPlaneProxy1 As WorkPlaneProxy
Dim oWorkPlaneProxy2 As WorkPlaneProxy
Dim oWorkPlaneProxy3 As WorkPlaneProxy
oNormteilOcc.CreateGeometryProxy(oNormteilOcc.Definition.WorkPlanes(1), oWorkPlaneProxy1)
oNormteilOcc.CreateGeometryProxy(oNormteilOcc.Definition.WorkPlanes(2), oWorkPlaneProxy2)
oNormteilOcc.CreateGeometryProxy(oNormteilOcc.Definition.WorkPlanes(3), oWorkPlaneProxy3)
'WorkaxisProxies
Dim oWorkAxisProxy1 As WorkAxisProxy
Dim oWorkAxisProxy2 As WorkAxisProxy
Dim oWorkAxisProxy3 As WorkAxisProxy
oNormteilOcc.CreateGeometryProxy(oNormteilOcc.Definition.WorkAxes(1), oWorkAxisProxy1)
oNormteilOcc.CreateGeometryProxy(oNormteilOcc.Definition.WorkAxes(2), oWorkAxisProxy2)
oNormteilOcc.CreateGeometryProxy(oNormteilOcc.Definition.WorkAxes(3), oWorkAxisProxy3)
'über parallele Einheitsvektoren die Ebenen bestimmen
If oNormteilKreisNormal.IsParallelTo(oWorkPlaneProxy1.Plane.Normal, 0.00001) Then
oNormteilPerpendWorkPlaneProxy = oWorkPlaneProxy2
oNormteilPerpendWorkAxisProxy = oWorkAxisProxy1
End If
If oNormteilKreisNormal.IsParallelTo(oWorkPlaneProxy2.Plane.Normal, 0.00001) Then
oNormteilPerpendWorkPlaneProxy = oWorkPlaneProxy3
oNormteilPerpendWorkAxisProxy = oWorkAxisProxy2
End If
If oNormteilKreisNormal.IsParallelTo(oWorkPlaneProxy3.Plane.Normal, 0.00001) Then
oNormteilPerpendWorkPlaneProxy = oWorkPlaneProxy1
oNormteilPerpendWorkAxisProxy = oWorkAxisProxy3
End If
'Wenn Bohrung schräg liegt nochmals über die Ebenen versuchen
If oNormteilPerpendWorkPlaneProxy Is Nothing Then
If oNormteilKreisNormal.IsPerpendicularTo(oWorkPlaneProxy1.Plane.Normal, 0.00001) Then
oNormteilPerpendWorkPlaneProxy = oWorkPlaneProxy1
oNormteilPerpendWorkAxisProxy = oWorkAxisProxy2
End If
If oNormteilKreisNormal.IsPerpendicularTo(oWorkPlaneProxy2.Plane.Normal, 0.00001) Then
oNormteilPerpendWorkPlaneProxy = oWorkPlaneProxy2
oNormteilPerpendWorkAxisProxy = oWorkAxisProxy3
End If
If oNormteilKreisNormal.IsPerpendicularTo(oWorkPlaneProxy3.Plane.Normal, 0.00001) Then
oNormteilPerpendWorkPlaneProxy = oWorkPlaneProxy3
oNormteilPerpendWorkAxisProxy = oWorkAxisProxy1
End If
End If
If oNormteilPerpendWorkPlaneProxy Is Nothing Then
LockRot = True
End If
'Senkrecht Ebenen zu FlächenKreis ermitteln
Dim oFlächenPerpendWorkPlaneProxy As WorkPlaneProxy
Dim oFlächenKreisNormal As UnitVector = oFlaechenKreisProxy.Geometry.Normal
'Bohrungsdurchmesser von Kreis
Dim Bohrungsdurchmesser As Double = Round(oFlaechenKreisProxy.Geometry.Radius * 20, 3)
oFlächenOcc.CreateGeometryProxy(oFlächenOcc.Definition.WorkPlanes.Item(1), oWorkPlaneProxy1)
oFlächenOcc.CreateGeometryProxy(oFlächenOcc.Definition.WorkPlanes.Item(2), oWorkPlaneProxy2)
oFlächenOcc.CreateGeometryProxy(oFlächenOcc.Definition.WorkPlanes.Item(3), oWorkPlaneProxy3)
If oWorkPlaneProxy1.Plane.Normal.IsParallelTo(oFlächenKreisNormal, 0.00001) Then oFlächenPerpendWorkPlaneProxy = oWorkPlaneProxy2
If oWorkPlaneProxy2.Plane.Normal.IsParallelTo(oFlächenKreisNormal, 0.00001) And oFlächenPerpendWorkPlaneProxy Is Nothing Then oFlächenPerpendWorkPlaneProxy = oWorkPlaneProxy3
If oWorkPlaneProxy3.Plane.Normal.IsParallelTo(oFlächenKreisNormal, 0.00001) And oFlächenPerpendWorkPlaneProxy Is Nothing Then oFlächenPerpendWorkPlaneProxy = oWorkPlaneProxy1
'ErsatzAchsen:
Dim oFlächenPerpendWorkAxisProxy As WorkAxisProxy
Dim FlächenKreisNormalAngle As Double = 0
If oFlächenPerpendWorkPlaneProxy Is Nothing Then
oFlächenOcc.CreateGeometryProxy(oFlächenOcc.Definition.WorkAxes.Item(1), oWorkAxisProxy1)
oFlächenOcc.CreateGeometryProxy(oFlächenOcc.Definition.WorkAxes.Item(2), oWorkAxisProxy2)
oFlächenOcc.CreateGeometryProxy(oFlächenOcc.Definition.WorkAxes.Item(3), oWorkAxisProxy3)
If oWorkAxisProxy1.Line.Direction.IsPerpendicularTo(oFlächenKreisNormal, 0.00001) Then oFlächenPerpendWorkAxisProxy = oWorkAxisProxy1
If oWorkAxisProxy2.Line.Direction.IsPerpendicularTo(oFlächenKreisNormal, 0.00001) And oFlächenPerpendWorkAxisProxy Is Nothing Then oFlächenPerpendWorkAxisProxy = oWorkAxisProxy2
If oWorkAxisProxy3.Line.Direction.IsPerpendicularTo(oFlächenKreisNormal, 0.00001) And oFlächenPerpendWorkAxisProxy Is Nothing Then oFlächenPerpendWorkAxisProxy = oWorkAxisProxy3
If oFlächenPerpendWorkAxisProxy Is Nothing Then oFlächenPerpendWorkAxisProxy = oWorkAxisProxy1
End If
'Identische Kreise suchen und in Collection schreiben
Dim oCircleCollection As ObjectCollection = oApp.TransientObjects.CreateObjectCollection
oCircleCollection.Add(oFlaechenKreisProxy)
Dim oFlaechenFacePlane As Plane = oApp.TransientGeometry.CreatePlane(oFlaechenKreisProxy.Geometry.Center, oFlächenKreisNormal.AsVector)
Dim oCircCenterPoint As Point
Dim IsAlreadyCenter As Boolean = False
For Each oBodyproxy As SurfaceBodyProxy In oFlächenOcc.SurfaceBodies
For Each oCircleProxy As EdgeProxy In oBodyproxy.Edges
If oCircleProxy.GeometryType = CurveTypeEnum.kCircleCurve _
Or oFlaechenKreisProxy.GeometryType = CurveTypeEnum.kCircularArcCurve _
And oCircleProxy.GeometryType = CurveTypeEnum.kCircularArcCurve Then
If Round(oCircleProxy.Geometry.Radius * 20, 3) = Bohrungsdurchmesser _
And Round(oFlaechenFacePlane.DistanceTo(oCircleProxy.Geometry.Center), 5) = 0 _
And Round(oFlaechenFacePlane.DistanceTo(oCircleProxy.PointOnEdge), 5) = 0 Then
For Each oCircleProxy2 As EdgeProxy In oCircleCollection
oCircCenterPoint = oCircleProxy2.Geometry.Center
If oCircCenterPoint.IsEqualTo(oCircleProxy.Geometry.Center, 0.00001) Then
IsAlreadyCenter = True
Exit For
End If
Next
If IsAlreadyCenter = False Then
oCircleCollection.Add(oCircleProxy)
Continue For
End If
IsAlreadyCenter = False
End If
End If
Next
Next
'Weitere Kreise hinzufügen fall Kreis von Schweißteil ist und nicht auf gleicher Fläche
SearchForTopOccFinal(oFlächenOcc, oAsmCompDef) 'Wenn oOcc in Unterbaugruppe ist, dann Rekursiv hochgehen bis Baugruppe gefunden ist
Dim oTopFlächenOcc As ComponentOccurrence = oCurrentTopOcc
If TypeOf oTopFlächenOcc.Definition.Document Is AssemblyDocument Then
Dim oTopFlächenDoc As AssemblyDocument = oTopFlächenOcc.Definition.Document
If oTopFlächenDoc.SubType = "{28EC8354-9024-440F-A8A2-0E0E55D635B0}" Then
For Each oOcc As ComponentOccurrence In oTopFlächenOcc.SubOccurrences
For Each oBodyproxy As SurfaceBodyProxy In oOcc.SurfaceBodies
For Each oCircleProxy As EdgeProxy In oBodyproxy.Edges
If oCircleProxy.GeometryType = CurveTypeEnum.kCircleCurve _
Or oFlaechenKreisProxy.GeometryType = CurveTypeEnum.kCircularArcCurve _
And oCircleProxy.GeometryType = CurveTypeEnum.kCircularArcCurve Then
If Round(oCircleProxy.Geometry.Radius * 20, 3) = Bohrungsdurchmesser _
And Round(oFlaechenFacePlane.DistanceTo(oCircleProxy.Geometry.Center), 5) = 0 _
And Round(oFlaechenFacePlane.DistanceTo(oCircleProxy.PointOnEdge), 5) = 0 Then
For Each oCircleProxy2 As EdgeProxy In oCircleCollection
oCircCenterPoint = oCircleProxy2.Geometry.Center
If oCircCenterPoint.IsEqualTo(oCircleProxy.Geometry.Center, 0.00001) Then
IsAlreadyCenter = True
Exit For
End If
Next
If IsAlreadyCenter = False Then
oCircleCollection.Add(oCircleProxy)
Continue For
End If
IsAlreadyCenter = False
End If
End If
Next
Next
Next
End If
End If
'Bereits abhängige Kreise aus Collection entfernen
Dim oConstraint As Object
If oCircleCollection.Count>1 Then
For Each oConstraint In oTopFlächenOcc.Constraints
If oConstraint.Suppressed = False And oConstraint.HealthStatus = HealthStatusEnum.kUpToDateHealth Then
If oConstraint.Type <> ObjectTypeEnum.kInsertConstraintObject Then Continue For
Try
If oConstraint.EntityOne Is Nothing Or oConstraint.EntityTwo Is Nothing Then Continue For 'War nötig weil in Baugruppe 82720.020.51.00.iam fehler kommt. Bei Einfügen:18 Fehlt die Entity, warum unbekannt!
For Each oCircleProxy As EdgeProxy In oCircleCollection
oCircCenterPoint = oCircleProxy.Geometry.Center
If Round(oCircCenterPoint.DistanceTo(oConstraint.EntityOne.Geometry.Center), 5) = 0 _
Or Round(oCircCenterPoint.DistanceTo(oConstraint.EntityTwo.Geometry.Center), 5) = 0 Then
If Round(oCircCenterPoint.DistanceTo(oFlaechenKreisProxy.Geometry.Center), 5) = 0 Then Continue For 'Außnahme dass immer auf den ersten Kreis eine Abhängigkeit platziert wird
oCircleCollection.RemoveByObject(oCircleProxy)
End If
Next
Catch
End Try
End If
Next
End If
'Alle Zusammenhägenden Occs in Collection
oAllCOnstraintsCollection = oApp.TransientObjects.CreateObjectCollection
oAllOccsCollection = oApp.TransientObjects.CreateObjectCollection
oAllOccsCollection.Add(oTopNormteilOcc)
SearchAllOccsInOcc(oTopNormteilOcc)
'Bildschirmaktualisierung aus 'Bringt starke Zeitersparnis
oApp.AssemblyOptions.DeferUpdate = True
'oApp.ScreenUpdating = False
'oVault.Deactivate
'Auf allen Kreisen ein Teil/Teileverbund platzieren
For Each oCircleOnFaceProxy As EdgeProxy In oCircleCollection
'Occurrence count originally
Dim occCount As Integer = oAsmCompDef.Occurrences.Count
Dim oNewNormteilOcc As ComponentOccurrence
'New originOcc ermitteln
If Not oCircleOnFaceProxy Is oCircleCollection(1) Then
oApp.ActiveDocument.SelectSet.SelectMultiple(oAllOccsCollection)
'AppActivate(ThisApplication.Caption)
oApp.CommandManager.ControlDefinitions.Item("AppCopyCmd").Execute2(True)
'Call copyDef.Execute
'Call WinAPISetFocus(ThisApplication.ActiveView.hwnd)
oApp.CommandManager.ControlDefinitions.Item("AppPasteCmd").Execute2(True)
'Call pasteDef.Execute
'Clipboard.Clear
'GC.Collect(generation, GCCollectionMode.Forced)
'iLogic.FreeILogicMemory
'iLogic.ClearCodeClipboard
For i = occCount + 1 To oAsmCompDef.Occurrences.Count
If oAsmCompDef.Occurrences(i).Definition.Document Is oTopNormteilOcc.Definition.Document Then
oNewNormteilOcc = oAsmCompDef.Occurrences(i)
Exit For
End If
Next
If NormOccIstInBG = True Then
Dim oNewNormteilOccProxy As ComponentOccurrenceProxy
oNewNormteilOcc.CreateGeometryProxy(oNewNormteilOcc.Definition.Occurrences.AllLeafOccurrences.Item(TopNormteilOccItem), oNewNormteilOccProxy)
oNewNormteilOcc = oNewNormteilOccProxy
End If
Else
oNewNormteilOcc = oNormteilOcc
End If
'Neue Proxies definieren
Dim oNewNormteilPerpendWorkPlaneProxy1 As WorkPlaneProxy
Dim oNewNormteilPerpendWorkAxisProxy1 As WorkAxisProxy
If Not oNormteilPerpendWorkPlaneProxy Is Nothing 'Wenn Bohrung im Raum liegt
oNewNormteilOcc.CreateGeometryProxy(oNormteilPerpendWorkPlaneProxy.NativeObject, oNewNormteilPerpendWorkPlaneProxy1)
oNewNormteilOcc.CreateGeometryProxy(oNormteilPerpendWorkAxisProxy.NativeObject, oNewNormteilPerpendWorkAxisProxy1)
End If
Dim oNewNormteilKreisProxy As EdgeProxy
oNewNormteilOcc.CreateGeometryProxy(oNormteilKreisProxy.NativeObject, oNewNormteilKreisProxy)
'Insert Abhaengigkeit vergeben
Dim Insert_Param_Expression As String
If IsMateConst = True Then
'If Insert_Param_Expression = "" Then oConstraint = oAsmCompDef.Constraints.AddInsertConstraint2(oNewNormteilKreisProxy, oCircleOnFaceProxy, True, Offset / 10,LockRot)
If Insert_Param_Expression = "" Then oConstraint = oAsmCompDef.Constraints.AddInsertConstraint2(oNewNormteilKreisProxy, oCircleOnFaceProxy, True, Offset,LockRot)
If Insert_Param_Expression <> "" Then oConstraint = oAsmCompDef.Constraints.AddInsertConstraint2(oNewNormteilKreisProxy, oCircleOnFaceProxy, True, Insert_Param_Expression,LockRot)
Else
'If Insert_Param_Expression = "" Then oConstraint = oAsmCompDef.Constraints.AddInsertConstraint2(oNewNormteilKreisProxy, oCircleOnFaceProxy, False, Offset / 10,LockRot)
If Insert_Param_Expression = "" Then oConstraint = oAsmCompDef.Constraints.AddInsertConstraint2(oNewNormteilKreisProxy, oCircleOnFaceProxy, False, Offset,LockRot)
If Insert_Param_Expression <> "" Then oConstraint = oAsmCompDef.Constraints.AddInsertConstraint2(oNewNormteilKreisProxy, oCircleOnFaceProxy, False, Insert_Param_Expression,LockRot)
End If
Dim X As Integer
Dim Z As Integer
If Insert_Param_Expression = "" Then
Insert_Param_Expression = oConstraint.Distance.Name
For X = 1 To 10000
Try
oConstraint.Name = "Constraint:" & X & "-0-Master"
Exit For
Catch
End Try
Next
Else
For Z = 1 To 10000
Try
oConstraint.Name = "Constraint:" & X & "-" & Z
Exit For
Catch
End Try
Next
End If
If LockRot = True Then Continue For
'Angle Abhaengigkeit vergeben
Dim oAngleConstraint As AngleConstraint
Dim Angle_Param_Expression As String
If oFlächenPerpendWorkPlaneProxy Is Nothing Then
If Angle_Param_Expression = "" Then oAngleConstraint = oAsmCompDef.Constraints.AddAngleConstraint(oNewNormteilPerpendWorkPlaneProxy1, oFlächenPerpendWorkAxisProxy, Winkel, kReferenceVectorSolution, oNewNormteilPerpendWorkAxisProxy1)
If Angle_Param_Expression <> "" Then oAsmCompDef.Constraints.AddAngleConstraint(oNewNormteilPerpendWorkPlaneProxy1, oFlächenPerpendWorkAxisProxy, Angle_Param_Expression, kReferenceVectorSolution, oNewNormteilPerpendWorkAxisProxy1)
Else
If Angle_Param_Expression = "" Then oAngleConstraint = oAsmCompDef.Constraints.AddAngleConstraint(oNewNormteilPerpendWorkPlaneProxy1, oFlächenPerpendWorkPlaneProxy, Winkel, kReferenceVectorSolution, oNewNormteilPerpendWorkAxisProxy1)
If Angle_Param_Expression <> "" Then oAngleConstraint = oAsmCompDef.Constraints.AddAngleConstraint(oNewNormteilPerpendWorkPlaneProxy1, oFlächenPerpendWorkPlaneProxy, Angle_Param_Expression, kReferenceVectorSolution, oNewNormteilPerpendWorkAxisProxy1)
End If
If Angle_Param_Expression = "" Then
Angle_Param_Expression = oAngleConstraint.Angle.Name
For X = 1 To 10000
Try
oAngleConstraint.Name = "Angle:" & X & "-0-Master"
Exit For
Catch
End Try
Next
Else
For Z = 1 To 10000
Try
oAngleConstraint.Name = "Angle:" & X & "-" & Z
Exit For
Catch
End Try
Next
End If
Next
'oApp.UserInterfaceManager.UserInteractionDisabled = False
'Bildschirmaktualisierung ein + update
'oVault.Activate
'oVault.Select
oApp.AssemblyOptions.DeferUpdate = False
oApp.ScreenUpdating = True
'oApp.CommandManager.ControlDefinitions.Item("AppRefineAppearanceCmd").Execute2(True)
'oApp.CommandManager.ControlDefinitions.Item("iLogic.FreeILogicMemory").Execute2(True)
'oApp.CommandManager.ControlDefinitions.Item("iLogic.ClearCodeClipboard").Execute2(True)
'oApp.CommandManager.ControlDefinitions.Item("AppRefineAppearanceCmd").Execute
oMasterAsmCompDef.Document.Update
'oUnit = UnitsTypeEnum.kInchLengthUnits
oTrans.End
'
oApp.AssemblyOptions.DeferUpdate = False
oMasterAsmCompDef.Document.Update
End Sub
Function SearchAllOccsInOcc(oOcc As ComponentOccurrence)
For Each oConstraint As AssemblyConstraint In oOcc.Constraints
Dim ConstraintVorhanden As Boolean = False
For Each oConstInCol As Object In oAllCOnstraintsCollection
If Not oConstraint Is oConstInCol Then Continue For
ConstraintVorhanden = True
Exit For
Next
oAllCOnstraintsCollection.Add(oConstraint)
oAllOccsCollection.Add(oConstraint.AffectedOccurrenceOne)
If ConstraintVorhanden = False Then SearchAllOccsInOcc(oConstraint.AffectedOccurrenceOne)
On Error Resume Next
oAllOccsCollection.Add(oConstraint.AffectedOccurrenceTwo)
If ConstraintVorhanden = False Then SearchAllOccsInOcc(oConstraint.AffectedOccurrenceTwo)
Next
For Each oJoint As AssemblyJoint In oOcc.Joints
Dim JointVorhanden As Boolean = False
For Each oJointInCol As Object In oAllCOnstraintsCollection
If Not oJoint Is oJointInCol Then Continue For
JointVorhanden = True
Exit For
Next
oAllCOnstraintsCollection.Add(oJoint)
oAllOccsCollection.Add(oJoint.AffectedOccurrenceOne)
If JointVorhanden = False Then SearchAllOccsInOcc(oJoint.AffectedOccurrenceOne)
oAllOccsCollection.Add(oJoint.AffectedOccurrenceTwo)
If JointVorhanden = False Then SearchAllOccsInOcc(oJoint.AffectedOccurrenceTwo)
Next
End Function
Function SearchForTopOccFinal(oOcc As ComponentOccurrence, oMasterAsmCompDef As AssemblyComponentDefinition) As ComponentOccurrence
If oCurrentTopOcc Is Nothing Then oCurrentTopOcc = oOcc
If Not oOcc.ParentOccurrence Is oMasterAsmCompDef.ActiveOccurrence Then
oCurrentTopOcc = oOcc.ParentOccurrence
SearchForTopOccFinal(oOcc.ParentOccurrence, oMasterAsmCompDef)
Return oCurrentTopOcc
End If
End Function
Function StrToDbl(str As String) As Double
'For i = 1 To Len(str)
'Dim CurrentCharacter As String = Mid(str, i, 1)
'If i=1 And CurrentCharacter="-" Then Continue For
'If IsNumeric(CurrentCharacter) = False _
'And CurrentCharacter <> "," _
'And CurrentCharacter <> "." Then
'str = Replace(str, CurrentCharacter, "")
'End If
'If CurrentCharacter = "." Then str = Replace(str, CurrentCharacter, ",")
'Next
StrToDbl = str
End Function
Private WithEvents MyForm As System.Windows.Forms.Form
Private Button0 As System.Windows.Forms.Button
Private Button1 As System.Windows.Forms.Button
Private ComboBox(0) As System.Windows.Forms.ComboBox
Private Label(0) As System.Windows.Forms.Label
Private PicBox(0) As System.Windows.Forms.PictureBox
Private TextBox(0) As System.Windows.Forms.TextBox
Private CheckBox(0) As System.Windows.Forms.CheckBox
Private RadioButton(0) As System.Windows.Forms.RadioButton
Private GroupBox As System.Windows.Forms.GroupBox
Private Label0 As System.Windows.Forms.Label
Private Label1 As System.Windows.Forms.Label
Private RadioButton0 As System.Windows.Forms.RadioButton
Private RadioButton1 As System.Windows.Forms.RadioButton
Private Sub CreateForm(Optional Name As String = vbNullString)
MyForm = New System.Windows.Forms.Form
MyForm.Text = Name
MyForm.AutoScaleMode = AutoScaleMode.Dpi
MyForm.Size = New Drawing.Size(375*2, 150*2) 'Width, Heigth
MyForm.MinimumSize = MyForm.Size
MyForm.MaximumSize = MyForm.Size
MyForm.Font = New Drawing.Font(MyForm.Font.FontFamily, 10)
MyForm.MaximizeBox = False
MyForm.MinimizeBox = False
MyForm.ShowIcon = False
MyForm.SizeGripStyle = SizeGripStyle.Hide
MyForm.StartPosition = FormStartPosition.CenterScreen
MyForm.KeyPreview = True
AddLabel(5*2, (128+20-140)*2, "Offset")
AddTextBox(55*2, (125+20-140)*2, "0", 100*2)
AddLabel(155*2, (128+20-140)*2, "in")
AddLabel(5*2, (153+20-140)*2, "Deg")
AddTextBox(55*2, (150+20-140)*2, "0", 100*2)
AddLabel(155*2, (153+20-140)*2, "°")
AddLabel(5*2, (195+20-140)*2, "Create angle constraint On standard parts?")
AddLabel(5*2, (220+20-140)*2, "Create Angle constraint On non-standard parts?")
AddCheckBox(335*2, 75*2, False)
AddCheckBox(335*2, 100*2, False)
AddMateButton()
AddFlushButton()
TextBox(0).TabIndex = 0
TextBox(1).TabIndex = 1
Button0.TabIndex = 2
Button1.TabIndex = 3
MyForm.AutoScaleDimensions = New System.Drawing.SizeF(184F, 184F)
'MyForm.Font = New System.Drawing.Font("Tahoma", 10F)
MyForm.AcceptButton = Button0
MyForm.AutoScaleMode = AutoScaleMode.Dpi
MyForm.PerformAutoScale()
End Sub
'Private Sub MyForm_FormClosing(ByVal sender As Object, ByVal E As System.Windows.Forms.FormClosedEventArgs) Handles MyForm.FormClosed
' If sender.Name = "CloseButton" Then
' MessageBox.Show(sender.Name)
' End If
'End Sub
Private Sub MyForm_KeyDown(ByVal sender As System.Object, ByVal E As System.Windows.Forms.KeyEventArgs) Handles MyForm.KeyDown
If E.KeyCode = Keys.Escape Then
MyForm.Close
ExitSub = True
'Exit sub
End If
End Sub
'Private Sub Button_Click(ByVal sender As System.Object, ByVal E As System.Windows.Forms.FormClosingEventArgs) Handles Button.FormClosing
' MessageBox.Show(sender.ToString, "Title")
'
' MyForm.Close
' ExitSub = True
'End Sub
Private Function AddLabel(PosX As Integer, PosY As Integer, Optional Caption As String = vbNullString, Optional Width As Integer = 100) As System.Windows.Forms.Label
Dim LC As Integer = Label.Length - 1
If Not Label(LC) Is Nothing Then
LC = LC + 1
ReDim Preserve Label(LC)
End If
Label(LC) = New System.Windows.Forms.Label
Label(LC).Name = "L" & LC
Label(LC).Location = New Drawing.Point(PosX, PosY)
Label(LC).Text = Caption
Label(LC).AutoSize = True
Label(LC).Width = Width
MyForm.Controls.Add(Label(LC))
Return Label(LC)
End Function
Private Function AddCheckBox(PosX As Integer, PosY As Integer, Checked As Boolean,Optional Caption As String = vbNullString, Optional Width As Integer = 100) As System.Windows.Forms.CheckBox
Dim LC As Integer = CheckBox.Length - 1
If Not CheckBox(LC) Is Nothing Then
LC = LC + 1
ReDim Preserve CheckBox(LC)
End If
CheckBox(LC) = New System.Windows.Forms.CheckBox
CheckBox(LC).Location = New Drawing.Point(PosX, PosY)
CheckBox(LC).Name = "CheckBox" & LC
CheckBox(LC).Text = Caption
CheckBox(LC).Width = Width
CheckBox(LC).Checked = Checked
CheckBox(LC).TabStop = False
MyForm.Controls.Add(CheckBox(LC))
Return CheckBox(LC)
End Function
Private Function AddTextBox(PosX As Integer, PosY As Integer, Optional Caption As String = vbNullString, Optional Width As Integer = 100) As System.Windows.Forms.TextBox
Dim LC As Integer = TextBox.Length - 1
If Not TextBox(LC) Is Nothing Then
LC = LC + 1
ReDim Preserve TextBox(LC)
End If
TextBox(LC) = New System.Windows.Forms.TextBox
TextBox(LC).Location = New Drawing.Point(PosX, PosY)
TextBox(LC).Name = "TextBox" & LC
TextBox(LC).Text = Caption
TextBox(LC).Width = Width
MyForm.Controls.Add(TextBox(LC))
Return TextBox(LC)
End Function
Private Function AddMateButton() As System.Windows.Forms.Button
Button0 = New System.Windows.Forms.Button
Button0.Name = "Button0"
Button0.Image = Drawing.Image.FromFile("I:\inventor\iLogic rules\Mate.png")
Button0.Location = New Drawing.Point(190*2, 5*2)
Button0.Text = ""
Button0.Width = Button0.Image.Width*2
Button0.Height = Button0.Image.Height*2
MyForm.Controls.Add(Button0)
AddHandler Button0.Click, AddressOf OnMateClick
Return Button0
End Function
Private Function AddFlushButton() As System.Windows.Forms.Button
Button1 = New System.Windows.Forms.Button
Button1.Name = "Button1"
Button1.Image = Drawing.Image.FromFile("I:\inventor\iLogic rules\Flush.png")
Button1.Location = New Drawing.Point(275*2, 5*2)
Button1.Text = ""
Button1.Width = Button1.Image.Width*2
Button1.Height = Button1.Image.Height*2
MyForm.Controls.Add(Button1)
AddHandler Button1.Click, AddressOf OnFlushClick
Return Button1
End Function
Private Sub OnMateClick()
MyForm.Close
IsMateConst = True
End Sub
Private Sub OnFlushClick()
MyForm.Close
IsMateConst = False
End Sub
End Class
