设置材质+属性+单位=180621=移动文件增加相关工程图处理

Sub 移动文件()

获取行列号
Set 已经处理文件 = CreateObject("Scripting.Dictionary")
文件个数 = 1
Set fso = CreateObject("Scripting.FileSystemObject")
Call sw初始化("")
For 当前行 = 表头行 + 1 To 末行
    Cells(当前行, 文件路径列号).Select
    If ActiveCell.Interior.ColorIndex = "-4142" Then '只处理无填充色的行==开始
        编号分裂 = Split(Cells(当前行, 编号列号), "-")
        If UBound(编号分裂) = 0 Then
            sw全名 = Cells(当前行, 文件路径列号) & Cells(当前行, 文件名称列号) & "." & Cells(当前行, 格式列号)
            Call 拆分文件名(sw全名)
            If Not 已经处理文件.Exists(sw全名) Then '排除已处理
                If 文件个数 = 1 Then '先创建目录
                    拟移动路径 = Cells(当前行, 文件路径列号) & "移动文件"
                    If "" <> Dir(拟移动路径, 16) Then
                        a = Format(Date, "yymmdd")   '当前年月日
                        b = Format(Time, "hhmmss")     '当前时间
                        拟移动路径 = 拟移动路径 & "=" & a & "." & b
                    End If
                    VBA.MkDir (拟移动路径)
                End If
                
                NewFileName = 拟移动路径 & "\" & Filename
                On Error Resume Next
                fso.MoveFile sw全名, NewFileName
                If Err.Number <> 0 Then
                    Set kkswModel = swApp.GetOpenDocumentByName(sw全名)
                    nRetVal = kkswModel.ForceReleaseLocks
                    Err.Clear
                    fso.MoveFile sw全名, NewFileName
                End If
                已经处理文件.Add sw全名, ""
                
                Cells(当前行, 文件路径列号).Interior.ColorIndex = 15
                文件个数 = 文件个数 + 1
            End If
        End If
    End If '只处理无填充色的行==结束
Next
     
Set fso = Nothing

End Sub

Sub 属性规范化()
获取行列号

For 当前行 = 首行 To 末行
    If Cells(当前行, 文件路径列号).Interior.ColorIndex = "-4142" Then '只处理无填充色的行==开始
    
    编号分裂 = Split(Cells(当前行, 编号列号), "-")
    Cells(当前行, 材质列号).Select
    If Not UBound(编号分裂) > 0 Then
        If UCase(Cells(当前行, 格式列号)) = "SLDPRT" And ActiveCell = "" Then
            ActiveCell = """SW-Material@" & Cells(当前行, 文件名称列号) & ".SLDPRT" & """"
        End If
        Cells(当前行, 重量列号) = """SW-Mass@" & Cells(当前行, 文件名称列号) & "." & Cells(当前行, 格式列号) & """"
        主文件名 = Cells(当前行, 文件名称列号)
    Else
