'模块中代码
Sub fu6()
If ThisApplication.Documents.Count = 0 Then
Exit Sub
End If
If ThisApplication.ActiveDocument.DocumentType = 12291 Then
Dim fos1 As SelectSet
Set fos1 = ThisApplication.ActiveDocument.SelectSet
If fos1.Count <> 2 Then
MsgBox "请选择两个零部件再运行"
Exit Sub
ElseIf fos1.Item(1).Type = 67113776 And fos1.Item(2).Type = 67113776 Then
UserForm1.Show
Else
MsgBox "不符合条件的选择，需要重新选择"
End If
End If
End Sub
'窗体中的代码
Dim fas1 As AssemblyComponentDefinition
Dim fos1 As SelectSet
Dim fot1 As Transaction
Dim fob1 As Object
Dim fob2 As Object
Dim fpl1 As WorkPlane
Dim fpl2 As WorkPlane
Dim foa1 As WorkPlaneProxy
Dim foa2 As WorkPlaneProxy
Private Sub CommandButton3_Click()
Set fas1 = ThisApplication.ActiveDocument.ComponentDefinition
Set fos1 = ThisApplication.ActiveDocument.SelectSet
Set fot1 = ThisApplication.TransactionManager.StartTransaction(ThisApplication.ActiveDocument, "qConstraints")
Set fob1 = fos1.Item(1)
Set fob2 = fos1.Item(2)
If CheckBox1.Value = True Then
Set fpl1 = fob1.Definition.WorkPlanes.Item(1)
Set fpl2 = fob2.Definition.WorkPlanes.Item(1)
Call fob1.CreateGeometryProxy(fpl1, foa1)
Call fob2.CreateGeometryProxy(fpl2, foa2)
Call fas1.Constraints.AddFlushConstraint(foa1, foa2, 0)
End If
If CheckBox2.Value = True Then
Set fpl1 = fob1.Definition.WorkPlanes.Item(2)
Set fpl2 = fob2.Definition.WorkPlanes.Item(2)
Call fob1.CreateGeometryProxy(fpl1, foa1)
Call fob2.CreateGeometryProxy(fpl2, foa2)
Call fas1.Constraints.AddFlushConstraint(foa1, foa2, 0)
End If
If CheckBox3.Value = True Then
Set fpl1 = fob1.Definition.WorkPlanes.Item(3)
Set fpl2 = fob2.Definition.WorkPlanes.Item(3)
Call fob1.CreateGeometryProxy(fpl1, foa1)
Call fob2.CreateGeometryProxy(fpl2, foa2)
Call fas1.Constraints.AddFlushConstraint(foa1, foa2, 0)
End If
fot1.End
Unload Me
End Sub
Private Sub CommandButton4_Click()
Unload Me
End Sub
源文档 <http://www.jxcad.com.cn/read.php?tid=51710>
窗体：
