接上回，这次放出完整代码结构，咱们自顶向下挨个索引。友情提醒：内容极其枯燥，让人极度不适，现在退出文章还来得及
既然上车，那就别走了，车门已焊死，来折磨下自己的大脑
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
乍一看，像屎山......再看，作为作者，都不想去多看一眼
值得一提的是这几个字典变量贯穿全文，几乎所有程序段都有它们的身影。
