当前位置：首页>Excel>SolidWorks*Excel+VBA-文件格式转换-其二(完整代码,量大管饱)

SolidWorks*Excel+VBA-文件格式转换-其二(完整代码,量大管饱)

2026-10-25 02:51:49

接上回，这次放出完整代码结构，咱们自顶向下挨个索引。

友情提醒：内容极其枯燥，让人极度不适，现在退出文章还来得及

既然上车，那就别走了，车门已焊死，来折磨下自己的大脑

1、文件格式转换主程序：

Sub OutputFlies() '导出dwg/dxf/pdf/stp/x_t/igsDim ReturnVal(), NullVal(1), SwDrw As DrawingDoc, SwMdoc As ModelDoc2, OutPutfs As StringDim k As Integer, posn As Long, Results1 As String, Results2 As StringDim Outpt2D As Boolean, Outpt3D As Boolean    Outpt2D = OutPutFileTypes.chk_DWG Or OutPutFileTypes.chk_DXF Or OutPutFileTypes.chk_PDF    Outpt3D = OutPutFileTypes.chk_STEP Or OutPutFileTypes.chk_X_T Or OutPutFileTypes.chk_IGS    If Not (Outpt2D Or Outpt3D) Then        MsgBox "未勾选任何输出文件类型!", vbExclamation, "不正经的机械仙人"        Exit Sub    End If    With ThisWorkbook.ActiveSheet        If myselcondi Then            swApp.CloseAllDocuments (True): SetGolDic            For k = 1 To Selnumber                ProcessBarUpdater k, Selnumber, "正在转换输出：", "共" & Selnumber & "个，第" & k & "个 ..."                posn = Selarray(k)                OutPutfs = .Cells(posn, PropTitDicA("文件位置")) & "\" & .Cells(posn, PropTitDicA("SW模型文件名")) '此时先不含后缀                '导出2D图                If Outpt2D Then                    ReturnVal = OpenDsFiles_next("slddrw", posn, True)                    Results1 = ReturnVal(1)                Else                    ReturnVal = NullVal                End If                If VarType(ReturnVal(0)) <> vbEmpty Then Set SwDrw = ReturnVal(0)                If Results1 = "SW工程图√" Then                    Results1 = ""                    If OutPutFileTypes.chk_DWG Then                        SwDrw.SaveAs2 OutPutfs & ".dwg", swSaveAsCurrentVersion, True, True                        Results1 = Results1 & "dwg;"                    End If                    If OutPutFileTypes.chk_DXF Then                        SwDrw.SaveAs2 OutPutfs & ".dxf", swSaveAsCurrentVersion, True, True                        Results1 = Results1 & "dxf;"                    End If                    If OutPutFileTypes.chk_PDF Then                        SwDrw.SaveAs2 OutPutfs & ".pdf", swSaveAsCurrentVersion, True, True                        Results1 = Results1 & "pdf;"                    End If                End If                If Not SwDrw Is Nothing Then                    swApp.QuitDoc SwDrw.GetPathName: Set SwDrw = Nothing                End If                Erase ReturnVal                '导出3D图                If Outpt3D Then                    ReturnVal = OpenDsFiles_next("model", posn)                    Results2 = ReturnVal(1)                Else                    ReturnVal = NullVal                End If                If VarType(ReturnVal(0)) <> vbEmpty Then Set SwMdoc = ReturnVal(0)                If Results2 = "SW模型√" Then                    Results2 = ""                    If OutPutFileTypes.chk_STEP Then                        SwMdoc.SaveAs2 OutPutfs & ".step", swSaveAsCurrentVersion, True, True                        Results2 = Results2 & "step;"                    End If                    If OutPutFileTypes.chk_X_T Then                        SwMdoc.SaveAs2 OutPutfs & ".x_t", swSaveAsCurrentVersion, True, True                        Results2 = Results2 & "x_t;"                    End If                    If OutPutFileTypes.chk_IGS Then                        SwMdoc.SaveAs2 OutPutfs & ".igs", swSaveAsCurrentVersion, True, True                        Results2 = Results2 & "igs;"                    End If                End If                If Not SwMdoc Is Nothing Then                    swApp.QuitDoc SwMdoc.GetPathName: Set SwMdoc = Nothing                End If                Erase ReturnVal                .Cells(posn, PropTitDicA("操作结果")) = Results1 & Results2: Results1 = "": Results2 = ""            Next        Else            MsgBox "未选择正确行,程序结束!", vbExclamation, "不正经的机械仙人"        End If    End With    Err.Clear    Application.StatusBar = FalseEnd Sub

主程序调用的第一个变量OutPutFileTypes，在全局中预先定义（上篇已说）

Public Type chkBoxs    chk_DWG As Boolean    chk_DXF As Boolean    chk_PDF As Boolean    chk_STEP As Boolean    chk_X_T As Boolean    chk_IGS As BooleanEnd TypePublic OutPutFileTypes As chkBoxs

