sw+vba非批量操作=180822

Sub 插入孔()
Call sw初始化("")
总数 = SelMgr.GetSelectedObjectCount2(-1)
Set 边线1阵列方向 = Nothing
For i = 1 To 总数
Set 对象 = SelMgr.GetSelectedObject6(i, -1)
nSelType = SelMgr.GetSelectedObjectType3(i, -1)
Select Case nSelType
Case swSelFACES
Set 放置面 = 对象
Case swSelEDGES, swSelEXTSKETCHSEGS
If 边线1阵列方向 Is Nothing Then
Set 边线1阵列方向 = 对象
Else
Set 边线2 = 对象
End If
End Select
Next

If 边线1阵列方向 Is Nothing Then
Dim s As Double
Dim e As Double
Dim Curve As SldWorks.Curve
Set 面边界 = CreateObject("Scripting.Dictionary")
vEdges = 放置面.GetEdges
i = 1
For Each 边 In vEdges
If i <= 2 Then
Set Curve = 边.GetCurve
If Curve.IsLine Then
bRet = Curve.GetEndParams(s, e, False, False)
线长度 = Curve.GetLength3(s, e) * 1000
If 线长度 > 11.5 Then
vLineParam = Curve.LineParams
If Abs(vLineParam(3)) = 1 Then
Set 面边界("x") = 边
ElseIf Abs(vLineParam(4)) = 1 Then
Set 面边界("y") = 边
ElseIf Abs(vLineParam(5)) = 1 Then
Set 面边界("z") = 边
End If
i = i + 1
End If
End If
End If
Next

If 面边界.Exists("x") And 面边界.Exists("y") Then
Set 面边界("横") = 面边界("x")
Set 面边界("竖") = 面边界("y")
ElseIf 面边界.Exists("y") And 面边界.Exists("z") Then
Set 面边界("横") = 面边界("z")
Set 面边界("竖") = 面边界("y")
Else
Set 面边界("横") = 面边界("x")
Set 面边界("竖") = 面边界("z")
End If

Set 边线1阵列方向 = 面边界("横")
Set 边线2 = 面边界("竖")
End If

swModel.ClearSelection2 True
numAdded = SelMgr.AddSelectionListObject(放置面, selData)
库特征全名 = Range("库特征路径") & "\" & Range("库特征名称") & ".sldlfp"
boolstatus = swModel.InsertLibraryFeature(库特征全名)
Set 当前库特征 = SelMgr.GetSelectedObject6(1, -1)

Dim LibraryFeatureData As SldWorks.LibraryFeatureData
Set LibraryFeatureData = 当前库特征.GetDefinition

Status = LibraryFeatureData.AccessSelections(swModel, Nothing)
Dim vLibRefs(1) As Object
Set vLibRefs(0) = 边线1阵列方向
Set vLibRefs(1) = 边线2

LibraryFeatureData.SetReferences (vLibRefs)
Status = 当前库特征.ModifyDefinition(LibraryFeatureData, swModel, Nothing)

'    LibraryFeatureData.ReleaseSelectionAccess
If 解散库特征 Then swModel.DissolveLibraryFeature
End Sub
Sub GetEdges_cs()
Call sw初始化("")
Set 对象 = SelMgr.GetSelectedObject6(1, -1)
nEdgeCount = 对象.GetEdgeCount
vEdges = 对象.GetEdges
Dim s As Double
Dim e As Double
Dim Curve As SldWorks.Curve

For j = 0 To (nEdgeCount - 1)
Set Curve = vEdges(j).GetCurve
If Curve.IsLine Then
vEdges(j).Display 2, 0, 0, 1, True
'            vLineParam = Curve.LineParams
'            Debug.Print "Root point = (" & vLineParam(0) * 1000# & ", " & vLineParam(1) * 1000# & ", " & vLineParam(2) * 1000# & ") mm"
'            Debug.Print "Direction = (" & vLineParam(3) & ", " & vLineParam(4) & ", " & vLineParam(5) & ")"
bRet = Curve.GetEndParams(s, e, False, False)
Debug.Print Curve.GetLength3(s, e)

