I check every mate or insert constraint. If created by a threaded feature or a clearance hole feature, then I check if both holes refer to the same screw size. if not, I generate a txt report file:
Sub ConstraintsCheck()
Dim oDoc As Document
Dim oAssemblyDoc As AssemblyDocument
Dim oConstraint As AssemblyConstraint
Dim bob As Integer
Dim oFeature As PartFeature
Dim oHoleFeature As HoleFeature
Dim oFace As Face
Dim EntityOneFastener As String
Dim EntityTwoFastener As String
Dim tapInfo As HoleTapInfo
Dim clearanceInfo As HoleClearanceInfo
Dim EntitySelections As New Collection
Dim referencedDoc As Document
Dim i As Integer
Dim fso As Object
Dim objShell As Object
Dim myFile As Object
On Error GoTo ConstraintsCheckErr
Set oDoc = ThisApplication.ActiveEditDocument
'Set EntitySelections = ThisApplication.TransientObjects.CreateObjectCollection
If TypeOf oDoc Is AssemblyDocument Then
ConstraintsScan oDoc, EntitySelections
For Each referencedDoc In oDoc.AllReferencedDocuments
If TypeOf referencedDoc Is AssemblyDocument Then
Set oAssemblyDoc = referencedDoc
ConstraintsScan oAssemblyDoc, EntitySelections
End If
Next referencedDoc
oDoc.SelectSet.Clear
'oDoc.SelectSet.SelectMultiple EntitySelections
Else
MsgBox "le document actif n'est pas un assemblage", vbMsgBoxSetForeground, "ConstraintsCheck"
Exit Sub
End If
If MsgBox(EntitySelections.count & " irrégularité(s) trouvée(s)." & vbCrLf & "Créer un rapport ?", vbMsgBoxSetForeground + vbYesNo, "ConstraintsCheck") = vbYes Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Wscript.Shell")
'.OpenTextFile(strFile [,IOMode (8=append, 1=Read, 2=Write) [,Create (True/False) [,Format (0=Ascii, -1=Unicode, -2=default)]]])
Set myFile = fso.openTextFile(objShell.SpecialFolders("Desktop") & "\ConstraintCheckReport.txt", 2, True)
For i = 1 To EntitySelections.count
myFile.writeline EntitySelections(i)
Next i
objShell.Run "notepad.exe " & objShell.SpecialFolders("Desktop") & "\ConstraintCheckReport.txt"
End If
ConstraintsCheckErr:
If Err Then
MsgBox "Unexpected error during ConstraintsCheck: " & Err.description, vbMsgBoxSetForeground, "ConstraintsCheck"
Err.Clear
End If
End Sub
Sub ConstraintsScan(oAssemblyDoc As AssemblyDocument, ByRef EntitySelections As Collection)
Dim oDoc As Document
Dim oConstraint As AssemblyConstraint
Dim bob As Integer
Dim oFeature As PartFeature
Dim oHoleFeature As HoleFeature
Dim oFace As Face
Dim EntityOneFastener As String
Dim EntityTwoFastener As String
Dim tapInfo As HoleTapInfo
Dim clearanceInfo As HoleClearanceInfo
Dim referencedDoc As Document
On Error GoTo ConstraintsScanErr
'Loop through each constraint. Look only at constraint of mate type or insert type. Constraints has to be healthy
For Each oConstraint In oAssemblyDoc.ComponentDefinition.Constraints
If (TypeOf oConstraint Is InsertConstraint Or TypeOf oConstraint Is MateConstraint) And (oConstraint.HealthStatus = kUpToDateHealth Or oConstraint.HealthStatus = kNewlyAddedHealth) Then
'Validate two occurences are being constrained. Prevent evaluation of component constrained to assembly plane
If Not oConstraint.AffectedOccurrenceOne Is Nothing And Not oConstraint.AffectedOccurrenceTwo Is Nothing Then
'Check if occurence are inseparable (i.e.: weldement or part to be built) and that they are not missing (suppressed or unresolved)
If Not oConstraint.AffectedOccurrenceOne.ReferencedDocumentDescriptor.ReferenceMissing And Not oConstraint.AffectedOccurrenceTwo.ReferencedDocumentDescriptor.ReferenceMissing Then
If oConstraint.AffectedOccurrenceOne.BOMStructure = kInseparableBOMStructure And oConstraint.AffectedOccurrenceTwo.BOMStructure = kInseparableBOMStructure Then
If (TypeOf oConstraint.AffectedOccurrenceOne.Definition Is PartComponentDefinition Or TypeOf oConstraint.AffectedOccurrenceOne.Definition Is WeldmentComponentDefinition) _
And (TypeOf oConstraint.AffectedOccurrenceTwo.Definition Is PartComponentDefinition Or TypeOf oConstraint.AffectedOccurrenceTwo.Definition Is WeldmentComponentDefinition) Then
' search only if native object is either a edge or a face
If Not oConstraint.EntityOne.NativeObject Is Nothing Then
If TypeOf oConstraint.EntityOne.NativeObject Is Edge Then
If oConstraint.EntityOne.NativeObject.CurveType = kCircleCurve Then
For Each oFace In oConstraint.EntityOne.NativeObject.Faces
If oFace.SurfaceType = kConeSurface Or oFace.SurfaceType = kCylinderSurface Then
EntityOneFastener = reuseLib.FastenerFromFace(oFace)
Exit For
End If
Next oFace
End If
ElseIf TypeOf oConstraint.EntityOne.NativeObject Is Face Then
Set oFace = oConstraint.EntityOne.NativeObject
If TypeOf oFace.CreatedByFeature Is HoleFeature Then
EntityOneFastener = reuseLib.FastenerFromFace(oFace)
End If
End If
End If
If Not oConstraint.EntityTwo.NativeObject Is Nothing Then
If TypeOf oConstraint.EntityTwo.NativeObject Is Edge Then
If oConstraint.EntityTwo.NativeObject.CurveType = kCircleCurve Then
For Each oFace In oConstraint.EntityTwo.NativeObject.Faces
If oFace.SurfaceType = kConeSurface Or oFace.SurfaceType = kCylinderSurface Then
EntityTwoFastener = reuseLib.FastenerFromFace(oFace)
Exit For
End If
Next oFace
End If
ElseIf TypeOf oConstraint.EntityTwo.NativeObject Is Face Then
Set oFace = oConstraint.EntityTwo.NativeObject
If TypeOf oFace.CreatedByFeature Is HoleFeature Then
EntityTwoFastener = reuseLib.FastenerFromFace(oFace)
End If
End If
End If
If EntityOneFastener <> "" And EntityTwoFastener <> "" And StrComp(EntityOneFastener, EntityTwoFastener, vbTextCompare) <> 0 Then
EntitySelections.add oAssemblyDoc.DisplayName & vbTab & oConstraint.name & " (" & oConstraint.AffectedOccurrenceOne.name & " - " & oConstraint.AffectedOccurrenceTwo.name & ")" & vbTab & EntityOneFastener & ", " & EntityTwoFastener
'EntitySelections.add oConstraint.AffectedOccurrenceOne
'EntitySelections.add oConstraint.AffectedOccurrenceTwo
End If
'reset string to nothing to prevent false positive
EntityOneFastener = ""
EntityTwoFastener = ""
End If
End If
End If
End If
End If
Next oConstraint
'oDoc.SelectSet.Clear
'oDoc.SelectSet.SelectMultiple EntitySelections
ConstraintsScanErr:
If Err Then
MsgBox "Unexpected error during ConstraintsScan: " & Err.description & vbCrLf & "La vérification de l'assemblage: " & oAssemblyDoc.DisplayName & " a échouée sur la contrainte: " & oConstraint.name & " Essayer de faire un Rebuild All." & vbCrLf & "Le rapport pourrait être incomplet.", vbMsgBoxSetForeground, "ConstraintsScan"
Err.Clear
End If
End Sub
Function FastenerFromFace(oFace As Face) As String
Dim oFeature As PartFeature
Dim oHoleFeature As HoleFeature
Dim tapInfo As HoleTapInfo
Dim clearanceInfo As HoleClearanceInfo
Dim regex As Object
Dim Matches As Object
Dim bob As Integer
Set regex = CreateObject("vbscript.RegExp")
regex.Pattern = "(\d*\.?\d+)" 'Search groups of digits
'( begin capture group
'\d* any digit zero or more times
'\.? a period zero or one times (i.e. it is optional)
'\d+ any digit one or more times
') end capture group
regex.Global = True
On Error GoTo FasternerFromFaceErr
If oFace.SurfaceType = kCylinderSurface Or oFace.SurfaceType = kConeSurface Then
'For Each oFeature In oFace.[_CreatedByFeatures]
If TypeOf oFace.CreatedByFeature Is HoleFeature Then
Set oHoleFeature = oFace.CreatedByFeature
If oHoleFeature.Tapped Then
Set tapInfo = oHoleFeature.tapInfo
If Not tapInfo.Metric Then
regex.Pattern = "([^#-]+)"
'( Begin capture group
'[^ Begin Exclude group
'#- Exclude "#" and "-"
'] End of exclude group
'+ anything else one or more times
') end capture group
Set Matches = regex.Execute(tapInfo.ThreadDesignation)
If Matches.count >= 1 Then
FastenerFromFace = Matches(0)
Else
MsgBox "TapInfo.NominalSize de la pièce: " & oHoleFeature.Parent.Document.DisplayName & " renvoi un résultat imprévu: " & tapInfo.ThreadDesignation, vbMsgBoxSetForeground, "FastenerFromFace"
Exit Function
End If
Else
Set Matches = regex.Execute(tapInfo.NominalSize)
If Matches.count = 1 Then
FastenerFromFace = Matches(0).Value
Else
MsgBox "TapInfo.NominalSize de la pièce: " & oHoleFeature.Parent.Document.DisplayName & " renvoi un résultat imprévu: " & tapInfo.NominalSize, vbMsgBoxSetForeground, "FastenerFromFace"
Exit Function
End If
End If
ElseIf oHoleFeature.IsClearanceHole Then
Set clearanceInfo = oHoleFeature.clearanceInfo
If InStr(1, clearanceInfo.FastenerStandard, "imperial", vbTextCompare) > 0 Or InStr(1, clearanceInfo.FastenerStandard, "unified", vbTextCompare) > 0 Then
regex.Pattern = "([^#]+)"
End If
Set Matches = regex.Execute(clearanceInfo.FastenerSize)
If Matches.count = 1 Then
FastenerFromFace = Matches(0).Value
Else
MsgBox "clearanceInfo.FastenerSize de la pièce: " & oHoleFeature.Parent.Document.DisplayName & " renvoi un résultat imprévu: " & clearanceInfo.FastenerSize, vbMsgBoxSetForeground, "FastenerFromFace"
Exit Function
End If
End If
'Exit For
End If
'Next oFeature
End If
FasternerFromFaceErr:
If Err Then
MsgBox "Unexpected error during FasternerFromFaceErr: " & Err.description, vbMsgBoxSetForeground, "FasternerFromFaceErr"
End If
End Function
Have fun
