生成类似零部件

 

 

Public 禁止改变 As Boolean
Public 表头行 As Integer
Public 首行 As Integer
Public 末行 As Long
'
Public 首列 As Integer
Public 末列 As Integer

Public 配置列 As Integer

Public 长度列 As Integer
Public 边界框长度列 As Integer
Public 仅顶层 As Boolean
Sub 获取行列号()
    首列 = 1
    表头行 = Range("表头行").Row
    首行 = 表头行 + 1
'    Cells.EntireColumn.Hidden = False
    If Cells(首行, 首列) <> "" Then
        末行 = Cells(表头行, 首列).End(xlDown).Row
    Else
        末行 = 表头行
    End If
    末列 = Cells(表头行, 首列).End(xlToRight).Column
    
End Sub
Sub 清除()
    获取行列号
    If 末行 = 表头行 Then Exit Sub
    Cells(首行, 首列).Resize(末行 - 首行 + 1, 末列 - 首列 + 1).Select
    Selection.Interior.Pattern = xlNone
    Selection.ClearContents
    
    Cells(首行, 1).Select
End Sub
Sub Excel转字典(ByRef 字典)
    获取行列号
    For 当前行 = 表头行 + 1 To 末行
        Call Excel转字典单行(字典, 当前行)
    Next 当前行
End Sub
Sub Excel转字典单行(ByRef 字典, ByVal 当前行)
    If Not 字典.Exists(当前行) Then
        Set 字典(当前行) = CreateObject("Scripting.Dictionary")
        For 列号 = 首列 To 末列
            k = Cells(表头行, 列号)
            Set v = Cells(当前行, 列号)
            字典(当前行).Add k, v
        Next
    End If
End Sub

Sub cs()
    kk = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    Debug.Print kk
    
    kk = Range("A33").EntireRow.Hidden
    Debug.Print kk
    
    
End Sub
Sub 分割文件(ByVal sw三维文件字典)
    Set 表字典 = CreateObject("Scripting.Dictionary")
    
    获取行列号
    当前行 = 首行
    For Each k In sw三维文件字典.keys
        Call Excel转字典单行(表字典, 当前行)
        Set 行 = 表字典(当前行)
        FilePathName = k
        Call 拆分文件名(FilePathName)
        
        行("编号").Value = IIf(sw三维文件字典(k) <> "", sw三维文件字典(k), "0")
        行("模板路径").Value = FilePath '填写路径
        行("模板名称").Value = FilenameWHZ '填写文件名
        行("格式").Value = Right(Filename, 6) '填写类型
        
        行("新路径").Value = FilePath
        行("新名称").Value = FilenameWHZ
        
        当前行 = 当前行 + 1
    Next

End Sub
Sub 加前后缀(ByVal 位置)
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    For Each 行 In 表字典.Items
        If 位置 = "后缀" Then
            新名称 = 行("新名称") & Range("前后缀")
        Else
            新名称 = Range("前后缀") & 行("新名称")
        End If
        行("新名称").Value = 新名称
    Next
    
End Sub

Function 路径加斜杆(ByVal 原路径) As String
    最末字符 = Right(原路径, 1)
    If 最末字符 <> "\" Then
        路径加斜杆 = 原路径 & "\"
    Else
        路径加斜杆 = 原路径
    End If
End Function

Sub 获取模板信息()
    Call sw初始化("")
    FilePathName = swModel.GetPathName
    If swFileTYpe = 2 Then
        '====
    ElseIf swFileTYpe = 3 Then
'        Dim vDepend             As Variant
        vDepend = swApp.GetDocumentDependencies2(FilePathName, False, True, False)
        For i = 0 To (UBound(vDepend) - 1) / 2
            Debug.Print "    " + vDepend(2 * i) + " --> " + vDepend(2 * i + 1)
        Next i
        对应装配体 = vDepend(1)
        Call sw初始化_获取指定文件(对应装配体)
    End If

    Set sw三维文件字典 = CreateObject("Scripting.Dictionary")
    Set 子组件字典 = CreateObject("Scripting.Dictionary")
    Set 挑出子组件字典 = CreateObject("Scripting.Dictionary")