Else
vEdges(j).Display 2, 0, 0, 0, True
End If
Next j
End Sub
Sub 插入孔cs()
Call sw初始化("")
Set 拟重装组件 = CreateObject("Scripting.Dictionary")
Set 坐标参考对象 = CreateObject("Scripting.Dictionary")
Set 选择的组件对象 = CreateObject("Scripting.Dictionary")

Set 放置面 = SelMgr.GetSelectedObject6(1, -1)
If 放置面 Is Nothing Then
'        AppActivate ThisWorkbook.Name
MsgBox "没有选择 放置面  !", vbInformation
Exit Sub
End If

boolstatus = swModel.InsertLibraryFeature("D:\企业模板\库特征\光孔.sldlfp")
Set 当前库特征 = SelMgr.GetSelectedObject6(1, -1)
Debug.Print 当前库特征.Name
'    boolstatus = swModel.Extension.SelectByID2("光孔<1>", "BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
swModel.DissolveLibraryFeature
End Sub

Sub 插入孔cs2()
Call sw初始化("")
总数 = SelMgr.GetSelectedObjectCount2(-1)
Set 边线1阵列方向 = Nothing
For i = 1 To 总数
Set 对象 = SelMgr.GetSelectedObject6(i, -1)
nSelType = SelMgr.GetSelectedObjectType3(i, -1)
Select Case nSelType
Case swSelFACES
Set 放置面 = 对象
Case swSelEDGES
If 边线1阵列方向 Is Nothing Then
Set 边线1阵列方向 = 对象
Else
Set 边线2 = 对象
End If
End Select
Next

Dim LibraryFeatureData As SldWorks.LibraryFeatureData
Dim swFeature As SldWorks.Feature

Set LibraryFeatureData = swFeatMgr.CreateDefinition(swFmLibraryFeature)
库特征全名 = Range("库特征路径") & "\" & Range("库特征名称") & ".sldlfp"
Status = LibraryFeatureData.Initialize(库特征全名)
nRefCount = LibraryFeatureData.GetReferencesCount
vRefs = LibraryFeatureData.GetReferences2(swLibFeatureData_FeatureRespect, vRefTypes)
'    If Not IsEmpty(vRefTypes) Then
'        Debug.Print "Types of references required (edge = 1): "
'        For Each refType In vRefTypes
'            Debug.Print "   " & CStr(refType)
'        Next
'    End If
'    LibraryFeatureData.ConfigurationName = "默认"

swModel.ClearSelection2 True
numAdded = SelMgr.AddSelectionListObject(放置面, selData)
Set swFeature = swFeatMgr.CreateFeature(LibraryFeatureData)
Set swFeature = SelMgr.GetSelectedObject6(1, -1) '上一步可能返回nothing

Set LibraryFeatureData = Nothing
Set LibraryFeatureData = swFeature.GetDefinition
Status = LibraryFeatureData.AccessSelections(swModel, Nothing)

Dim vLibRefs(1) As Object
Set vLibRefs(0) = 边线1阵列方向
Set vLibRefs(1) = 边线2

LibraryFeatureData.SetReferences (vLibRefs)
Status = swFeature.ModifyDefinition(LibraryFeatureData, swModel, Nothing)

'    LibraryFeatureData.ReleaseSelectionAccess
swModel.DissolveLibraryFeature
End Sub
Sub 获取库特征数据()
Call sw初始化("")

Set 库特征 = SelMgr.GetSelectedObject6(1, -1)
Set LibraryFeatureData = 库特征.GetDefinition
boolstatus = LibraryFeatureData.AccessSelections(swModel, Nothing)

' Get the references
vRefs = LibraryFeatureData.GetReferences3(swLibFeatureData_e.swLibFeatureData_PartRespect, vRefType, vRefName)
If Not IsEmpty(vRefType) Then
Debug.Print "Reference types and names: "
For i = LBound(vRefType) To UBound(vRefType)
Debug.Print "  " & vRefType(i) & ", " & vRefName(i)
vRefs(i).Select False
Next i
End If
'Release the selections that define the library feature
LibraryFeatureData.ReleaseSelectionAccess

End Sub

模块32库特征 模块33插入其他库特征