1.1、接下来是主程序调用的第一个子过程myselcondi()，用于处理选择操作结果

Function myselcondi() As Boolean '处理选择操作Dim MySelection() As IntegerDim i As Long, j As LongDim Selarea As Range, Selrange As Range    ReDim MySelection(1 To 1000) As Integer    On Error Resume Next    Err.Clear: j = 1000    Selnumber = 1    For Each Selarea In Selection.Areas        For Each Selrange In Selarea.Rows            If Not (Selrange.Hidden) And Selrange.Row > 2 Then                MySelection(Selnumber) = Selrange.Row                Selnumber = Selnumber + 1                If Selnumber > j - 2 Then                    j = j + 1000                    ReDim Preserve MySelection(1 To j)                End If            End If        Next    Next    Selnumber = Selnumber - 1    If Selnumber = 0 Then        myselcondi = False: Exit Function    End If    ReDim Preserve MySelection(1 To Selnumber) As Integer: Selarray = MySelection    For i = 1 To Selnumber        MySelection(i) = WorksheetFunction.Small(Selarray, i)    Next    Selarray = MySelection: myselcondi = TrueEnd Function

这个子过程调用了两个全局变量，存储选择的行表信息

Public Selarray As Variant, Selnumber As Integer '选择的行数

1.2、继续，接下来是第二个子过程SetGolDic()，用来设置全局字典。

Function SetGolDic() '给全局字典赋值Dim i As Integer, Swftypes()    Swftypes = Array(Array(".SLDPRT", swDocPART), Array(".SLDASM", swDocASSEMBLY), Array(".SLDDRW", swDocDRAWING))    With ThisWorkbook.ActiveSheet        PropTitDicA.RemoveAll: PropTitDicB.RemoveAll: SwFtypeDic.RemoveAll        i = 1        Do While .Cells(1, i) <> ""            If .Cells(1, i).Interior.Color <> 10498160 Then '紫色底色为通用属性                PropTitDicA.Add .Cells(1, i).Value, i            Else                PropTitDicB.Add .Cells(1, i).Value, i            End If            i = i + 1        Loop        For i = 0 To UBound(Swftypes)            SwFtypeDic.Add Swftypes(i)(0), Swftypes(i)(1)        Next    End WithEnd Function

同样，这个过程也是用到3个全局字典变量，用于索引表头，文件类型

Public PropTitDicA As New Dictionary '非通用化属性表头Public PropTitDicB As New Dictionary '通用化一般属性表头Public SwFtypeDic As New Dictionary 'SW文件类型

1.3、接下来，就是我们的进度条老朋友ProcessBarUpdater()，就不多说了。

Function ProcessBarUpdater(CurNum As Integer, TotalNum As Integer, strTopic As String, endTopic As String)Dim intNumberOfall As Integer, intCurrentOfBars As Integer    If CurNum = 1 Then Application.StatusBar = "就绪"    intNumberOfall = 35 '总显示长度    intCurrentOfBars = (CurNum / TotalNum) * intNumberOfall    Application.StatusBar = strTopic & "「" & String(intCurrentOfBars, Chr(47)) & String(intNumberOfall - intCurrentOfBars, Chr(45)) & "」" & endTopicEnd Function

1.4、然后，就到轮了重量级选手OpenDsFiles_next()，打开文件。

这段程序做了通用化处理，可以被不同程序段调用，返回一个2元素一维数组，第一个元素存文件对象，第二个元素存处理结果信息。

