SolidWorks图号名称分离宏--不依赖空格或特殊符号

好东西，谢谢！

谢谢正需要

hcxxx901127 发表于 2018-10-20 10:58
像立管1、立管2这样的名称在前，图号3WPZ1000.2.-01、3WPZ1000.2.-02在后，这样的情况怎么处理？

这种情况不好处理， 你这个名称里带了一个数字，这种你最好在名称与图号种加空格或者其他符号

xiabulai 发表于 2019-3-17 18:11
冒昧的问一下，楼主遍历的图号名称分离宏能分享一下吗，不能分享也没关系

这是遍历宏加入分离宏，但是并不是绝对的稳定，有时候会出错

Dim TopDocPathOnly As String
Dim PartsCollect() As String '遍历清单（阵列）111
Dim InCollectCount As Double '遍历清单长度
Dim CustomInfoQTY As String

Sub main()
Set swApp = Application.SldWorks 'SW对象
Set TopDoc = swApp.ActiveDoc '总装对象
If TopDoc.GetType <> 2 Then Exit Sub '不是装配=退出
TopDocPathSplit = Split(TopDoc.GetPathName, "") '分割
TopDocName = TopDocPathSplit(UBound(TopDocPathSplit)) '总装文件名称
TopDocName = Left(TopDocName, Len(TopDocName) - 7) '总装文件名称（排除.SLDASM）
TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "", -1)) '總裝整個目錄名稱
TopConfString = TopDoc.GetActiveConfiguration.Name '總裝配置名稱
CustomInfoQTY = "数量" '可按个人喜好修改预设值
InCollectCount = 1 '遍历清单长度基数
ReDim PartsCollect(InCollectCount) '定义阵列项数
SubAsm TopDoc, TopConfString '遍历
Beep
MsgBox "完成"
End Sub