'    子组件字典.Add swModel.GetPathName, "00"
    Set config = swModel.GetActiveConfiguration
    配置名 = config.Name
    键 = swModel.GetPathName
    sw三维文件字典.Add 键, "00"
    If swFileTYpe = 2 Then
        Set 组件对象 = swModel
        上层编号 = ""
        Call 遍历组件特征(子组件字典, 组件对象, 上层编号, 挑出子组件字典)
    End If

    
    For Each k In 子组件字典
        键 = k.GetPathName
        编号 = 子组件字典(k)
        If 挑出子组件字典.Exists(k) Then
            On Error Resume Next
            sw三维文件字典.Add 键, 编号
        End If
    Next
    
    清除
    Call 分割文件(sw三维文件字典)

End Sub
Sub 遍历组件特征(ByRef 子组件字典, ByVal 组件对象, ByVal 上层编号, ByRef 挑出子组件字典)
    Set swFeat = 组件对象.FirstFeature
    Do While Not swFeat Is Nothing
        If swFeat.GetTypeName2 = "Reference" Or swFeat.GetTypeName2 = "SplitReference" Then 'SplitReference用于分割特征生成的装配体
            SelMgr.SuspendSelectionList
            numAdded = SelMgr.AddSelectionListObject(swFeat, selData)
            Set 子组件对象 = SelMgr.GetSelectedObject6(1, -1)
            Call 分析子组件(子组件字典, 子组件对象, 上层编号, 挑出子组件字典)
        ElseIf 含其中之一(swFeat.GetTypeName2, "Pattern|MirrorCompFeat") Then
            Set swSubFeat = swFeat.GetFirstSubFeature
            Do While Not swSubFeat Is Nothing
                Debug.Print swSubFeat.GetTypeName2&; "==" & swSubFeat.Name
                SelMgr.SuspendSelectionList
                numAdded = SelMgr.AddSelectionListObject(swSubFeat, selData)
                Set 子组件对象 = SelMgr.GetSelectedObject6(1, -1)
                Call 分析子组件(子组件字典, 子组件对象, 上层编号, 挑出子组件字典)
                Set swSubFeat = swSubFeat.GetNextSubFeature
            Loop
        End If
        Set swFeat = swFeat.GetNextFeature
    Loop

End Sub
Sub 分析子组件(ByRef 子组件字典, ByVal 子组件对象, ByVal 上层编号, ByRef 挑出子组件字典)
    FilePathName2 = 子组件对象.GetPathName
'    配置名 = 子组件对象.ReferencedConfiguration
'    键 = FilePathName2

    编号连接符 = IIf(上层编号 = "", "", ".")
    计数 = 计数 + 1
    本层编号 = 上层编号 & 编号连接符 & Format(计数, "00")
    子组件字典.Add 子组件对象, 本层编号
    nRefCount = 子组件对象.ListExternalFileReferencesCount
    If nRefCount > 0 Then
        On Error Resume Next
        挑出子组件字典.Add 子组件对象, ""
        Call 添加父组件(子组件对象, 挑出子组件字典)
    End If
    Call 类型判断(FilePathName2)
    If swFileTYpe = 2 Then
        Call 遍历组件特征(子组件字典, 子组件对象, 本层编号, 挑出子组件字典)
    Else
        '……
    End If

End Sub
Sub 添加父组件(ByVal 子组件对象, ByRef 挑出子组件字典)
    Set swParentComp = 子组件对象.GetParent
    If Not Nothing Is swParentComp Then
'        父键 = swParentComp.GetPathName
        On Error Resume Next
        挑出子组件字典.Add swParentComp, ""
        Call 添加父组件(swParentComp, 挑出子组件字典)
    End If
End Sub

Sub 热移动文件(ByRef 需移动文件字典, ByVal 第一个有效路径, ByRef 释放了锁定的文件)
    
        拟移动路径 = 第一个有效路径 & "移动文件"
        If "" <> Dir(拟移动路径, 16) Then
            a = Format(Date, "yymmdd")   '当前年月日
            b = Format(Time, "hhmmss")     '当前时间
            拟移动路径 = 拟移动路径 & "=" & a & "." & b
        End If
        VBA.MkDir (拟移动路径)
    
        Set fso = CreateObject("Scripting.FileSystemObject")
        For Each 新名称 In 需移动文件字典.keys
            新名称 = 需移动文件字典(新名称)
            If "" <> Dir(新名称) Then
                Call 拆分文件名(新名称)
                拟移动文件 = 拟移动路径 & "\" & Filename

                On Error Resume Next
                fso.MoveFile 新名称, 拟移动文件
                '释放锁定后再删除文件
                If Err.Number <> 0 Then
                    Set kkswModel = swApp.GetOpenDocumentByName(新名称)
                    nRetVal = kkswModel.ForceReleaseLocks
                    释放了锁定的文件.Add 新名称, kkswModel
                    Err.Clear
                    On Error Resume Next
                    fso.MoveFile 新名称, 拟移动文件
        
                    If Err.Number <> 0 Then
                        AppActivate ThisWorkbook.Name
                        MsgBox "移动打开的文件出错", vbInformation
                    End If
                End If
            End If
        Next
        Set fso = Nothing