Function OpenDsFiles_next(DsFtype As String, posn As Long, Optional drwchk As Boolean) As Variant '打开文件子程序Dim DsFname As String, SwErr As Long, SwFileType As Long, OpFile As Variant, ReturnVal(1)    With ThisWorkbook.ActiveSheet        Select Case True        Case DsFtype = "model"            DsFname = .Cells(posn, PropTitDicA("文件位置")) & "\" & .Cells(posn, PropTitDicA("SW模型文件名")) & .Cells(posn, PropTitDicA("扩展名"))            If Dir(DsFname) = "" Then                ReturnVal(1) = "无SW模型文件!"            Else                SwFileType = SwFtypeDic(UCase(.Cells(posn, PropTitDicA("扩展名"))))                Set OpFile = swApp.ActivateDoc2(DsFname, False, SwErr)                If OpFile Is Nothing Then Set OpFile = swApp.OpenDoc(DsFname, SwFileType)                If OpFile Is Nothing Then                    ReturnVal(1) = "打开SW模型失败!" '重名或高版本                Else                    Set ReturnVal(0) = OpFile                    ReturnVal(1) = "SW模型√"                End If                Set OpFile = Nothing            End If        Case DsFtype = "slddrw"            DsFname = .Cells(posn, PropTitDicA("文件位置")) & "\" & .Cells(posn, PropTitDicA("SW模型文件名")) & ".SLDDRW"            If Dir(DsFname) = "" Then                ReturnVal(1) = "无SW工程图!"            Else                SwFileType = swDocDRAWING                Set OpFile = swApp.ActivateDoc2(DsFname, False, SwErr)                If OpFile Is Nothing Then Set OpFile = swApp.OpenDoc(DsFname, SwFileType)                If OpFile Is Nothing Then                    ReturnVal(1) = "打开SW工程图失败!" '重名或高版本                Else                    OpFile.ViewFullPage                    Set ReturnVal(0) = OpFile                    If drwchk Then ReturnVal(1) = ChkDrwSlt(OpFile) '执行检查                End If                Set OpFile = Nothing            End If        Case Else            DsFname = .Cells(posn, PropTitDicA("文件位置")) & "\" & .Cells(posn, PropTitDicA("SW模型文件名")) & "." & DsFtype            If Dir(DsFname) = "" Then                ReturnVal(1) = "无" & UCase(DsFtype) & "文件!"            Else                If Shell("explorer " & DsFname, vbNormalFocus) = 0 Then                    ReturnVal(1) = UCase(DsFtype) & "打开失败!"                Else                    ReturnVal(1) = UCase(DsFtype) & "√"                End If            End If        End Select    End With    OpenDsFiles_next = ReturnValEnd Function

1.4.1、这段程序也有个子过程，ChkDrwSlt()，检查工程图，工程图如果有问题，那必然是万万不能输出的。

FunctionChkDrwSlt(SwDrw As Variant)AsString '检查工程图：比例，配置等Dim i As Integer, LinkedScale As Long, ViewLinkedConfi As Long, BOMLinkedConfig As Long, ShtNames, Views, SubViewDim BomFeat As BomFeature, mSwDrw As ModelDoc2, BomConfigNms, ConfigVis, viewpt    ShtNames = SwDrw.GetSheetNames: Set mSwDrw = SwDrw    For i = 0 To UBound(ShtNames)        Views = SwDrw.Sheet(ShtNames(i)).GetViews        If VarType(Views) = vbEmpty Then GoTo Next1        For Each SubView In Views            viewpt = SubView.Position            If viewpt(0) * viewpt(1) = 0 Then GoTo Next2 '调色板视图，x/y位置有一个是0            If SubView.GetBaseView Is Nothing Then '主视图没有基础视图                If Not SubView.UseSheetScale Then LinkedScale = LinkedScale + 1            Else                If Not SubView.UseParentScale And SubView.Type <> swDrawingDetailView _                   And InStr(SubView.Name, "轴测") = 0 _                   Then LinkedScale = LinkedScale + 1 '视图比例未关联父视图,不考虑局部视图、轴测图                If Not SubView.LinkParentConfiguration And _                   (SubView.Type = swDrawingAuxiliaryView Or SubView.Type = swDrawingProjectedView) _                   Then ViewLinkedConfi = ViewLinkedConfi + 1            End If            '检查明细表配置与关联视图是否一致            If SubView.GetKeepLinkedToBOM Then                mSwDrw.Extension.SelectByID2 SubView.GetKeepLinkedToBOMName, "BOMFEATURE", 0, 0, 0, False, 0, Nothing, 0                Set BomFeat = mSwDrw.SelectionManager.GetSelectedObject5(1)                mSwDrw.ClearSelection2 True                BomConfigNms = BomFeat.GetConfigurations(True, ConfigVis)                If BomConfigNms(0) <> SubView.ReferencedConfiguration Then BOMLinkedConfig = BOMLinkedConfig + 1                Set BomFeat = Nothing: Erase BomConfigNms: Erase ConfigVis            End IfNext2:  Next        Erase ViewsNext1:    Next    Erase ShtNames: Set mSwDrw = Nothing    If LinkedScale + ViewLinkedConfi + BOMLinkedConfig = 0 Then        ChkDrwSlt = "SW工程图√"    Else        If LinkedScale > 0 Then ChkDrwSlt = ChkDrwSlt & "视图比例×;"        If ViewLinkedConfi > 0 Then ChkDrwSlt = ChkDrwSlt & "视图配置×;"        If BOMLinkedConfig > 0 Then ChkDrwSlt = ChkDrwSlt & "明细表配置×;"    End IfEnd Function

到这里为止，就是程序结构全过程。

乍一看，像屎山......再看，作为作者，都不想去多看一眼

值得一提的是这几个字典变量贯穿全文，几乎所有程序段都有它们的身影。

本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。

SolidWorks*Excel+VBA-文件格式转换-其二(完整代码,量大管饱)

89页PPT|企业供应商协同管理解决方案

各类灭火器的使用方法及场景PPT