Sub 插入零件或装配体(ByVal 文件后缀, ByVal 清单排除, ByVal 虚拟)
Call sw初始化("")
Set swConf = swConfigMgr.ActiveConfiguration
Debug.Print swConf.Name
配置名 = swConf.Name

If Not 虚拟 Then
名称 = FilenameWHZ & "=" & Range("零件名称后缀")
If 文件后缀 = ".SLDPRT" Then
'        模板 = swApp.GetUserPreferenceStringValue(swDefaultTemplatePart)
模板 = Range("文件模板路径") & "\" & Range("零件模板") & ".PRTDOT"
Else
'        模板 = swApp.GetUserPreferenceStringValue(swDefaultTemplateAssembly)
模板 = Range("文件模板路径") & "\" & Range("装配体模板") & ".ASMDOT"
End If
目标 = FilePath & 名称 & 文件后缀
Debug.Print 目标
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
fso.CopyFile 模板, 目标
Set fso = Nothing
Else
目标 = IIf(文件后缀 = ".SLDPRT", "D:\企业模板\外部参考.SLDPRT", "D:\企业模板\外部参考.SLDASM")
End If

Call 类型判断(目标)
Set swModelkk = swApp.OpenDoc6(目标, swFileTYpe, swOpenDocOptions_Silent, "", lErrors, lwarnings)
swModelkk.Visible = False
SaveOk = swModelkk.Save3(1, lErrors, lwarnings)

'    Set swModel = swApp.ActivateDoc3(sw全名, False, 0, lErrors)
Set 对象 = swModel.AddComponent5(目标, 0, "", False, "", 0, 0, 0)
Debug.Print 对象.GetSelectByIDString
对象ID = 对象.GetSelectByIDString