'        "SW-Material@@@切割清单项目1=1@SJS800.01.01.01.00【车体焊接件】.SLDPRT"
        If ActiveCell = "" Then
            ActiveCell = """SW-Material@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
        End If
'        "SW-Mass@@@切割清单项目1=1@SJS800.01.01.01.00【车体焊接件】.SLDPRT"
        Cells(当前行, 重量列号) = """SW-Mass@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
            
        原规格 = Cells(当前行, 规格列号)
        If Cells(当前行, 长度列) <> "" Then
            If Range("是否表达式") = "表达式" Then
                拟填入长度 = """LENGTH@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                '"LENGTH@@@切割清单项目11@落地支腿a.SLDPRT"
            Else
                拟填入长度 = Cells(当前行, 长度列)
            End If
            
            '判断原规格======开始
            If InStr(1, 原规格, "长""", 1) = 0 Then
                Cells(当前行, 规格列号) = 原规格 & "长" & 拟填入长度
            Else
            
            '判断原规格======结束
                原规格 = Left(原规格, InStrRev(原规格, "长") - 1)
                Cells(当前行, 规格列号) = 原规格 & "长" & 拟填入长度
            End If
            
            
        ElseIf Cells(当前行, 边界框长度列) <> "" Then
            If Range("是否表达式") = "表达式" Then
                If Cells(当前行, Range("是否钣金").Column) = "是" Then
                    长 = """SW-边界框长度@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                    宽 = """SW-边界框宽度@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                    厚 = """SW-钣金厚度@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                Else
                    长 = """SW-3D-边界框长度@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                    宽 = """SW-3D-边界框宽度@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                    厚 = """SW-3D-边界框厚度@@@" & Cells(当前行, 文件名称列号) & "@" & 主文件名 & ".SLDPRT" & """"
                End If
            Else
                长 = Cells(当前行, 边界框长度列)
                宽 = Cells(当前行, 边界框长度列 + 1)
                厚 = Cells(当前行, 边界框长度列 + 2)
            End If
            If 原规格 = "" Or 含其中之一(原规格, "@@@|厚") Then
                Cells(当前行, 规格列号) = 长 & "X" & 宽 & "厚" & 厚
            End If
        End If
        
    End If
    
    End If '只处理无填充色的行==结束
Next

End Sub
Sub 规格列正则表达式()
    Dim oRegExp As Object
    Dim oMatches As Object
    Dim oMatche As Object
    Dim sText As String
    sText = Cells(12, 12)
    Set oRegExp = CreateObject("vbscript.regexp")
    With oRegExp
'            .Global = True
        .IgnoreCase = True
        .Pattern = "([^长]+)(长K\S)"
'        .Pattern = "([^长]+)([长\""\S])"
        Debug.Print .test(sText)
        If .test(sText) Then
            Set oMatches = .Execute(sText)
            Debug.Print oMatches(0).submatches(0)
            For Each k In oMatches
                Debug.Print k
            Next
            
'            Cells(c.Row, 代号列号) = RTrim(oMatches(0).submatches(0))
'            Cells(c.Row, 名称列号) = oMatches(0).submatches(1) & oMatches(0).submatches(2)
        End If
    End With
    Set oRegExp = Nothing
    Set oMatches = Nothing
            
End Sub

Sub 读主材质及属性(ByVal 配置特定属性, ByVal 仅选择行)
获取行列号
Set 已经处理文件 = CreateObject("Scripting.Dictionary")
文件个数 = 1
If 仅选择行 Then
    新首行 = ActiveCell.Row
    新末行 = 新首行
Else
    新首行 = 表头行 + 1
    新末行 = 末行
End If

For 当前行 = 新首行 To 新末行
    Cells(当前行, 文件路径列号).Select
    If ActiveCell.Interior.ColorIndex = "-4142" Then '只处理无填充色的行==开始
    编号分裂 = Split(Cells(当前行, 编号列号), "-")
    If UBound(编号分裂) = 0 Then
        sw全名 = Cells(当前行, 文件路径列号) & Cells(当前行, 文件名称列号) & "." & Cells(当前行, 格式列号)
        If Not 已经处理文件.Exists(sw全名) Then '排除已处理
            Call sw初始化_获取指定文件(sw全名)
            配置名 = ""
            If Not 配置特定属性 Or Cells(当前行, 配置列) = "" Then
                Set cusPropMgr = swModel.Extension.CustomPropertyManager("")
                已经处理文件.Add sw全名, ""
            Else
                配置名 = Cells(当前行, 配置列)
'                Value = swModel.ShowConfiguration2(配置名)
'                Set config = swModel.GetActiveConfiguration
                Set config = swModel.GetConfigurationByName(配置名)
                Set cusPropMgr = config.CustomPropertyManager
            End If
            
            If swFileTYpe = 1 Then
                Dim sMatName                    As String
                Dim sMatDB                      As String
                sMatName = swModel.GetMaterialPropertyName2(配置名, sMatDB)
    '            Debug.Print "  Material = " & sMatName & " (" & sMatDB & ")"
                Cells(当前行, 当前材质列号).Select
                ActiveCell = sMatDB & "=" & sMatName
            End If
            
            Dim lRetVal As Long
            Dim ValOut As String
            Dim ResolvedValOut As String
            Dim wasResolved As Boolean
            
            
            For 列号 = 代号列号 To 长度列 - 1
                Cells(当前行, 列号).Select
                属性名 = Cells(表头行, 列号)
                lRetVal = cusPropMgr.Get5(属性名, False, ValOut, ResolvedValOut, wasResolved)
                ActiveCell = ValOut
    '            ActiveCell = ResolvedValOut
            Next 列号
            
    '        If 文件个数 > 8 Then SwApp.CloseDoc sw全名
            文件个数 = 文件个数 + 1
        End If '排除已处理
    End If
    End If '只处理无填充色的行==结束
Next 当前行
'MsgBox "done！", vbInformation

End Sub
Sub 属性cs()
Call sw初始化("")
    Set cusPropMgr = swModel.Extension.CustomPropertyManager("")
    propNames = cusPropMgr.GetNames
    If Not IsEmpty(propNames) Then
        For Each vName In propNames
            Debug.Print vName
'            custPropMgr.Get2 propName, Value, resolvedValue
'            If propName = "重量" Then Weight = resolvedValue
'            If propName = "DESCRIPTION" Then pName = resolvedValue
        Next vName
    End If
            
End Sub

Sub 粘贴属性到改名表()
    Set 属性字典 = CreateObject("Scripting.Dictionary")
    获取行列号
'    末行 = Cells(65536, 文件名称列号).End(3).Row
    For 当前行 = 首行 To 末行
        k = Cells(当前行, 文件名称列号) & Cells(当前行, 格式列号)
        Dim arr(1)
        arr(0) = Cells(当前行, 代号列号)
        arr(1) = Cells(当前行, 名称列号)
        属性字典(k) = arr
    Next
    
'    改名文件 = "D:\余魁\swvba\批量改名.xlsm"
    改名文件短名称 = "重命名文件.xlsm"
    改名文件 = "D:\余魁\swvba\" & 改名文件短名称
    On Error Resume Next
    Windows(改名文件短名称).Activate
    
    If Err.Number <> 0 Then
        Workbooks.Open Filename:=改名文件
        Err.Clear
    End If
    
    
    末行 = Cells(65536, Range("文件名称").Column).End(3).Row
    首行kk = Range("文件名称").Row + 1
    For 当前行 = 首行kk To 末行
        k = Cells(当前行, Range("文件名称").Column) & Cells(当前行, Range("文件格式").Column)
        If 属性字典.Exists(k) Then
            Cells(当前行, Range("代号").Column) = 属性字典(k)(0)
            Cells(当前行, Range("名称").Column) = 属性字典(k)(1)
        End If
    Next
    
End Sub