End Sub

Sub 重载或替换文件(ByVal 释放了锁定的文件)
    For Each 新名称 In 释放了锁定的文件.keys
        Set kkswModel = 释放了锁定的文件(新名称)
        nRetVal重载 = kkswModel.ReloadOrReplace(False, 新名称, True)
        If nRetVal重载 <> 0 Then
            Debug.Print 新名称 & "重载有异常! nRetVal重载=" & nRetVal重载, vbInformation
       End If
    Next
End Sub

Sub 生成类似零部件(ByVal 包含工程图)
    Call sw初始化("")
    Set swPackAndGo = swModelDocExt.GetPackAndGo()
    swPackAndGo.IncludeDrawings = 包含工程图
    namesCount = swPackAndGo.GetDocumentNamesCount
    
    Set 需打包文件字典 = CreateObject("Scripting.Dictionary")
    
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Call Excel转字典(表字典)
    For Each 行 In 表字典.Items
        打包路径 = 路径加斜杆(行("新路径"))
        
        打包短名 = 行("新名称")
        拟打包全名 = 打包路径 & 打包短名 & "." & 行("格式")
        原全名 = 行("模板路径") & 行("模板名称") & "." & 行("格式")
        
        If (打包路径 = "" Or 打包短名 = "" Or 拟打包全名 = 原全名) Then
            MsgBox "路径或名称不能为空或者与模板相同，请修改！", vbInformation
            Exit Sub
        End If
        
        需打包文件字典.Add UCase(原全名), UCase(拟打包全名)
        If 包含工程图 Then
            同名工程图 = 打包路径 & 打包短名 & "." & "SLDDRW"
            原全名 = 行("模板路径") & 行("模板名称") & "." & "SLDDRW"
            需打包文件字典.Add UCase(原全名), UCase(同名工程图)
        End If
    Next
    
    Status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
    For i = 0 To UBound(pgFileNames)
        k = UCase(pgFileNames(i))
        If 需打包文件字典.Exists(k) Then
            pgFileNames(i) = 需打包文件字典(k)
        End If
    Next
    
    For Each k In 需打包文件字典.keys
        新名称 = 需打包文件字典(k)
        If "" <> Dir(新名称) Then
            某些文件已存在 = True
            Exit For
        End If
    Next
    
    Set 释放了锁定的文件 = CreateObject("Scripting.Dictionary")
    If 某些文件已存在 Then
        第一个有效路径 = Cells(首行, Range("新路径").Column)
        第一个有效路径 = 路径加斜杆(第一个有效路径)
        Call 热移动文件(需打包文件字典, 第一个有效路径, 释放了锁定的文件)
    End If
    
    Status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)
    statuses = swModelDocExt.SavePackAndGo(swPackAndGo)
    行号 = 首行
    For Each it In statuses
        Debug.Print it
        Set 行 = 表字典(行号)
        On Error Resume Next
        行("返回值").Select
        On Error Resume Next
        行("返回值").Value = it
        行号 = 行号 + 1
    Next
    Call 重载或替换文件(释放了锁定的文件)
    
End Sub
Sub 打包cs()
    Call sw初始化("")
    Dim swPackAndGo As SldWorks.PackAndGo
    Dim swModelDocExt As SldWorks.ModelDocExtension
    Set swModelDocExt = swModel.Extension
    Set swPackAndGo = swModelDocExt.GetPackAndGo()
    namesCount = swPackAndGo.GetDocumentNamesCount
    Status = swPackAndGo.GetDocumentNames(pgFileNames)
    Status = swPackAndGo.SetDocumentSaveToNames(pgFileNames)


End Sub