原点2 = "Point1@原点@" & 对象.GetSelectByIDString
swModel.ClearSelection2 True
boolstatus = swModel.Extension.SelectByID2("Point1@原点", "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
boolstatus = swModel.Extension.SelectByID2(原点2, "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
Set myMate = swModel.AddMate5(20, -1, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, lstatus)

boolstatus = swModel.Extension.SelectByID2(对象ID, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = swModel.CompConfigProperties4(2, 0, True, True, "", 清单排除)

If 虚拟 Then
stat = 对象.MakeVirtual2(False)
kk = 对象.Name
SaveOk = swModel.Save3(1, lErrors, lwarnings)
对象.Name2 = Range("零件名称后缀")
End If

swModel.EditRebuild3
Call 激活窗口

End Sub
Sub 插入外部参考(ByVal 清单排除, ByVal 零件)
Call sw初始化("")
目标 = IIf(零件, "D:\企业模板\外部参考.SLDPRT", "D:\企业模板\外部参考.SLDASM")

Call 类型判断(目标)
Set swModelkk = swApp.OpenDoc6(目标, swFileTYpe, swOpenDocOptions_Silent, "", lErrors, lwarnings)
swModelkk.Visible = False
SaveOk = swModelkk.Save3(1, lErrors, lwarnings)

Set 对象 = swModel.AddComponent5(目标, 0, "", False, "", 0, 0, 0)
Debug.Print 对象.GetSelectByIDString
对象ID = 对象.GetSelectByIDString

原点2 = "Point1@原点@" & 对象.GetSelectByIDString
swModel.ClearSelection2 True
boolstatus = swModel.Extension.SelectByID2("Point1@原点", "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
boolstatus = swModel.Extension.SelectByID2(原点2, "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
Set myMate = swModel.AddMate5(20, -1, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, lstatus)

boolstatus = swModel.Extension.SelectByID2(对象ID, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = swModel.CompConfigProperties4(2, 0, True, True, "", 清单排除)

stat = 对象.MakeVirtual2(False)
kk = 对象.Name
SaveOk = swModel.Save3(1, lErrors, lwarnings)
对象.Name2 = "外部参考"

swModel.EditRebuild3
Call 激活窗口

End Sub

Sub cs()
Call sw初始化("")
Set ModelDocExtension = swModel.Extension
value = swApp.GetUserPreferenceStringValue(swDefaultTemplatePart)
Debug.Print value
value = swApp.GetUserPreferenceStringValue(swDefaultTemplateAssembly)
Debug.Print value

End Sub

模块4插入零件或装配体

  模块72粘贴技术要求

Sub cs()
Call sw初始化("")
Set swDisplayDim = SelMgr.GetSelectedObject6(1, -1)
swDisplayDim.SetText swDimensionTextPrefix, "42x50(="
swDisplayDim.SetText swDimensionTextSuffix, ")"
'swDisplayDim.GridBubble = True
End Sub
Sub cs2()
Call sw初始化("")
boolstatus = swModel.Extension.EditDimensionProperties(swTolBASIC, 0, 0, "", "", True, 9, swDimArrowsFollowDoc, _
True, swSLASH_ARROWHEAD, swSLASH_ARROWHEAD, "", "", True, "", "kk", "lower text", True, swThisConfiguration, "")

End Sub
Sub cs3()
'    Dim holeVariables As Variant
Dim swDisplayDimension As Object
Call sw初始化("")
'Get the selected hole callout
Set swDisplayDimension = SelMgr.GetSelectedObject6(1, -1)
holeVariables = swDisplayDimension.GetHoleCalloutVariables
Debug.Print "Number of hole callout variables = " & UBound(holeVariables) + 1
Debug.Print ""
'Determine type of hole callout variable and get and set some values
For i = 0 To UBound(holeVariables)
Set swCalloutVariable = holeVariables(i)
str1 = "  Callout variable name = " & swCalloutVariable.VariableName
str2 = "  Callout variable name as it appears in Dimension PropertyManager page = " & swCalloutVariable.UserReadableVariableName
vType = swCalloutVariable.Type
If vType = swCalloutVariableType_e.swCalloutVariableType_Length Then
Set swCalloutLengthVariable = swCalloutVariable
Debug.Print "Callout variable(" & i & ")'s" & " type = length"
Debug.Print str1
Debug.Print str2
Debug.Print "  Length = " & swCalloutLengthVariable.Length
Debug.Print "  Precision = " & swCalloutLengthVariable.precision
Debug.Print "  Tolerance precision = " & swCalloutLengthVariable.TolerancePrecision
swCalloutLengthVariable.precision = swCalloutLengthVariable.precision - 1 - i
Debug.Print "  Changed precision = " & swCalloutLengthVariable.precision
swCalloutVariable.ToleranceType = swTolType_e.swTolBILAT
ElseIf vType = swCalloutVariableType_e.swCalloutVariableType_Angle Then
Set swCalloutAngleVariable = swCalloutVariable
Debug.Print "Callout variable(" & i & ")'s" & " type = angle"
Debug.Print str1
Debug.Print str2
Debug.Print "  Angle = " & swCalloutAngleVariable.Angle
ElseIf vType = swCalloutVariableType_e.swCalloutVariableType_String Then
Set swCalloutStringVariable = swCalloutVariable
Debug.Print "Callout variable(" & i & ")'s" & " type = string"
Debug.Print str1
Debug.Print str2
Debug.Print "  String = '" & swCalloutStringVariable.String & "'"
End If
Next
End Sub
Sub cs4()
Dim swDisplayDimension As Object
Call sw初始化("")
'Get the selected hole callout
Set swDisplayDimension = SelMgr.GetSelectedObject6(1, -1)
holeVariables = swDisplayDimension.GetHoleCalloutVariables
Debug.Print "Number of hole callout variables = " & UBound(holeVariables) + 1
Debug.Print ""
'Determine type of hole callout variable and get and set some values
For Each v In holeVariables
Debug.Print v.VariableName
Next
End Sub

Sub 孔标注cs5()
Dim swDispDim As Object
Call sw初始化("")
'Get the selected hole callout
Set swDispDim = SelMgr.GetSelectedObject6(1, -1)
Debug.Print "    ------------------------------------"

'Debug.Print "      DimFullName                  = " & swDispDim.FullName
'Debug.Print "      DimName                      = " & swDispDim.Name
Debug.Print "      swDimensionParamType_e type  = " & swDispDim.GetType
'Debug.Print "      DrivenState                  = " & swDispDim.DrivenState
'Debug.Print "      ReadOnly                     = " & swDispDim.ReadOnly
'Debug.Print "      Value                        = " & swDispDim.GetSystemValue2("")
Debug.Print ""
Debug.Print "      Arrowside                    = " & swDispDim.ArrowSide
Debug.Print "      TextAll                      = " & swDispDim.GetText(swDimensionTextAll)
Debug.Print "      TextPrefix                   = " & swDispDim.GetText(swDimensionTextPrefix)
Debug.Print "      TextSuffix                   = " & swDispDim.GetText(swDimensionTextSuffix)
Debug.Print "      CalloutAbove                 = " & swDispDim.GetText(swDimensionTextCalloutAbove)
Debug.Print "      CalloutBelow                 = " & swDispDim.GetText(swDimensionTextCalloutBelow)

'    Debug.Print "Is a hole callout? " & swDispDim.IsHoleCallout
'    Debug.Print "  Callout portion above text  = " & swDispDim.GetText(swDimensionTextParts_e.swDimensionTextCalloutAbove)
'    Debug.Print "  Callout portion below text  = " & swDispDim.GetText(swDimensionTextParts_e.swDimensionTextCalloutBelow)
'    Debug.Print "  Prefix of callout = " & swDispDim.GetText(swDimensionTextParts_e.swDimensionTextPrefix)
'    Debug.Print "  Suffix of callout = " & swDispDim.GetText(swDimensionTextParts_e.swDimensionTextSuffix)
End Sub

Sub 其他尺寸cs5()
Dim swDispDim As Object
Dim swDim                       As SldWorks.Dimension

Call sw初始化("")
'Get the selected hole callout
Set swDispDim = SelMgr.GetSelectedObject6(1, -1)
Set swAnn = swDispDim.GetAnnotation
Set swDim = swDispDim.GetDimension

Debug.Print "    ------------------------------------"
Debug.Print "    AnnName = " & swAnn.GetName
Debug.Print "      DimFullName                  = " & swDim.FullName
Debug.Print "      DimName                      = " & swDim.Name
Debug.Print "      swDimensionParamType_e type  = " & swDim.GetType
Debug.Print "      DrivenState                  = " & swDim.DrivenState
Debug.Print "      ReadOnly                     = " & swDim.ReadOnly
Debug.Print "      Value                        = " & swDim.GetSystemValue2("")
Debug.Print ""
Debug.Print "      Arrowside                    = " & swDispDim.ArrowSide
Debug.Print "      TextAll                      = " & swDispDim.GetText(swDimensionTextAll)
Debug.Print "      TextPrefix                   = " & swDispDim.GetText(swDimensionTextPrefix)
Debug.Print "      TextSuffix                   = " & swDispDim.GetText(swDimensionTextSuffix)
Debug.Print "      CalloutAbove                 = " & swDispDim.GetText(swDimensionTextCalloutAbove)
Debug.Print "      CalloutBelow                 = " & swDispDim.GetText(swDimensionTextCalloutBelow)
End Sub

模块740孔标注测试

Sub 处理孔标注f()
Dim swDispDim As Object
Call sw初始化("")
'Get the selected hole callout
Set swDispDim = SelMgr.GetSelectedObject6(1, -1)

TextPrefix = swDispDim.GetText(swDimensionTextParts_e.swDimensionTextCalloutAbove)
TextPrefix = swDispDim.GetText(swDimensionTextPrefix)
TextPrefix = Replace(TextPrefix, " ", "")

'    If InStr(1, TextAll, "<hw-thru>", 1) <> 0 Then
'        TextPrefix = Replace(TextPrefix, "<hw-thru>", "")
'        swDispDim.SetText swDimensionTextPrefix, TextPrefix
'        swDispDim.SetText swDimensionTextSuffix, "通孔"
'    End If
swDispDim.SetText swDimensionTextPrefix, "<NUM_INST>-<hw-diam>X<hw-slot-length>"
swDispDim.SetText swDimensionTextCalloutBelow, "通孔"

End Sub
Sub 处理孔标注(ByVal 类别)
Dim swDispDim As Object
Call sw初始化("")
总数 = SelMgr.GetSelectedObjectCount2(-1)
For i = 1 To 总数
Set swDispDim = SelMgr.GetSelectedObject6(i, -1)
Select Case 类别
Case "腰形孔"
swDispDim.SetText swDimensionTextPrefix, "<NUM_INST>-<hw-diam>X<hw-slot-length>"
swDispDim.SetText swDimensionTextCalloutBelow, "通孔"
Case "光孔"
CalloutPrefix = swDispDim.GetText(swDimensionTextPrefix)
If InStr(1, CalloutPrefix, "x", 1) <> 0 Then
数量 = "<NUM_INST>-"
Else
数量 = ""
End If
swDispDim.SetText swDimensionTextPrefix, 数量 & "<MOD-DIAM><hw-diam>" '<NUM_INST> x <MOD-DIAM> <hw-diam> <hw-thru>
swDispDim.SetText swDimensionTextCalloutBelow, "通孔"
Case "沉头孔"
'                <NUM_INST> x <MOD-DIAM> <hw-thruholedia> <hw-thru>
'                <HOLE-SPOT><MOD-DIAM> <hw-cbdia> <HOLE-DEPTH> <hw-cbdepth>
CalloutAbove = swDispDim.GetText(swDimensionTextCalloutAbove)
If InStr(1, CalloutAbove, "x", 1) <> 0 Then
数量 = "<NUM_INST>-"
Else
数量 = ""
End If
swDispDim.SetText swDimensionTextCalloutAbove, 数量 & "<MOD-DIAM><hw-thruholedia>通孔"
swDispDim.SetText swDimensionTextPrefix, "<HOLE-SPOT><MOD-DIAM><hw-cbdia><HOLE-DEPTH><hw-cbdepth>"
Case "螺纹孔"
'                <NUM_INST> x  <hw-threaddesc> - 6H <HOLE-DEPTH> <hw-threaddepth>
'                <MOD-DIAM> <hw-tapdrldia> <HOLE-DEPTH> <hw-tapdrldepth>
CalloutAbove = swDispDim.GetText(swDimensionTextCalloutAbove)
If InStr(1, CalloutAbove, "x", 1) <> 0 Then
数量 = "<NUM_INST>-"
Else
数量 = ""
End If
If InStr(1, CalloutAbove, "贯", 1) <> 0 Then
swDispDim.SetText swDimensionTextCalloutAbove, 数量 & "<hw-threaddesc>"
swDispDim.SetText swDimensionTextCalloutBelow, "攻通"
Else
swDispDim.SetText swDimensionTextCalloutAbove, 数量 & "<hw-threaddesc>丝深<hw-threaddepth>"
End If
swDispDim.SetText swDimensionTextPrefix, ""

End Select
Next
Call 激活窗口
End Sub

模块741处理孔标注

Sub 阵列标注()
Dim swDim As SldWorks.Dimension
Call sw初始化("")
总数 = SelMgr.GetSelectedObjectCount2(-1)
For i = 1 To 总数
Set swDispDim = SelMgr.GetSelectedObject6(i, -1)
Set swDim = swDispDim.GetDimension
Select Case i
Case 1
单位间距 = swDim.GetSystemValue2("")
Case 2
总间距 = swDim.GetSystemValue2("")
Set 总间距尺寸 = swDispDim
End Select
Next

数量 = Round(总间距 / 单位间距)
总间距尺寸.SetText swDimensionTextPrefix, 数量 & "x" & Round(单位间距 * 1000, 1) & "(="
总间距尺寸.SetText swDimensionTextSuffix, ")"
End Sub

模块742阵列标注

Sub 找坐标系零件()
Set 坐标对象 = Nothing
For 实例号 = 1 To 9
坐标对象id = FilenameWHZ & "=坐标-" & 实例号 & "@" & FilenameWHZ
boolstatus = swModel.Extension.SelectByID2(坐标对象id, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)
If boolstatus Then Exit For
Next
If Not boolstatus Then
'            AppActivate ThisWorkbook.Name
MsgBox "装配体中必须有：装配体名称=坐标  的零件，并且实例号必须小于 9 ", vbInformation
Exit Sub
End If

Set 坐标对象 = SelMgr.GetSelectedObject6(1, -1)

'    If 坐标对象 Is Nothing Then
'111:    AppActivate ThisWorkbook.Name
'        MsgBox "装配体中必须有：装配体名称=坐标  的零件，并且实例号必须为 1 ", vbInformation
''        GoTo 110
'        Exit Sub
'    End If
End Sub
Sub 找坐标系零件V2(ByVal 父级选择ID, ByVal 父级WHZ)
Set 坐标对象 = Nothing
父级WHZ替换 = Replace(父级WHZ, "^", "_")
For 实例号 = 1 To 9

坐标对象id = 父级选择ID & "/坐标^" & 父级WHZ替换 & "-" & 实例号 & "@" & 父级WHZ
Debug.Print 坐标对象id
boolstatus = swModel.Extension.SelectByID2(坐标对象id, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)
If boolstatus Then Exit For
Next
If Not boolstatus Then
'            AppActivate ThisWorkbook.Name
MsgBox "装配体中必须有：装配体名称=坐标  的零件，并且实例号必须小于 9 ", vbInformation
Exit Sub
End If

Set 坐标对象 = SelMgr.GetSelectedObject6(1, -1)

End Sub
Sub 插入坐标系(ByVal 坐标参考对象)
Set 已有坐标系 = CreateObject("Scripting.Dictionary")

'获取已有坐标系
Set swFeat = 坐标对象.FirstFeature
Do While Not swFeat Is Nothing
Debug.Print swFeat.Name&; "==" & swFeat.GetTypeName2
If "CoordSys" = swFeat.GetTypeName2 And InStr(1, swFeat.Name, "cds", vbTextCompare) <> 0 Then
已有坐标系.Add swFeat.Name, ""
End If
Set swFeat = swFeat.GetNextFeature
Loop

'插入坐标系
SelMgr.SuspendSelectionList
numAdded = SelMgr.AddSelectionListObject(坐标对象, selData)
swModel.showcomponent2
lstatus = swModel.EditPart2(True, False, lwarnings)
For Each k In 坐标参考对象.keys
'    Debug.Print k.Name
'    If InStr(1, k.Name, "坐标", vbTextCompare) = 0 Then
组件id = k.GetSelectByIDString
标志 = 坐标参考对象(k)
坐标系名称 = "cds" & 标志
boolstatus = swModel.Extension.SelectByID2(组件id, "COMPONENT", 0, 0, 0, False, 0, Nothing, 0)
If Not 已有坐标系.Exists(坐标系名称) Then
可能名 = Array("右视基准面", "右视", "Right")
For Each 元素 In 可能名
kk = 元素 & "@" & 组件id
boolstatus = swModel.Extension.SelectByID2(kk, "PLANE", 0, 0, 0, False, 2, Nothing, 0)
If boolstatus Then Exit For
Next
可能名 = Array("原点", "Origin")
For Each 元素 In 可能名
kk = "Point1@" & 元素 & "@" & 组件id
boolstatus = swModel.Extension.SelectByID2(kk, "EXTSKETCHPOINT", 0, 0, 0, True, 1, Nothing, 0)
If boolstatus Then Exit For
Next
可能名 = Array("上视基准面", "上视", "Top")
For Each 元素 In 可能名
kk = 元素 & "@" & 组件id
boolstatus = swModel.Extension.SelectByID2(kk, "PLANE", 0, 0, 0, True, 4, Nothing, 0)
If boolstatus Then Exit For
Next
'            Call 猜基准面(组件id)
Set 坐标系 = swFeatMgr.InsertCoordinateSystem(False, False, False)
坐标系.Name = 坐标系名称
已有坐标系.Add 坐标系名称, ""
End If
'    End If
Next

SelMgr.SuspendSelectionList
swModel.EditAssembly
'    SaveOk = swModel.Save3(1, lErrors, lwarnings)

End Sub

模块999插入坐标系

Sub 重装组件(ByVal 拟重装组件)
Set 已装组件 = CreateObject("Scripting.Dictionary")
Components = swModel.GetComponents(False)
已经装入坐标对象 = False

boolstatus = swModel.Extension.SelectByID2("配合", "MATEGROUPS", 0, 0, 0, False, 0, Nothing, 0)
Set swFeature = SelMgr.GetSelectedObject6(1, -1)
SelMgr.SuspendSelectionList

坐标对象全名 = 坐标对象.GetPathName
Call 拆分文件名(坐标对象全名)
坐标对象短名 = FilenameWHZ

Set swSubFeature = swFeature.GetFirstSubFeature
Do While Not swSubFeature Is Nothing
'            Debug.Print swSubFeature.Name&; "==" & swSubFeature.GetTypeName2
If swSubFeature.GetTypeName2 = "MateCoordinate" Then
Set swMate = swSubFeature.GetSpecificFeature2
是坐标系配合 = False
For i = 0 To 1
Set swComp = swMate.MateEntity(i).ReferenceComponent
元素全名 = swComp.GetPathName
If InStr(元素全名, 坐标对象短名) <> 0 Then
已经装入坐标对象 = True
Set 新坐标对象 = swComp
End If
'在配合中找坐标系名称，作为已装组件的识别
Set swEnt = swMate.MateEntity(i).Reference
On Error Resume Next
元素类型 = swEnt.GetTypeName2
If 元素类型 = "CoordSys" Then
'                    Debug.Print swEnt.Name
键名 = Replace(swEnt.Name, "cds", "")
已装组件.Add 键名, ""
End If
Next

End If
Set swSubFeature = swSubFeature.GetNextSubFeature
Loop

'装入坐标对象
If Not 已经装入坐标对象 Then
拟装入零件 = 坐标对象.GetPathName
Call 类型判断(拟装入零件)
Set swModelkk = swApp.OpenDoc6(拟装入零件, swFileTYpe, swOpenDocOptions_Silent, "", lErrors, lwarnings)
swModelkk.Visible = False
Set 新坐标对象 = swModel.AddComponent5(拟装入零件, 0, "", False, "", 0, 0, 0)

SelMgr.SuspendSelectionList
numAdded = SelMgr.AddSelectionListObject(新坐标对象, selData)
swModel.UnfixComponent

对象ID = 新坐标对象.GetSelectByIDString
原点2 = "Point1@原点@" & 对象ID
swModel.ClearSelection2 True
boolstatus = swModel.Extension.SelectByID2("Point1@原点", "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
boolstatus = swModel.Extension.SelectByID2(原点2, "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
Set myMate = swModel.AddMate5(20, -1, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, lstatus)
End If

'======装入其他组件添加配合==开始
For Each k In 拟重装组件.keys
If Not 已装组件.Exists(k) Then
拟装入零件 = 拟重装组件(k)(0)
配置名 = 拟重装组件(k)(1)
Call 类型判断(拟装入零件)
Set swModelkk = swApp.OpenDoc6(拟装入零件, swFileTYpe, swOpenDocOptions_Silent, "", lErrors, lwarnings)
value = swModelkk.ShowConfiguration2(配置名)
swModelkk.Visible = False
Set 对象 = swModel.AddComponent5(拟装入零件, swAddComponentConfigOptions_CurrentSelectedConfig, "", False, "", 0, 0, 0)
'    对象.ComponentReference = 拟重装组件(k)(1)
对象ID = 对象.GetSelectByIDString
'    对象原点全名 = "Point1@原点@" & 对象ID

坐标对象id = 新坐标对象.GetSelectByIDString
坐标系全名 = "cds" & k & "@" & 坐标对象id

SelMgr.SuspendSelectionList
boolstatus = swModel.Extension.SelectByID2(坐标系全名, "COORDSYS", 0, 0, 0, False, 0, Nothing, 0)

可能名 = Array("原点", "Origin")
For Each 元素 In 可能名
对象原点全名 = "Point1@" & 元素 & "@" & 对象ID
boolstatus = swModel.Extension.SelectByID2(对象原点全名, "EXTSKETCHPOINT", 0, 0, 0, True, 0, Nothing, 0)
If boolstatus Then Exit For
Next

Set myMate = swModel.AddMate5(20, -1, False, 0, 0, 0, 0, 0, 0, 0, 0, False, False, 0, lstatus)
End If
Next
'======装入其他组件添加配合==完成
swModel.EditRebuild3
Call 激活窗口
'    SaveOk = swModel.Save3(1, lErrors, lwarnings)
End Sub

模块999重装组件

 

 

转载于:https://www.cnblogs.com/yiguxianyun/p/9603745.html

• 点赞
• 收藏
• 分享
• 文章举报

LI5566123456 发布了0 篇原创文章 · 获赞 0 · 访问量 703 私信 关注