Function SubAsm(AsmDoc, ConfString)
Set swApp = Application.SldWorks 'SW对象
Set TopDoc = swApp.ActiveDoc '总装对象
TopDocPathSplit = Split(TopDoc.GetPathName, "") '分割
TopDocName = TopDocPathSplit(UBound(TopDocPathSplit)) '总装文件名称
TopDocName = Left(TopDocName, Len(TopDocName) - 7) '总装文件名称（排除.SLDASM）
TopDocPathOnly = Mid(TopDoc.GetPathName, 1, InStrRev(TopDoc.GetPathName, "", -1)) '總裝整個目錄名稱
TopConfString = TopDoc.GetActiveConfiguration.Name '總裝配置名稱
Set Configuration = AsmDoc.GetConfigurationByName(ConfString)
Set RootComponent = Configuration.GetRootComponent
Components = RootComponent.GetChildren
For Each Child In Components
    Set ChildModel = Child.GetModelDoc
    If Not (ChildModel Is Nothing) Then '排除抑制及轻化
        ChildConfString = Child.ReferencedConfiguration '零件配置名称
        ChildType = ChildModel.GetType
            ChildPathSplit = Split(Child.GetPathName, "") '分割
            ChildName = ChildPathSplit(UBound(ChildPathSplit)) '零件文件名称
            ChildPathOnly = Mid(Child.GetPathName, 1, InStrRev(Child.GetPathName, "", -1)) '總裝整個目錄名稱
            If ChildPathOnly = Replace(ChildPathOnly, TopDocPathOnly, "") Then SamePath = False Else SamePath = True '零件是否在总装目录或以下目录
            If (Not Child.ExcludeFromBOM) And (Not Child.IsEnvelope) Then '跳过：不包括在材料明細表中 及 封套

                BYL_Name = ChildModel.CustomInfo2(ChildConfString, "BYL") '备用量属性名称
                BYL = ChildModel.CustomInfo2(ChildConfString, BYL_Name) '备用量
                If (BYL = 0) Or (BYL = "") Then BYL = 1 '备用量除错
                inCollect = False '重置判断变量
                For Each PartinCollect In PartsCollect '判断是否已在遍历清单內
                    If ChildConfString & "@" & ChildName = PartinCollect Then inCollect = True
                Next
                If inCollect Then '已在遍历清单內
                    ht_Qty = ChildModel.CustomInfo2(ChildConfString, CustomInfoQTY) + 1 * BYL
                    ChildModel.DeleteCustomInfo2 ChildConfString, CustomInfoQTY
                    ChildModel.AddCustomInfo3 ChildConfString, CustomInfoQTY, 30, ht_Qty
                Else '不在遍历清单內（首次处理）
                    ChildModel.DeleteCustomInfo2 ChildConfString, CustomInfoQTY
                    ChildModel.AddCustomInfo3 ChildConfString, CustomInfoQTY, 30, BYL
                    InCollectCount = InCollectCount + 1
                    ReDim Preserve PartsCollect(InCollectCount) '重新定义阵列项数（保留內含数据）
                    PartsCollect(InCollectCount - 1) = ChildConfString & "@" & ChildName '加入到遍历清单中
                    ChildModel.SetUserPreferenceIntegerValue swUnitSystem, swUnitSystem_Custom '单位系统=Custom
                    ChildModel.SetUserPreferenceIntegerValue swUnitsMassPropMass, swUnitsMassPropMass_Kilograms '重量单位设定为kg（可按喜好加入設定）
                                    ChildModel.SetUserPreferenceIntegerValue swUnitsMassPropMass, swUnitsMassPropMass_Grams '设质量定单位为克
                ChildModel.DeleteCustomInfo2 "", "重量" '删除重量自定义属性
                ChildModel.DeleteCustomInfo2 ChildConfString, "重量" '删除重量配置特定属性
                ChildModel.AddCustomInfo3 ChildConfString, "重量", 30, Chr(34) & "SW-Mass@@" & ChildConfString & "@*" & ChildName & Chr(34) '加入重量配置特定属性
                ChildModel.SetUserPreferenceIntegerValue swUnitsMassPropLength, swCM '设定体积单位为厘米
                ChildModel.SetUserPreferenceIntegerValue swUnitsMassPropVolume, swUnitsMassPropVolume_Centimeters3 '设定单位每立方厘米
                ChildModel.DeleteCustomInfo2 "", "体积" '删除体积自定义属性
                ChildModel.DeleteCustomInfo2 ChildConfString, "体积" '删除体积配置特定属性
                ChildModel.AddCustomInfo3 ChildConfString, "体积", 30, Chr(34) & "SW-Volume@@" & ChildConfString & "@*" & ChildName & Chr(34) '加入体积配置特定属性
                ChildModel.SetUserPreferenceIntegerValue swUnitsMassPropDecimalPlaces, 8 '质量及体积小数后8位
               ConfName = ChildModel.GetActiveConfiguration.Name
                Set CustPropMgr = ChildModel.Extension.CustomPropertyManager(ConfName)

                Path_Name = ChildModel.GetPathName() '取得"路径名称及扩展名",不管扩展名是否应藏
                S1 = InStrRev(Path_Name, "\") '\符号在路径之最后位置数
                Name_C = Right(Path_Name, Len(Path_Name) - S1) '取得件号_名称.扩展名"

b = Len(Name_C)
e = Right(Name_C, 7)

If e = ".SLDPRT" Or e = ".SLDASM" Or e = ".sldprt" Or e = ".sldasm" Then
   g = Left(Name_C, b - 7)
Else
   g = Name_C
End If

   k = Len(g)

For I = 1 To Len(g)
   If Asc(Mid$(g, I, 1)) < 0 Then
      w = I  '确定第一个汉字的位置
   Exit For
   End If
Next

For I = 0 To Len(g) - 1
   If Asc(Mid$(g, k - I, 1)) < 0 Then
      X = k - I  '确定最后一个汉字的位置
   Exit For
   End If
Next

If w > 0 Then
  If w = 1 Then
     s = Left(g, X) '汉字在前数字在后的情况
     T = Right(g, k - X)
  Else
     s = Right(g, k - w + 1) '数字在前汉字在后的情况
     T = Left(g, w - 1)
  End If
Else
  s = "" '纯数字的情况
  T = g


End If

If k - ((X - w) + 1) = 1 Or k - ((X - w) + 1) = 0 Then  '纯名称的情况
  T = ""
  s = g

Else
End If


                '删除栏
                CustPropMgr.Delete ("代号")
                CustPropMgr.Delete ("名称")
                CustPropMgr.Delete ("客户")

                '新增
                CustPropMgr.Add2 "代号", swCustomInfoText, T
                CustPropMgr.Add2 "名称", swCustomInfoText, s
                CustPropMgr.Add2 "客户", swCustomInfoText, TopConfString


                ChildModel.SketchManager.Insert3DSketch True '插入三低草图
                ChildModel.SketchManager.Insert3DSketch True '离开三低草图
                End If
                 If ChildType = 2 Then
            SubAsm ChildModel, ChildConfString '如果是装配则向下遍历
            End If

        End If
    End If
Next
End Function

cj8510 发表于 2019-7-2 20:17
这个代码在各大论坛发扬光大了。

是吗，我还没注意

s78763036 发表于 2019-12-2 10:38
这是遍历宏加入分离宏，但是并不是绝对的稳定，有时候会出错

Dim TopDocPathOnly As String

非常感谢！

这是最新修改过的，更改了判断方法，希望能帮助大家，没学过编程，代码乱写的，但是能用

1. Sub MAIN()
   
2. Set swApp = CreateObject("sldworks.application")
   
3. Set Part = swApp.ActiveDoc
   
4. swApp.ActiveDoc.ActiveView.FrameState = 1
   
5. Set CurCFG = Part.GetActiveConfiguration()
   
6. ConfName = CurCFG.Name
   
7. Name = swApp.ActiveDoc.GetTitle()
   
8.   c = Replace(Name, " ", "")
   
9. blnretval = Part.AddCustomInfo3(ConfName, "代号", swCustomInfoText, frmPartID)
   
10. blnretval = Part.AddCustomInfo3(ConfName, "名称", swCustomInfoText, frmPartID)
    
11.    b = Len(c)
    
12.    e = Right(c, 7)
    
13. If e = ".SLDPRT" Or e = ".SLDASM" Or e = ".sldprt" Or e = ".sldasm" Then
    
14.    f = Left(c, b - 7)
    
15. Else
    
16.    f = c
    
17. End If
    
18. k = Len(f)
    
19. kk = LenB(StrConv(f, vbFromUnicode))   
    
20. If k = kk Then '纯数字的情况
    
21.     s = ""
    
22.     t = f
    
23.     Response = MsgBox("文件名不包含零件名称，已整体写入“代号”属性栏", vbOKOnly, "未读取到零件名称") '窗口提示,不需要提示可以删除本行
    
24. Else
    
25.     If kk / k = 2 Then  '纯汉字的情况
    
26.         t = ""
    
27.         s = f
    
28.         Response = MsgBox("文件名不包含代号，已整体写入“名称”属性栏", vbOKOnly, "未读取到零件代号") '窗口提示,不需要提示可以删除本行
    
29.     Else
    
30.         For i = 1 To k
    
31.             If Asc(Mid$(f, i, 1)) < 0 Then
    
32.                 w = i '确定第一个汉字的位置
    
33.         Exit For
    
34.             End If
    
35.         Next
    
36.         If w = 1 Then                '名称+代号的情况
    
37.             s = Left(f, kk - k)
    
38.             t = Right(f, k - (kk - k))
    
39.         Else                         '代号+名称的情况
    
40.             s = Right(f, k - w + 1)
    
41.             t = Left(f, w - 1)
    
42.         End If
    
43.     End If
    
44. End If
    
45. dummy = Part.Extension.CustomPropertyManager(Part.ConfigurationManager.ActiveConfiguration.Name).Set("代号", t)
    
46. dummy = Part.Extension.CustomPropertyManager(Part.ConfigurationManager.ActiveConfiguration.Name).Set("名称", s)
    
47. End Sub

复制代码

不错，很好。多谢！

谢谢楼主分想

这个必须支持！！！