Sub 热覆盖()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Set 需覆盖文件字典 = CreateObject("Scripting.Dictionary")
    获取行列号
    Call Excel转字典(表字典, 首行, 末行)
    第一个有效路径 = ""
    i = 0
    For Each 行 In 表字典.Items
        行("文件名称").Select
        覆盖路径 = 路径加斜杆(行("新路径"))
        
        If Not (行("新路径") = "" Or 行("新名称") = "") Then
            拟覆盖全名 = 覆盖路径 & 行("新名称") & "." & 行("格式")
            原全名 = 行("文件路径") & 行("文件名称") & "." & 行("格式")
            If 拟覆盖全名 <> 原全名 Then
                If 第一个有效路径 = "" Then 第一个有效路径 = 覆盖路径
                需覆盖文件字典.Add 拟覆盖全名, 原全名
            End If
        End If
        i = i + 1
    Next
    
    Set swApp = CreateObject("SldWorks.Application")
    Set 释放了锁定的文件 = CreateObject("Scripting.Dictionary")
    Call 热移动文件(需覆盖文件字典, 第一个有效路径, 释放了锁定的文件)
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each k In 需覆盖文件字典.keys
        原全名 = 需覆盖文件字典(k)
        fso.CopyFile 原全名, k
    Next
    Set fso = Nothing
    
    Call 重载或替换文件(释放了锁定的文件)
    
End Sub

Sub 热覆盖()
    Set 表字典 = CreateObject("Scripting.Dictionary")
    Set 需覆盖文件字典 = CreateObject("Scripting.Dictionary")
    获取行列号
    Call Excel转字典(表字典, 首行, 末行)
    第一个有效路径 = ""
    i = 0
    For Each 行 In 表字典.Items
        行("文件名称").Select
        覆盖路径 = 路径加斜杆(行("新路径"))
        
        If Not (行("新路径") = "" Or 行("新名称") = "") Then
            拟覆盖全名 = 覆盖路径 & 行("新名称") & "." & 行("格式")
            原全名 = 行("文件路径") & 行("文件名称") & "." & 行("格式")
            If 拟覆盖全名 <> 原全名 Then
                If 第一个有效路径 = "" Then 第一个有效路径 = 覆盖路径
                需覆盖文件字典.Add 拟覆盖全名, 原全名
            End If
        End If
        i = i + 1
    Next
    
    Set swApp = CreateObject("SldWorks.Application")
    Set 释放了锁定的文件 = CreateObject("Scripting.Dictionary")
    Call 热移动文件(需覆盖文件字典, 第一个有效路径, 释放了锁定的文件)
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each k In 需覆盖文件字典.keys
        原全名 = 需覆盖文件字典(k)
        fso.CopyFile 原全名, k
    Next
    Set fso = Nothing
    
    Call 重载或替换文件(释放了锁定的文件)
    
End Sub

Public swApp As Object, swModel As Object, swFeatMgr As Object, swConfigMgr As Object
Public selData As Object, SelMgr As Object
Public lstatus As Long, lwarnings As Long, lErrors As Long
Public FilePathName, FilePath, Filename, FilenameWHZ As String
Public swFileTYpe As Integer
Public 坐标对象 As Object
Public swModelDocExt As SldWorks.ModelDocExtension
Public swPackAndGo As Object
Sub sw初始化(ByVal sw全名)
    Set swApp = CreateObject("SldWorks.Application") '启动SW
    If sw全名 = "" Then
        Set swModel = swApp.ActiveDoc
        sw全名 = swModel.GetPathName
    End If
    Call 拆分文件名(sw全名)
    Call 类型判断(sw全名)
    Set swModel = swApp.OpenDoc(sw全名, swFileTYpe) '开启档案
    Set swModel = swApp.ActivateDoc3(sw全名, False, 0, lErrors)
    swset
    FilePathName = swModel.GetPathName
End Sub
Sub sw初始化_获取指定文件(ByVal sw全名)
    Set swApp = CreateObject("SldWorks.Application") '启动SW
    Call 类型判断(sw全名)
    Set swModel = swApp.GetOpenDocumentByName(sw全名)
    If swModel Is Nothing Then
        Set swModel = swApp.OpenDoc(sw全名, swFileTYpe)
        swModel.Visible = False
    End If
    swset
End Sub
Sub 拆分文件名(ByVal FilePathName)
    FilePath = Left(FilePathName, InStrRev(FilePathName, "\")) '分解路径
    Filename = Right(FilePathName, Len(FilePathName) - Len(FilePath)) '分解文件名
    FilenameWHZ = Left(Filename, Len(Filename) - 7)
End Sub
Sub 类型判断(ByVal FilePathName)
    If UCase(Right(FilePathName, 3)) = "PRT" Then swFileTYpe = 1
    If UCase(Right(FilePathName, 3)) = "LFP" Then swFileTYpe = 1
    If UCase(Right(FilePathName, 3)) = "ASM" Then swFileTYpe = 2
    If UCase(Right(FilePathName, 3)) = "DRW" Then swFileTYpe = 3
    If UCase(Right(FilePathName, 6)) = "DRWDOT" Then swFileTYpe = 3
End Sub
Sub swset()
    Set swFeatMgr = swModel.FeatureManager
    Set SelMgr = swModel.SelectionManager
    Set selData = SelMgr.CreateSelectData
    Set swConfigMgr = swModel.ConfigurationManager
    Set swModelDocExt = swModel.Extension
End Sub
Sub 激活窗口()
    If Range("激活sw窗口方式") = "AppActivate" Then
        窗口标题集 = Array( _
        Filename & " - 图纸1", _
        Filename & " - 图纸1 *", _
        FilenameWHZ & " - 图纸1", _
        FilenameWHZ & " - 图纸1 *", _
        FilenameWHZ & " - 图纸2", _
        FilenameWHZ & " - 图纸2 *", _
        Filename, _
        Filename & " *", _
        FilenameWHZ, _
        FilenameWHZ & " *" _
        )
        For Each 窗口标题 In 窗口标题集
            On Error Resume Next
            AppActivate 窗口标题
            If Err.Number <> 0 Then
                Err.Clear
            Else
                Exit For
            End If
        Next
    Else
        sw全名 = swModel.GetPathName
        cmd = "explorer.exe """ & sw全名 & """"
        Shell cmd, 1
    End If
End Sub
Function 映射特征类型(ByVal 原特征类型) As String
    Set d = CreateObject("scripting.dictionary")
    d.Add "ICE", "BODYFEATURE"
    d.Add "Chamfer", "BODYFEATURE"
    d.Add "ProfileFeature", "SKETCH"
    d.Add "DeleteBody", "BODYFEATURE"
    d.Add "BaseBody", "BODYFEATURE"
    d.Add "Cut", "BODYFEATURE"
    d.Add "LPattern", "BODYFEATURE"
    d.Add "HoleWzd", "BODYFEATURE"
    d.Add "Reference", "COMPONENT"
    d.Add "MirrorPattern", "BODYFEATURE"
    d.Add "LocalLPattern", "COMPPATTERN"
    
    If d.Exists(原特征类型) Then
        映射特征类型 = d(原特征类型)
    End If
End Function
Sub 映射图纸大小(ByRef 映射字典)
    Set 映射字典("swto俗称") = CreateObject("scripting.dictionary")
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA3size, "A3"
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA2size, "A2"
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA4sizeVertical, "A4"
    映射字典("swto俗称").Add swDwgPaperSizes_e.swDwgPaperA4size, "A4横"
    
    Set 映射字典("俗称tosw") = CreateObject("scripting.dictionary")
    For Each k In 映射字典("swto俗称")
        映射字典("俗称tosw").Add 映射字典("swto俗称")(k), k
    Next
End Sub
Sub 激活窗口cs()
    Set 窗口标题集 = CreateObject("Scripting.Dictionary")
    窗口标题集.Add "00_kz", ""
    
    For Each 窗口标题 In 窗口标题集.keys
        On Error Resume Next
        AppActivate 窗口标题
        If Err.Number <> 0 Then
            Err.Clear
        Else
            Exit For
        End If
    Next
End Sub
Sub 获取工程图对象模型()
    If swFileTYpe = 3 Then
'        Dim vDepend             As Variant
        vDepend = swApp.GetDocumentDependencies2(FilePathName, False, True, False)
        For i = 0 To (UBound(vDepend) - 1) / 2
            Debug.Print "    " + vDepend(2 * i) + " --> " + vDepend(2 * i + 1)
        Next i
        对应模型 = vDepend(1)
        Call sw初始化_获取指定文件(对应模型)
    End If

End Sub