Imports Inventor Imports Inventor.SelectionFilterEnum Imports Inventor.DocumentTypeEnum Imports Inventor.DrawingViewTypeEnum Imports Inventor.PropertyTypeEnum Imports Inventor.BOMStructureEnum Imports Inventor.IOMechanismEnum Imports System.Windows.Forms Imports Inventor.PrintOrientationEnum Imports System.Text Imports System.Collections.ObjectModel Module InventorBasic Public Structure StockNumPartName Dim IsGet As Boolean Dim StockNum As String Dim PartName As String Dim PartNum As String End Structure Public ThisApplication As Inventor.Application 'Public ThisApprenticeApp As Inventor.ApprenticeServerComponent '学徒服务器 Public WithEvents ThisApplicationEvents As ApplicationEvents Public ClientID As String Public DWG As String = ".dwg" Public IAM As String = ".iam" Public IPT As String = ".ipt" Public IDW As String = ".idw" Public ContentCenterFiles As String '零件库文件夹 Public IsAutoSetPartName As Boolean 'true 为进行中，false则退出进程 Public Map_StochNum As String '映射图号 Public Map_PartName As String '映射文件名 Public Map_PartNum As String '映射存货编码 Public Map_Mir_StochNum As String '映射对称件图号 Public Map_Mir_PartName As String '映射对称件文件名 Public Map_DrawingScale As String '映射比例 Public Map_Mass As String '映射质量 Public Map_PrintDay As String '映射打印时间 Public IsOpenPrint As String '设置打印时间后是否进入打印预览 Public IsDayAndName As String '同时签字 Public EngineerName As String '工程师 Public BOMTiTle As String '导出BOM用的项目 Public Mass_Accuracy As String '质量精度 Public Area_Accuracy As String '面积精度 Public IsSetDrawingScale As String '打开工程图时是否写 比例 到ipro 是赋值为1 Public IsSetMass As String '打开工程图时是否写 质量 到ipro 是赋值为1 Public CheckUpdate As String '启动检查更新 Public TotalItem As Integer 'BOM序号 Public OPosition(9) As Point '点 Public TempPoint(9) As SketchPoint '临时绘制的点 Public IsShowUpdateMsg As Boolean '检查更新时是否显示是最新版本的msgbox '------------------------------------------------------------------------------- Public Sub SetStatusBarText(Optional ByVal StatusBarText As String = "就绪") ThisApplication.StatusBarText = StatusBarText End Sub 'inventor是否打开文件,未打开文件返回false Public Function IsInventorOpenDoc() As Boolean Try If ThisApplication.FileManager.Files.Count = 0 Then MsgBox("未打开文件", MsgBoxStyle.Critical) Return False Exit Function Else Return True End If Catch ex As Exception MsgBox(ex.Message) End Try End Function '更改零件/部件文件名 Public Function RenameAssPartDocumentName(ByVal oInventorDocument As Inventor.Document, ByVal OldComponentOccurrence As ComponentOccurrence, ByVal NewFileName As String) As Boolean Dim OldFullFileName As String '被替换的旧文件全名 Dim OldFileName As String '被替换的旧文件仅文件名 OldFullFileName = OldComponentOccurrence.ReferencedDocumentDescriptor.FullDocumentName OldFileName = GetFileNameInfo(OldFullFileName).ONlyName If IsFileExsts(OldFullFileName) = False Then MsgBox("文件： " & OldFullFileName & "不存在！", MsgBoxStyle.Critical, "修改文件名") Return True Exit Function End If 'Dim oOccDef As PartComponentDefinition 'oOccDef = OldOcc.Definition 'If Not oOccDef.IsContentMember = False Then '跳过零件库文件 ' MsgBox(OldFullFileName & "为零件库文件", MsgBoxStyle.Information) ' 'OldInventorDoc.Close() ' Return False ' Exit Function 'End If If InStr(OldFullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 MsgBox("无法修改资源中心文件： " & OldFullFileName, MsgBoxStyle.Information, "修改文件名") 'OldInventorDoc.Close() Return True Exit Function End If Select Case OldComponentOccurrence.DefinitionDocumentType Case kPartDocumentObject, kAssemblyDocumentObject '选择的是部件或零件 Dim NewFullFileName As String '新文件全名 '新图号 'frmain.Focus() '取消输入 If NewFileName = "" Then Return True Exit Select End If '新旧文件名一致 If OldFileName = NewFileName Then MsgBox("未重新命名 ", MsgBoxStyle.Information, "修改文件名") Return True Exit Select End If '替换旧文件全名为新文件全名 NewFullFileName = GetNewFileName(OldFullFileName, NewFileName) '检查新文件是否存在 If IsFileExsts(NewFullFileName) = True Then Select Case MsgBox("存在文件：" & NewFullFileName & vbCrLf & "是-直接替换" & vbCrLf & "否-重新生成替换" & vbCrLf & "取消-退出重新命名 ", MsgBoxStyle.Information + MsgBoxStyle.YesNoCancel) Case MsgBoxResult.Yes '直接用新文件替换 '全部替换为新文件 If MsgBox("是否替换全部零件？", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.SystemModal) = MsgBoxResult.Yes Then OldComponentOccurrence.Replace(NewFullFileName, True) Else OldComponentOccurrence.Replace(NewFullFileName, False) End If Return True Case MsgBoxResult.No '重新另存为新文件，再替换 Case MsgBoxResult.Cancel '取消退出 Return False End Select End If '打开旧文件,不显示 Dim OldInventorDocument As Inventor.Document OldInventorDocument = ThisApplication.Documents.Open(OldFullFileName, False) '另存为新文件 OldInventorDocument.SaveAs(NewFullFileName, True) '关闭旧图 OldInventorDocument.Close() '全部替换为新文件 If MsgBox("是否替换全部零件？", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.SystemModal + MsgBoxStyle.DefaultButton1) = MsgBoxResult.Yes Then OldComponentOccurrence.Replace(NewFullFileName, True) Else OldComponentOccurrence.Replace(NewFullFileName, False) End If ThisApplication.Documents.ItemByName(OldFullFileName).Close() '后台打开文件，修改ipro oInventorDocument = ThisApplication.Documents.Open(NewFullFileName, False) '打开文件，不显示 SetDocumentIpropertyFromFileName(oInventorDocument, True) '设置Iproperty，打开文件后需关闭 Dim IsSaveAsOld As MsgBoxResult IsSaveAsOld = MsgBox("是否更改原文件为备份文件，扩展名增加 .old ？", MsgBoxStyle.YesNo + MsgBoxStyle.DefaultButton2, "备份文件") '是否有对应的工程图文件，同时复制后修改文件名和模型链接 Dim OldIdwFullFileName As String OldIdwFullFileName = GetNewExtensionFileName(OldFullFileName, ".idw") '旧工程图 Dim TempFullFileName As String '更改旧模型文件的名字存档 If IsFileExsts(OldIdwFullFileName) = True Then Dim NewIdwFullFileName As String NewIdwFullFileName = GetNewExtensionFileName(NewFullFileName, ".idw") '新工程图 FileSystem.FileCopy(OldIdwFullFileName, NewIdwFullFileName) '复制为新工程图 'MsgBox("找到有对应的旧工程图，生成新的工程图，将打开，请链接到文件：" & vbCrLf & NewFullFileName & vbCrLf & "该文件名已复制，粘贴到对话框即可。", MsgBoxStyle.Information) 'Windows.Forms.Clipboard.SetText(NewFullFileName) 'ThisApplication.Documents.Open(NewIdwFullFileName, False) '打开新的工程图，使其手动链接零件或部件 'ThisApplication.Documents.ItemByName(NewIdwFullFileName).Save2() '保存链接并关闭工程图 'ThisApplication.Documents.ItemByName(NewIdwFullFileName).Close() oInventorDocument = ThisApplication.Documents.Open(NewIdwFullFileName, False) '打开文件，不显示 oInventorDocument.ReferencedDocumentDescriptors(1).ReferencedFileDescriptor.ReplaceReference(NewFullFileName) oInventorDocument.Save2() oInventorDocument.Close() If IsSaveAsOld = MsgBoxResult.Yes Then TempFullFileName = OldIdwFullFileName & ".old" '暂时更改旧工程图文件的名字存档 ReFileName(OldIdwFullFileName, TempFullFileName) 'ReFileName(TempFullFileName, OldFullFileName) '恢复旧零件或部件文件名 End If End If If IsSaveAsOld = MsgBoxResult.Yes Then TempFullFileName = OldFullFileName & ".old" ReFileName(OldFullFileName, TempFullFileName) End If Return True Case MsgBox("选择的文件不是零件或部件", MsgBoxStyle.Information) Return False End Select End Function '更改镜像零件文件名 Public Function RenameMirrorAssPartDocumentName(ByVal oInventorDocument As Inventor.Document, ByVal OldComponentOccurrence As ComponentOccurrence, ByVal NewFileName As String) As Boolean Dim OldFullFileName As String '被替换的旧文件全名 Dim OldFileName As String '被替换的旧文件仅文件名 OldFullFileName = OldComponentOccurrence.ReferencedDocumentDescriptor.FullDocumentName OldFileName = GetFileNameInfo(OldFullFileName).ONlyName If IsFileExsts(OldFullFileName) = False Then MsgBox(OldFullFileName & "不存在！", MsgBoxStyle.Critical) Return True Exit Function End If 'Dim oOccDef As PartComponentDefinition 'oOccDef = OldOcc.Definition 'If Not oOccDef.IsContentMember = False Then '跳过零件库文件 ' MsgBox(OldFullFileName & "为零件库文件", MsgBoxStyle.Information) ' 'OldInventorDoc.Close() ' Return False ' Exit Function 'End If If InStr(OldFullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 MsgBox(OldFullFileName & "为零件库文件", MsgBoxStyle.Information) 'OldInventorDoc.Close() Return True Exit Function End If 'Select Case OldOcc.DefinitionDocumentType ' Case kPartDocumentObject, kAssemblyDocumentObject '选择的是部件或零件 Dim NewFullFileName As String '新文件全名 'Dim NewFileName As String '新文件仅文件名 '新图号 'frmain.Focus() 'NewFileName = InputBox("重命名 " & OldFullFileName, "重命名", OldFileName) '输入新文件名 ''取消输入 'If NewFileName = "" Then ' Return True ' Exit Select 'End If '替换旧文件全名为新文件全名 NewFullFileName = GetNewFileName(OldFullFileName, NewFileName) '检查新文件是否存在 If IsFileExsts(NewFullFileName) = True Then Select Case MsgBox("存在文件：" & NewFullFileName & " ，是-直接替换 否-重新生成替换 取消-退出重新命名 ", MsgBoxStyle.Information + MsgBoxStyle.YesNoCancel) Case MsgBoxResult.Yes '直接用新文件替换 '全部替换为新文件 If MsgBox("是否替换全部零件？", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.SystemModal) = MsgBoxResult.Yes Then OldComponentOccurrence.Replace(NewFullFileName, True) Else OldComponentOccurrence.Replace(NewFullFileName, False) End If Return True Case MsgBoxResult.No '重新另存为新文件，再替换 Case MsgBoxResult.Cancel '取消退出 Return False End Select End If '打开旧文件,不显示 Dim OldInventorDocument As Inventor.Document OldInventorDocument = ThisApplication.Documents.Open(OldFullFileName, False) '基础文件 Dim ReferencedFullFileName As String Dim ReferencedFullFileNameTemp As String ReferencedFullFileName = OldInventorDocument.ReferencedDocuments(1).FullFileName ReferencedFullFileNameTemp = ReferencedFullFileName & ".old" '重命名基础文件 ReFileName(ReferencedFullFileName, ReferencedFullFileNameTemp) '另存为新文件 OldInventorDocument.SaveAs(NewFullFileName, True) '关闭旧图 OldInventorDocument.Close() '全部替换为新文件 If MsgBox("是否替换全部零件？", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.SystemModal) = MsgBoxResult.Yes Then MsgBox("选择 " & NewFullFileName & " 的基础文件！") OldComponentOccurrence.Replace(NewFullFileName, True) Else MsgBox("选择 " & NewFullFileName & " 的基础文件！") OldComponentOccurrence.Replace(NewFullFileName, False) End If ThisApplication.Documents.ItemByName(OldFullFileName).Close() '后台打开文件，修改ipro oInventorDocument = ThisApplication.Documents.Open(NewFullFileName, False) '打开文件，不显示 SetDocumentIpropertyFromFileName(oInventorDocument, True) '设置Iproperty，打开文件后需关闭 '还原早一个版本的文件() ReFileName(ReferencedFullFileNameTemp, ReferencedFullFileName) Return True ' Case MsgBox("选择的文件不是零件或部件", MsgBoxStyle.Information) 'Return False 'End Select End Function '根据文件名提取到iproperty （ 文件对象 ； 文件是否需打开，打开的文件用后要关闭） Public Function SetDocumentIpropertyFromFileName(ByVal oInventorDocument As Inventor.Document, ByVal IsNeedClose As Boolean) As Boolean Dim FullFileName As String '当前文件全名 Dim FileName As String FullFileName = oInventorDocument.FullFileName FileName = GetFileNameInfo(FullFileName).ONlyName If InStr(FullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 MsgBox("无法修改资源中心文件： " & FullFileName, MsgBoxStyle.Information, "修改iProperty") Return True Exit Function End If Dim StockNumPartName As StockNumPartName StockNumPartName = GetStockNumPartName(FullFileName) Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = oInventorDocument.PropertySets oPropSet = oPropSets.Item(3) For Each propitem In oPropSet '设置iproperty Select Case propitem.DisplayName Case Map_PartName If StockNumPartName.PartName <> "" Then propitem.Value = StockNumPartName.PartName End If Case Map_StochNum If StockNumPartName.StockNum <> "" Then propitem.Value = StockNumPartName.StockNum End If Case Map_PartNum If StockNumPartName.PartNum <> "" Then propitem.Value = StockNumPartName.PartNum End If Case "描述" ' propitem.Value = "" End Select Next 999: '是否为打开的文件，是的话就关闭 If IsNeedClose = True Then oInventorDocument.Close(True) End If Return True End Function '修改部件包含文件的iProperty （ 部件文件对象 ； 文件是否需打开，打开的文件用后要关闭） Public Function SetDocumentsInAssIpropertyFromFileName(ByVal oAssemblyDocument As AssemblyDocument, ByVal IsNeedClose As Boolean) As Boolean ' 获取所有引用文档 Dim FirstLevelOnly As Boolean Select Case MsgBox("修改模式：是-仅修改第一级零件 否-修改所有级别零件 ", MsgBoxStyle.Question + MsgBoxStyle.YesNoCancel, "修改模式") Case MsgBoxResult.Yes 'RefDocs = AsmDoc.ReferencedDocuments FirstLevelOnly = True Case MsgBoxResult.No 'RefDocs = AsmDoc.AllReferencedDocuments FirstLevelOnly = False Case Else Return True End Select '============================================================================================== '基于bom结构化数据，可跳过参考的文件 ' Set a reference to the BOM Dim oBOM As BOM oBOM = oAssemblyDocument.ComponentDefinition.BOM oBOM.StructuredViewEnabled = True 'Set a reference to the "Structured" BOMView Dim oBOMView As BOMView '获取结构化的bom页面 For Each oBOMView In oBOM.BOMViews If oBOMView.ViewType = BOMViewTypeEnum.kStructuredBOMViewType Then '遍历这个bom页面 QueryBOMRowToSetiPro(oBOMView.BOMRows, FirstLevelOnly) End If Next '============================================================================================== Return True End Function '遍历BOM结构，查询row文件修改ipro Public Sub QueryBOMRowToSetiPro(ByVal oBOMRows As BOMRowsEnumerator, ByVal FirstLevelOnly As Boolean) Dim i As Integer Dim iStepCount As Short iStepCount = oBOMRows.Count 'Create a new ProgressBar object. Dim oProgressBar As Inventor.ProgressBar oProgressBar = ThisApplication.CreateProgressBar(False, iStepCount, "当前文件： ") For i = 1 To oBOMRows.Count ' Get the current row. Dim oBOMRow As BOMRow oBOMRow = oBOMRows.Item(i) Dim oFullFileName As String oFullFileName = oBOMRow.ReferencedFileDescriptor.FullFileName '测试文件 Debug.Print(oFullFileName) ' Set the message for the progress bar oProgressBar.Message = oFullFileName If IsFileExsts(oFullFileName) = False Then '跳过不存在的文件 GoTo 999 End If If InStr(oFullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 GoTo 999 End If Dim oInventorDocument As Inventor.Document oInventorDocument = ThisApplication.Documents.Open(oFullFileName, False) '打开文件，不显示 SetDocumentIpropertyFromFileName(oInventorDocument, True) '设置Iproperty,打开文件后需关闭 '遍历下一级 If (Not oBOMRow.ChildRows Is Nothing) And FirstLevelOnly = False Then Call QueryBOMRowToSetiPro(oBOMRow.ChildRows, FirstLevelOnly) End If 999: oProgressBar.UpdateProgress() Next oProgressBar.Close() End Sub '自动生成零件图号（部件文件对象；进度条） Public Function AutoSetPartNumber(ByVal oAssemblyDocument As AssemblyDocument) As Boolean 'With ProgressBar ' .Minimum = 0 ' '.Maximum = AsmDoc.ReferencedDocuments.Count ' .Value = 0 'End With Dim FullFileName As String '当前部件全名 Dim FileName As String '当前部件名 Dim BasicNumber As String '当前部件图号 '部件全文件名 和 仅文件名 FullFileName = oAssemblyDocument.FullFileName FileName = GetFileNameInfo(FullFileName).ONlyName 'Dim i As Integer 'Dim s As String ''获取汉字的位置 'i = 1 'Do ' s = Mid(FileName, i, 1) ' i = i + 1 ' If s = "" Then ' Exit Do ' End If 'Loop Until (CheckCharType(s) = "Unicode字符") ''判断图号情况 'Select Case True '第一个字符为汉字 ' Case i = 2 ' BasicNumber = InputBox("部件 " & FullFileName & " 无图号，输入图号", "输入图号", "") ' If BasicNumber.ToString = "" Then ' Return False ' Exit Function ' End If ' Case s = "" '无汉字 ' BasicNumber = GetFileNameInfo(FullFileName).ONlyName ' Case Else '正常情况 ' BasicNumber = Left(FileName, i - 2) 'End Select Dim StockNumPartName As StockNumPartName '获取图号和零件名 StockNumPartName = GetStockNumPartName(FullFileName) '未获取图号，退出 If StockNumPartName.IsGet = False Then Return False End If '基本图号 BasicNumber = StockNumPartName.StockNum Dim PartNumberStep As Integer '零件图号变化步长 Dim AssNumberStep As Integer '部件图号变化步长 AssNumberStep = Val(InputBox("输入部件文件的编号变化，部件XXX-0000000 下第一个部件为XXX-0000100 则 输入 100 ")) If AssNumberStep = 0 Then Return False Exit Function End If PartNumberStep = Val(InputBox("输入零件文件的编号变化，部件XXX-0000000 下第一个零件为XXX-0000001 则 输入 1 ")) If PartNumberStep = 0 Then Return False Exit Function End If '重命名还是续命名 Dim PartNumberItem As Integer '第几个零件文件 Dim AssNumberItem As Integer '第几个部件文件 If MsgBox("是否续编部件文件名？", MsgBoxStyle.YesNo + MsgBoxStyle.Question) = MsgBoxResult.Yes Then 'Dim BasicOcc As ComponentOccurrence '选择续编的的部件或零件 'Dim BasicFullFileName As String '续编的文档全名 'Dim BasicFileName As String '续编的文件名 'BasicOcc = ThisApplication.CommandManager.Pick(kAssemblyOccurrenceFilter, "选择续编的部件文件") 'BasicFullFileName = BasicOcc.ReferencedDocumentDescriptor.FullDocumentName 'BasicFileName = GetStockNumPartName(BasicFullFileName).StockNum 'AssNumberItem = (Val(BasicFileName) - Val(BasicNumber)) / AssNumberStep AssNumberItem = Val(InputBox("输入续编部件文件的文件名，部件XXX-0000200 则 输入 200 ", "续编部件", "")) / AssNumberStep Else '重0开始命名，不续编 AssNumberItem = 0 End If If MsgBox("是否续编零件文件名？", MsgBoxStyle.YesNo + MsgBoxStyle.Question) = MsgBoxResult.Yes Then 'Dim BasicOcc As ComponentOccurrence '选择续编的的部件或零件 'Dim BasicFullFileName As String '续编的文档全名 'Dim BasicFileName As String '续编的文件名 'BasicOcc = ThisApplication.CommandManager.Pick(kAssemblyOccurrenceFilter, "选择续编的零件文件") 'BasicFullFileName = BasicOcc.ReferencedDocumentDescriptor.FullDocumentName 'BasicFileName = GetStockNumPartName(BasicFullFileName).StockNum 'Dim a As Double = GetNumbers(BasicFileName) 'Dim b As Double = GetNumbers(BasicNumber) 'PartNumberItem = (a - b) / PartNumberStep PartNumberItem = Val(InputBox("输入续编零件文件的文件名，零件XXX-0000105 则 输入 5 ", "续编零件", "")) / PartNumberStep Else '重0开始命名，不续编 PartNumberItem = 0 End If Dim OldComponentOccurrence As ComponentOccurrence '选择的部件或零件 Dim OldInventorDocument As Document '旧的文档 Dim OldFullFileName As String '旧的文档全名 Dim OldFileName As String '旧的文件名 Dim OldFileInfo As FileNameInfo Dim NewInventorDocument As Document Dim NewFullFileName As String '新的文档全名 Dim NewFileName As String '新的文档名 Dim NewStockNum As String = Nothing '新的图号 ' 获取所有引用文档 Dim oDocumentsEnumerator As DocumentsEnumerator oDocumentsEnumerator = oAssemblyDocument.ReferencedDocuments ' 遍历这些文档 Do OldComponentOccurrence = ThisApplication.CommandManager.Pick(kAssemblyOccurrenceFilter, "选择要编号的文件") If OldComponentOccurrence Is Nothing Then '取消选择 Exit Do End If OldFullFileName = OldComponentOccurrence.ReferencedDocumentDescriptor.FullDocumentName '旧文件全文件名 OldFileInfo = GetFileNameInfo(OldFullFileName) OldFileName = OldFileInfo.ONlyName '旧文件 仅文件名 If IsFileExsts(OldFullFileName) = False Then '跳过不存在的文件 MsgBox(OldFullFileName & "不存在", MsgBoxStyle.Critical) GoTo 999 End If If InStr(OldFullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 MsgBox(OldFullFileName & "为零件库文件", MsgBoxStyle.Information) 'OldInventorDoc.Close() GoTo 999 End If '如果旧文件目录下有一个文件名相同的已有零件号的文件，是否替换或者重新命名当前文件 For Each FoundFile As String In My.Computer.FileSystem.GetFiles(OldFileInfo.Folder, FileIO.SearchOption.SearchTopLevelOnly) ' OldFileInfo.ExtensionName) If InStr(GetFileNameInfo(FoundFile).SigleName, OldFileInfo.SigleName) > 1 Then '存在一个已命名图号的文件 Select Case MsgBox("存在一个已命名图号的文件：" & FoundFile & " ，是-直接替换 否-重新生成替换 ", MsgBoxStyle.Information + MsgBoxStyle.YesNo + MsgBoxStyle.DefaultButton1, "自动生成零件图号") Case MsgBoxResult.Yes '替换文件 OldComponentOccurrence.Replace(FoundFile, True) GoTo 999 Case MsgBoxResult.No '重新命名 End Select Exit For End If Next If IsAutoSetPartName = False Then Exit Do End If If CheckCharType(Strings.Left(OldFileName, 1)) = "Unicode字符" Then '第一个为中文就编号 Select Case OldComponentOccurrence.ReferencedDocumentDescriptor.ReferencedDocumentType '零件和部件分别计数 Case kPartDocumentObject '零件 PartNumberItem = PartNumberItem + 1 '第几个文件 NewStockNum = Strings.Left(BasicNumber, (Strings.Len(BasicNumber)) - Len((PartNumberStep * PartNumberItem).ToString)) '获取不改变的前部分图号 NewStockNum = NewStockNum & (PartNumberStep * PartNumberItem).ToString '获取全图号 Case kAssemblyDocumentObject '部件 AssNumberItem = AssNumberItem + 1 NewStockNum = Strings.Left(BasicNumber, (Strings.Len(BasicNumber)) - Len((AssNumberStep * AssNumberItem).ToString)) NewStockNum = NewStockNum & (AssNumberStep * AssNumberItem).ToString Case Else End Select NewFileName = NewStockNum & OldFileName '获取全文件名 NewFullFileName = GetNewFileName(OldFullFileName, NewFileName) '替换旧文件全名为新文件全名 '后台打开旧文件，另存为新文件 OldInventorDocument = ThisApplication.Documents.Open(OldFullFileName, False) OldInventorDocument.SaveAs(NewFullFileName, True) '另存为新图号文件 OldInventorDocument.Close() '替换旧文件 OldComponentOccurrence.Replace(NewFullFileName, True) '后台打开新文件，修改ipro NewInventorDocument = ThisApplication.Documents.Open(NewFullFileName, False) '打开文件，不显示 SetDocumentIpropertyFromFileName(NewInventorDocument, False) '设置Iproperty，打开文件后需关闭 '是否有对应的工程图文件，同时复制后修改文件名和模型链接 Dim OldIdwFullFileName As String OldIdwFullFileName = GetNewExtensionFileName(OldFullFileName, ".idw") '旧工程图 If IsFileExsts(OldIdwFullFileName) = True Then Dim NewIdwFullFileName As String NewIdwFullFileName = GetNewExtensionFileName(NewFullFileName, ".idw") '新工程图 FileSystem.FileCopy(OldIdwFullFileName, NewIdwFullFileName) '复制为新工程图 Dim TempFullFileName As String '暂时更改旧文件名字 TempFullFileName = OldFullFileName & ".old" ReFileName(OldFullFileName, TempFullFileName) MsgBox("找到有对应的旧工程图，生成新的工程图，将打开，请链接到文件：" & vbCrLf & NewFullFileName & vbCrLf & "该文件名已复制，粘贴到对话框即可。", MsgBoxStyle.Information) Windows.Forms.Clipboard.SetText(NewFullFileName) ThisApplication.Documents.Open(NewIdwFullFileName, False) '打开新的工程图，使其手动链接零件或部件 ThisApplication.Documents.ItemByName(NewIdwFullFileName).Save2() '保存链接并关闭工程图 ThisApplication.Documents.ItemByName(NewIdwFullFileName).Close() 'ReFileName(TempFullFileName, OldFullFileName) '恢复旧零件或部件文件名 End If Else MsgBox(OldFullFileName & "可能已有图号", MsgBoxStyle.Information) End If 999: 'TSProgressBar.Value = TSProgressBar.Value + 1 Loop While True Return True End Function '另存为dwg Public Function SaveAsDwg(ByVal oDrawingDocument As Inventor.DrawingDocument) As String Dim IdwFullFileName As String '工程图全文件名 Dim DwgFullFileName As String 'cad 文件全文件名 IdwFullFileName = oDrawingDocument.FullFileName DwgFullFileName = Strings.Replace(IdwFullFileName, LCaseGetFileExtension(IdwFullFileName), ".dwg") If IsFileExsts(DwgFullFileName) Then Dim msg As MsgBoxResult = MsgBox("已存在文件： " & DwgFullFileName & " 是否覆盖（是）或另存为（否）？", MsgBoxStyle.Question + MsgBoxStyle.YesNoCancel, "另存为Dwg") Select Case msg Case MsgBoxResult.Yes Case MsgBoxResult.No Dim ofd As New SaveFileDialog With ofd .Title = "选择 dwg 文件" .Filter = "AutoCAD文件(*.dwg)|*.dwg" .InitialDirectory = GetParentFolder(oDrawingDocument.FullDocumentName) If .ShowDialog = DialogResult.OK Then DwgFullFileName = .FileName Else Return "取消" End If End With Case MsgBoxResult.Cancel Return "取消" End Select End If 'IdwDoc.SaveAs(DwgFullFileName, True) 'If IsFileExsts(DwgFullFileName) = False Then ' DwgFullFileName = Strings.Replace(DwgFullFileName, ".dwg", ".zip") 'End If ' 获取对应的Translator. Dim oTranslatorAddIn As TranslatorAddIn oTranslatorAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC2-122E-11D5-8E91-0010B541CD80}") ' 获取当前零件或装配文档. Dim oTransientObjects As TransientObjects oTransientObjects = ThisApplication.TransientObjects ' 设置导出文件 Dim oTranslationContext As TranslationContext oTranslationContext = oTransientObjects.CreateTranslationContext oTranslationContext.Type = kFileBrowseIOMechanism ' 获取可操作的选项 Dim options As NameValueMap options = oTransientObjects.CreateNameValueMap If oTranslatorAddIn.HasSaveCopyAsOptions(oDrawingDocument, oTranslationContext, options) Then ' 设置导出样式. options.Value("Solid") = True ' 导出 solids. options.Value("Surface") = False ' 导出 surfaces. options.Value("Sketch") = False ' 导出 sketches. ' 设置导出DWG的版本. ' 23 = ACAD 2000 ' 25 = ACAD 2004 ' 27 = ACAD 2007 ' 29 = ACAD 2010 options.Value("DwgVersion") = 23 End If ' 设置导出文件名. Dim oDataMedium As DataMedium oDataMedium = oTransientObjects.CreateDataMedium oDataMedium.FileName = DwgFullFileName ' 调用SaveCopyAs Call oTranslatorAddIn.SaveCopyAs(oDrawingDocument, oTranslationContext, options, oDataMedium) Return DwgFullFileName End Function '另存为pdf Public Function SaveAsPdf(ByVal InventorDocument As Inventor.Document) As String Dim InventorFullFileName As String '工程图全文件名 Dim PdfFullFileName As String 'pdf 文件全文件名 InventorFullFileName = InventorDocument.FullFileName PdfFullFileName = Strings.Replace(InventorFullFileName, LCaseGetFileExtension(InventorFullFileName), ".pdf") If IsFileExsts(PdfFullFileName) Then Dim msg As MsgBoxResult = MsgBox("已存在文件： " & PdfFullFileName & " 是否覆盖（是）或另存为（否）？", MsgBoxStyle.Question + MsgBoxStyle.YesNoCancel, "另存为Dwg") Select Case msg Case MsgBoxResult.Yes Case MsgBoxResult.No Dim ofd As New SaveFileDialog With ofd .Title = "选择 Pdf 文件" .Filter = "Adobe PDF文件(*.pdf)|*.pdf" .InitialDirectory = GetParentFolder(InventorDocument.FullDocumentName) If .ShowDialog = DialogResult.OK Then PdfFullFileName = .FileName Else Return "取消" End If End With Case MsgBoxResult.Cancel Return "取消" End Select End If InventorDocument.SaveAs(PdfFullFileName, True) Return PdfFullFileName End Function '设置工程图自定义比例 Public Function SetDrawingScale(ByVal oDrawingDocument As DrawingDocument) As Boolean Dim oView As DrawingView For Each oView In oDrawingDocument.Sheets(1).DrawingViews If GetViewType(oView) = "主视图" Then 'View.Scale.ToString() Dim oPropertyName As String oPropertyName = Map_DrawingScale Dim StrScale As String StrScale = oView.ScaleString Dim pEachScale As [Property] Try '若该iProperty已经存在，则直接修改其值 pEachScale = oDrawingDocument.PropertySets.Item("User Defined Properties").Item(oPropertyName) pEachScale.Value = StrScale Catch ' 若该iProperty不存在，则添加一个 oDrawingDocument.PropertySets.Item("User Defined Properties").Add(StrScale, oPropertyName) End Try oDrawingDocument.Update() '刷新数据 Return True End If Next Return False End Function '获取零部件质量 Public Function GetMass(ByVal oInventorDocument As Inventor.Document) As Double Dim valMass As Double If oInventorDocument.DocumentType = kPartDocumentObject Then Dim IptDoc As PartDocument IptDoc = oInventorDocument valMass = IptDoc.ComponentDefinition.MassProperties.Mass ElseIf oInventorDocument.DocumentType = kAssemblyDocumentObject Then Dim AsmDoc As AssemblyDocument AsmDoc = oInventorDocument valMass = AsmDoc.ComponentDefinition.MassProperties.Mass Else valMass = 0 End If valMass = valMass + 0.00000001 Dim Val_Mass_Accuracy As Integer Val_Mass_Accuracy = Val(Mass_Accuracy) valMass = Math.Round(valMass, Val_Mass_Accuracy) Return valMass End Function '获取零部件面积 Public Function GetArea(ByVal oInventorDocument As Inventor.Document) As Double Dim valArea As Double If oInventorDocument.DocumentType = kPartDocumentObject Then Dim IptDoc As PartDocument IptDoc = oInventorDocument valArea = IptDoc.ComponentDefinition.MassProperties.Area / 10 ^ 4 ElseIf oInventorDocument.DocumentType = kAssemblyDocumentObject Then Dim AsmDoc As AssemblyDocument AsmDoc = oInventorDocument valArea = AsmDoc.ComponentDefinition.MassProperties.Area / 10 ^ 4 Else valArea = 0 End If valArea = valArea + 0.00000001 Dim Val_Area_Accuracy As Integer Val_Area_Accuracy = Val(Area_Accuracy) valArea = Math.Round(valArea, Val_Area_Accuracy) Return valArea End Function '设置工程图自定义质量 Public Function SetMass(ByVal oDrawingDocument As DrawingDocument) As Boolean Dim oPropertyName As String oPropertyName = "质量" Dim InventorDoc As Inventor.Document Dim valMass As Double = 0 Dim TempdoubleMass As Double = 0 For Each InventorDoc In oDrawingDocument.ReferencedDocuments TempdoubleMass = GetMass(InventorDoc) If TempdoubleMass > valMass Then valMass = TempdoubleMass End If Next Dim strMass As String strMass = valMass.ToString Dim pEachScale As [Property] Try '若该iProperty已经存在，则直接修改其值 pEachScale = oDrawingDocument.PropertySets.Item("User Defined Properties").Item(oPropertyName) pEachScale.Value = strMass Catch ' 若该iProperty不存在，则添加一个 oDrawingDocument.PropertySets.Item("User Defined Properties").Add(strMass, oPropertyName) End Try oDrawingDocument.Update() '刷新数据 Return True End Function '获取视图类型 Public Function GetViewType(ByVal oDrawingView As DrawingView) As String '遍历每个视图 Select Case (oDrawingView.ViewType) Case kStandardDrawingViewType Return ("主视图") Case kAssociativeDraftDrawingViewType Return ("关联草图视图") Case kAuxiliaryDrawingViewType Return ("辅助视图") Case kCustomDrawingViewType Return ("自定义视图") Case kDefaultDrawingViewType Return ("缺省视图") Case kDetailDrawingViewType Return ("详细视图") Case kDraftDrawingViewType Return ("草图视图") Case kOLEAttachmentDrawingViewType Return ("OLE附着视图") Case kOverlayDrawingViewType Return ("覆盖视图") Case kProjectedDrawingViewType Return ("投影视图") Case kSectionDrawingViewType Return ("局部视图") End Select Return "无法识别" End Function '设置工程图自定义属性：对称件IPro Public Function SetDrawingMirPartIPro(ByVal oDrawingDocument As DrawingDocument) As Boolean Dim oSheet As Sheet oSheet = oDrawingDocument.ActiveSheet Dim oView As DrawingView oView = oSheet.DrawingViews.Item(1) Dim oRef As DocumentDescriptor oRef = oView.ReferencedDocumentDescriptor '获取本零件文件夹路径 Dim MirFile_FullFileName As String Dim ofd As New OpenFileDialog With ofd .Multiselect = False .Title = "选择 ipt iam 文件" .Filter = "Inventor 文件(*.ipt;*.iam)|*.ipt;*.iam|Inventor 零件(*.ipt)|*.ipt|Inventor 部件(*.iam)|*.iam" .InitialDirectory = GetParentFolder(oRef.FullDocumentName) If .ShowDialog = DialogResult.OK Then MirFile_FullFileName = .FileName Else Return True Exit Function End If End With '获取镜像零件ipro Dim StockNumPartName As StockNumPartName StockNumPartName = GetStockNumPartName(MirFile_FullFileName) '设置ipro Dim pEachScale As [Property] Try '若该iProperty已经存在，则直接修改其值 pEachScale = oDrawingDocument.PropertySets.Item("User Defined Properties").Item(Map_Mir_StochNum) pEachScale.Value = StockNumPartName.StockNum pEachScale = oDrawingDocument.PropertySets.Item("User Defined Properties").Item(Map_Mir_PartName) pEachScale.Value = StockNumPartName.PartName Catch ' 若该iProperty不存在，则添加一个 oDrawingDocument.PropertySets.Item("User Defined Properties").Add(StockNumPartName.StockNum, Map_Mir_StochNum) oDrawingDocument.PropertySets.Item("User Defined Properties").Add(StockNumPartName.PartName, Map_Mir_PartName) End Try oDrawingDocument.Update() '刷新数据 Return True End Function '设置打印时间 'Public Function SetPrintTime(ByVal IdwDoc As DrawingDocument, ByVal AddTime As Short) As Boolean ' Dim pEachScale As [Property] ' Dim Print_Day As String ' Print_Day = " " ' Select Case AddTime ' Case 0 '清除数据改为空白 ' Case 1 '当前日写数据 ' Print_Day = Today.Year & "." & Today.Month & "." & Today.Day ' Case 2 '自定义日期写数据 ' Print_Day = Today.Year & "." & Today.Month & "." & Today.Day ' Print_Day = InputBox("输入日期", "日期", Print_Day) ' End Select ' Try ' '若该iProperty已经存在，则直接修改其值 ' pEachScale = IdwDoc.PropertySets.Item("User Defined Properties").Item(Map_PrintDay) ' pEachScale.Value = Print_Day ' Catch ' ' 若该iProperty不存在，则添加一个 ' IdwDoc.PropertySets.Item("User Defined Properties").Add(Print_Day, Map_PrintDay) ' End Try ' IdwDoc.Update() '刷新数据 ' Return True 'End Function '设置签字 Public Function SetSign(ByVal oDrawingDocument As DrawingDocument, ByVal EngineerName As String, ByVal Print_Day As String, ByVal IsOPenPrintDialog As Boolean) As Boolean Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = oDrawingDocument.PropertySets oPropSet = oPropSets.Item(3) For Each propitem In oPropSet '设置iproperty Select Case propitem.DisplayName Case "工程师" propitem.Value = EngineerName End Select Next Dim pEachScale As [Property] Try '若该iProperty已经存在，则直接修改其值 pEachScale = oDrawingDocument.PropertySets.Item("User Defined Properties").Item(Map_PrintDay) pEachScale.Value = Print_Day Catch ' 若该iProperty不存在，则添加一个 oDrawingDocument.PropertySets.Item("User Defined Properties").Add(Print_Day, Map_PrintDay) End Try oDrawingDocument.Update() '刷新数据 '打开打印窗口() If IsOpenPrint = 1 And IsOPenPrintDialog = True Then Dim oCommmandbars As CommandControl For Each oCommmandbars In ThisApplication.UserInterfaceManager.FileBrowserControls If oCommmandbars.DisplayName = "打印" Then Dim oCommandbarPrint As CommandControl For Each oCommandbarPrint In oCommmandbars.ChildControls If oCommandbarPrint.DisplayName = "打印" Then oCommandbarPrint.ControlDefinition.Execute2(True) End If Next Exit For End If Next End If Return True End Function '获取单个描述 Public Function GetPropitem(ByVal oInventorDocument As Inventor.Document, ByVal propitemName As String) As String Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = oInventorDocument.PropertySets oPropSet = oPropSets.Item(3) '获取iproperty Dim StockNumPartName As StockNumPartName = Nothing For Each propitem In oPropSet Select Case propitem.DisplayName Case propitemName Return propitem.Value End Select Next oInventorDocument.Update() '刷新数据 Return True End Function '设置单个propitem Public Function SetPropitem(ByVal oInventorDocument As Inventor.Document, ByVal propitemName As String, ByVal propitemValue As String) As Boolean Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = oInventorDocument.PropertySets oPropSet = oPropSets.Item(3) '获取iproperty Dim StockNumPartName As StockNumPartName = Nothing For Each propitem In oPropSet Select Case propitem.DisplayName Case propitemName propitem.Value = propitemValue End Select Next oInventorDocument.Update() '刷新数据 Return True End Function '获取 StockNumPartName Public Function GetPropitems(ByVal oInventorDocument As Inventor.Document) As StockNumPartName Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = oInventorDocument.PropertySets oPropSet = oPropSets.Item(3) Dim oStockNumPartName As StockNumPartName = Nothing For Each propitem In oPropSet Select Case propitem.DisplayName Case Map_PartName oStockNumPartName.PartName = propitem.Value Case Map_StochNum oStockNumPartName.StockNum = propitem.Value Case Map_PartNum oStockNumPartName.PartNum = propitem.Value End Select Next oInventorDocument.Update() '刷新数据 Return oStockNumPartName End Function '设置 StockNumPartName Public Function SetPropitems(ByVal oInventorDocument As Inventor.Document, ByVal oStockNumPartName As StockNumPartName) As Boolean Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = oInventorDocument.PropertySets oPropSet = oPropSets.Item(3) For Each propitem In oPropSet Select Case propitem.DisplayName Case Map_PartName propitem.Value = oStockNumPartName.PartName Case Map_StochNum propitem.Value = oStockNumPartName.StockNum Case Map_PartNum propitem.Value = oStockNumPartName.PartNum End Select Next oInventorDocument.Update() '刷新数据 Return True End Function '提取iproperty更改文件名 Public Function GetIpropertyToRename(ByVal InventorDoc As Inventor.Document, ByVal OldOcc As ComponentOccurrence) As Boolean Dim OldFullFileName As String '被替换的旧文件全名 Dim OldFileName As String '被替换的旧文件仅文件名 OldFullFileName = OldOcc.ReferencedDocumentDescriptor.FullDocumentName OldFileName = GetFileNameInfo(OldFullFileName).ONlyName If IsFileExsts(OldFullFileName) = False Then MsgBox("文件： " & OldFullFileName & "不存在！", MsgBoxStyle.Critical, "修改文件名") Return True Exit Function End If If InStr(OldFullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 MsgBox("无法修改资源中心文件： " & OldFullFileName, MsgBoxStyle.Information, "修改文件名") 'OldInventorDoc.Close() Return True Exit Function End If Select Case OldOcc.DefinitionDocumentType Case kPartDocumentObject, kAssemblyDocumentObject '选择的是部件或零件 Dim NewFullFileName As String '新文件全名 Dim NewFileName As String '新文件仅文件名 '新图号 'frmain.Focus() '打开旧文件,不显示 Dim OldInventorDoc As Document OldInventorDoc = ThisApplication.Documents.Open(OldFullFileName, False) Dim oPropSets As PropertySets Dim oPropSet As PropertySet Dim propitem As [Property] oPropSets = OldInventorDoc.PropertySets oPropSet = oPropSets.Item(3) '获取iproperty Dim StockNumPartName As StockNumPartName = Nothing For Each propitem In oPropSet Select Case propitem.DisplayName Case Map_PartName StockNumPartName.PartName = propitem.Value Case Map_StochNum StockNumPartName.StockNum = propitem.Value Case "描述" ' propitem.Value = "" End Select Next '新文件名 NewFileName = StockNumPartName.StockNum & StockNumPartName.PartName '替换旧文件全名为新文件全名 NewFullFileName = GetNewFileName(OldFullFileName, NewFileName) If NewFullFileName = OldFullFileName Then MsgBox("iProperty与文件名匹配，无需重命名文件！", MsgBoxStyle.Information) '关闭旧图,不保存 OldInventorDoc.Close(True) Return True End If '检查新文件是否存在 If IsFileExsts(NewFullFileName) = True Then Select Case MsgBox("存在文件：" & NewFullFileName & " ，是-直接替换 否-重新生成替换 取消-退出重新命名 ", MsgBoxStyle.Information + MsgBoxStyle.YesNoCancel) Case MsgBoxResult.Yes '直接用新文件替换 '全部替换为新文件 'If MsgBox("是否替换全部零件？", MsgBoxStyle.YesNo + MsgBoxStyle.Question + MsgBoxStyle.SystemModal) = MsgBoxResult.Yes Then OldOcc.Replace(NewFullFileName, True) 'Else 'OldOcc.Replace(NewFullFileName, False) 'End If OldInventorDoc.Close(True) Return True Case MsgBoxResult.No '重新另存为新文件，再替换 Case MsgBoxResult.Cancel '取消退出 '关闭旧图 OldInventorDoc.Close(True) Return True End Select End If '另存为新文件 OldInventorDoc.SaveAs(NewFullFileName, True) '全部替换为新文件 OldOcc.Replace(NewFullFileName, True) '后台打开新文件，修改ipro Dim NewInventorDoc As Inventor.Document NewInventorDoc = ThisApplication.Documents.Open(NewFullFileName, False) '打开文件，不显示 '设置新文件的Iproperty，打开文件后不关闭 SetDocumentIpropertyFromFileName(NewInventorDoc, False) '检查是否有对应的工程图文件，同时复制后修改文件名和模型链接 Dim OldIdwFullFileName As String OldIdwFullFileName = GetNewExtensionFileName(OldFullFileName, ".idw") '旧工程图 If IsFileExsts(OldIdwFullFileName) = True Then Dim NewIdwFullFileName As String '新工程图 NewIdwFullFileName = GetNewExtensionFileName(NewFullFileName, ".idw") '复制为新工程图 FileSystem.FileCopy(OldIdwFullFileName, NewIdwFullFileName) Dim NewIdwDoc As Inventor.DrawingDocument '打开新工程图文件，不显示 NewIdwDoc = ThisApplication.Documents.Open(NewIdwFullFileName, False) '在新工程图中替换新的零件部件引用 NewIdwDoc.ReferencedDocumentDescriptors(1).ReferencedFileDescriptor.ReplaceReference(NewFullFileName) '保存关闭新工程图 NewIdwDoc.Save2() NewIdwDoc.Close() '关闭旧的零件部件 OldInventorDoc.Close(True) NewInventorDoc.Close() End If Return True Case MsgBox("选择的文件不是零件或部件", MsgBoxStyle.Information) Return False End Select End Function '设置序号 Public Function SetSerialNumber(ByVal oDrawingDocument As DrawingDocument) As Boolean Dim oActiveSheet As Sheet oActiveSheet = oDrawingDocument.ActiveSheet If oActiveSheet.PartsLists.Count = 0 Then MsgBox("该工程图无明细表", MsgBoxStyle.Critical) Return False Exit Function End If Dim FirstBalloonNumber As Short Dim BalloonNumber As Short FirstBalloonNumber = InputBox("输入第一个序号：", "重建序号", "1") BalloonNumber = FirstBalloonNumber ' '设置序号为0 Dim partslistrow As Inventor.PartsListRow For Each partslistrow In oActiveSheet.PartsLists.Item(1).PartsListRows If partslistrow.Item(1).Value >= FirstBalloonNumber Then partslistrow.Item(1).Value = 0 End If Next '获取当前balloon的textstyle Dim OldBalloonTextStyl As String = oDrawingDocument.StylesManager.ActiveStandardStyle.ActiveObjectDefaults.BalloonStyle.TextStyle.Name '获取当前balloonstyle Dim oActiveBalloonStyle As BalloonStyle = oDrawingDocument.StylesManager.ActiveStandardStyle.ActiveObjectDefaults.BalloonStyle '新建 ZeroBalloonText Try If oDrawingDocument.StylesManager.TextStyles.Item("ZeroBalloonText") Is Nothing Then End If Catch ex As Exception Dim oZeroBalloonText As TextStyle oZeroBalloonText = oDrawingDocument.StylesManager.TextStyles.Item(OldBalloonTextStyl).Copy("ZeroBalloonText") Dim oZeroBalloonTextColor As Color = ThisApplication.TransientObjects.CreateColor(255, 0, 128) oZeroBalloonText.Color = oZeroBalloonTextColor End Try '设置当前balloon style 为新的 zeroballoonstyle oActiveBalloonStyle.TextStyle = oDrawingDocument.StylesManager.TextStyles.Item("ZeroBalloonText") ' '' '' ' '' '' '点击每个序号组 ' '' '' Dim oBalloon As Balloon ' '' '' For i = 1 To oActiveSheet.PartsLists.Item(1).PartsListRows.Count ' '' '' oBalloon = ThisApplication.CommandManager.Pick(kDrawingBalloonFilter, "选择引出序号") ' '' '' '遍历序号组中的序号，不为0就设置序号，并加1，设置下一个，有序号则跳过 ' '' '' For Each oBalloonValueSet As BalloonValueSet In oBalloon.BalloonValueSets ' '' '' If oBalloonValueSet.Value = 0 Then ' '' '' oBalloonValueSet.Value = i ' '' '' i = i + 1 ' '' '' End If ' '' '' Next ' '' '' '多加的1要减去 ' '' '' i = i - 1 ' '' '' Next '点击每个序号组 Try Dim oBalloon As Balloon Do oBalloon = ThisApplication.CommandManager.Pick(kDrawingBalloonFilter, "选择引出序号") For Each oBalloonValueSet As BalloonValueSet In oBalloon.BalloonValueSets 'If (oBalloonValueSet.Value >= FirstBalloonNumber) Then If oBalloonValueSet.Value = 0 Then oBalloonValueSet.Value = BalloonNumber BalloonNumber = BalloonNumber + 1 End If Next Loop While True Catch ex As Exception 'esc 退出后，还原balloon style oActiveBalloonStyle.TextStyle = oDrawingDocument.StylesManager.TextStyles.Item(OldBalloonTextStyl) Return True End Try End Function '检查序号完整性 Public Function CheckSerialNumber(ByVal oDrawingDocument As DrawingDocument) As Boolean Dim oActiveSheet As Sheet oActiveSheet = oDrawingDocument.ActiveSheet If oActiveSheet.Balloons.Count = 0 Then MsgBox("该工程图无序号，请添加 序号", MsgBoxStyle.Critical) Return False Exit Function End If If oActiveSheet.PartsLists.Count = 0 Then MsgBox("该工程图无明细表，请插入一个 明细表 ", MsgBoxStyle.Critical) Return False Exit Function End If Dim oPartsListRows As PartsListRows = oActiveSheet.PartsLists.Item(1).PartsListRows Dim strList As String = "" For Each oPartsListRow As PartsListRow In oPartsListRows If oPartsListRow.Ballooned = False Then strList = strList & oPartsListRow.Item(1).Value & " , " End If Next If Strings.Len(strList) > 1 Then MsgBox("明细表：" & strList & " 无序号", MsgBoxStyle.Information, "检查序号完整性") Return False Else Return True End If End Function Public Function InsertSerialNumber(ByVal oDrawingDocument As DrawingDocument) As Boolean Dim oActiveSheet As Sheet oActiveSheet = oDrawingDocument.ActiveSheet If oActiveSheet.PartsLists.Count = 0 Then MsgBox("该工程图无明细表", MsgBoxStyle.Critical) Return False Exit Function End If Dim FirstBalloonNumber As Short FirstBalloonNumber = InputBox("输入要插入的序号，并点击该序号的标注标识", "插入序号") If FirstBalloonNumber = "" Then Return False End If '点击被插入的序号标识 Dim oBalloon As Balloon oBalloon = ThisApplication.CommandManager.Pick(kDrawingBalloonFilter, "选择被插入的引出序号标识") ' 设置序号+1 For Each oPartsListRow As Inventor.PartsListRow In oActiveSheet.PartsLists.Item(1).PartsListRows If oPartsListRow.Item(1).Value >= FirstBalloonNumber Then oPartsListRow.Item(1).Value = oPartsListRow.Item(1).Value + 1 End If Next '设置插入序号对应的标识 For Each oBalloonValueSet As BalloonValueSet In oBalloon.BalloonValueSets If oBalloonValueSet.Value = 0 Then oBalloonValueSet.Value = FirstBalloonNumber Else MsgBox("该标识数值不为0，请重新选择。", MsgBoxStyle.Information) End If Next Return True End Function '设置当前部件下级为虚拟件 Public Function SetBOMStructuret(ByVal oAssemblyDocument As AssemblyDocument) As Boolean '设置结构类型 Dim BOMStructureType As BOMStructureEnum Dim intBOMStructureType As String intBOMStructureType = InputBox("输入要设置的类型：" & vbCrLf & "1——普通件" & vbCrLf & vbCrLf & "2——虚拟件", "BOM结构类型", 2) Select Case intBOMStructureType Case "" Return True Case "1" '普通件 BOMStructureType = kNormalBOMStructure Case "2" '虚拟件 BOMStructureType = kPhantomBOMStructure End Select ' Set a reference to the BOM Dim oBOM As BOM oBOM = oAssemblyDocument.ComponentDefinition.BOM ' Set the structured view to 'all levels' oBOM.StructuredViewFirstLevelOnly = False ' Make sure that the structured view is enabled. oBOM.StructuredViewEnabled = True ' Set a reference to the "Structured" BOMView '获取结构化的bom页面 For Each oBOMView As BOMView In oBOM.BOMViews If oBOMView.ViewType = BOMViewTypeEnum.kModelDataBOMViewType Then '遍历这个bom页面 SetPhantomBOMStructuretSub(oBOMView.BOMRows, BOMStructureType) End If Next Return True End Function '设置当前部件下级为虚拟件,遍历子程序 Public Sub SetPhantomBOMStructuretSub(ByVal oBOMRows As BOMRowsEnumerator, ByVal BOMStructureType As BOMStructureEnum) Dim i As Long For i = 1 To oBOMRows.Count Dim oRow As BOMRow oRow = oBOMRows.Item(i) Dim oCompDef As ComponentDefinition oCompDef = oRow.ComponentDefinitions.Item(1) Debug.Print(oCompDef.Document.FullFileName) ' 遍历下一级 If Not oRow.ChildRows Is Nothing Then Call SetPhantomBOMStructuretSub(oRow.ChildRows, BOMStructureType) End If '跳过参考件 If oRow.BOMStructure <> kInseparableBOMStructure Then oRow.BOMStructure = BOMStructureType End If Next End Sub '在尺寸前添加φ Public Function ADDFai(ByVal oInventorDocument As Inventor.Document) As Boolean Dim oLinearGeneralDimension As LinearGeneralDimension '选择的部件或零件 Dim strDimension As String Dim strFai As String ' 是否已经选择了尺寸 If oInventorDocument.SelectSet.Count <> 0 Then For Each oSelect As Object In oInventorDocument.SelectSet If oSelect.Type = ObjectTypeEnum.kLinearGeneralDimensionObject Then '添加Φ，内部代号n strFai = "n" strDimension = strFai & "" oSelect.Text.FormattedText = strDimension End If Next Else oLinearGeneralDimension = ThisApplication.CommandManager.Pick(kDrawingDefaultFilter, "选择要添加Φ的尺寸") If oLinearGeneralDimension Is Nothing Then '取消选择 Return True Exit Function End If strFai = "n" strDimension = strFai & "" oLinearGeneralDimension.Text.FormattedText = strDimension End If Return True End Function '检查模型是否有对应的工程图 Public Function CheckIsInvHaveIdw(ByVal oAssemblyDocument As AssemblyDocument, ByVal StrInName As String) As Boolean ' Set a reference to the BOM Dim oBOM As BOM oBOM = oAssemblyDocument.ComponentDefinition.BOM ' Set the structured view to 'all levels' oBOM.StructuredViewFirstLevelOnly = False ' Make sure that the structured view is enabled. oBOM.StructuredViewEnabled = True ' Set a reference to the "Structured" BOMView '获取结构化的bom页面 For Each oBOMView As BOMView In oBOM.BOMViews If oBOMView.ViewType = BOMViewTypeEnum.kStructuredBOMViewType Then '遍历这个bom页面 CheckIsInvHaveIdwSub(oBOMView.BOMRows, StrInName) End If Next Return True End Function '检查模型是否有对应的工程图 Public Sub CheckIsInvHaveIdwSub(ByVal oBOMRows As BOMRowsEnumerator, ByVal StrInName As String) Dim i As Long For i = 1 To oBOMRows.Count Dim oRow As BOMRow oRow = oBOMRows.Item(i) Dim oCompDef As ComponentDefinition oCompDef = oRow.ComponentDefinitions.Item(1) Debug.Print(oCompDef.Document.FullFileName) Dim InventorFullName As String '模型文件 Dim IdwFullFileName As String '工程图全文件名 InventorFullName = oCompDef.Document.FullFileName If IsFileExsts(InventorFullName) = False Then '跳过不存在的文件 GoTo 999 End If If InStr(InventorFullName, ContentCenterFiles) > 0 Then '跳过零件库文件 GoTo 999 End If '检查收否含有指定的字符串 If InStr(Strings.LCase(InventorFullName), Strings.LCase(StrInName)) = 0 Then GoTo 999 End If IdwFullFileName = Strings.Replace(InventorFullName, LCaseGetFileExtension(InventorFullName), ".idw") If IsFileExsts(IdwFullFileName) = False Then ThisApplication.Documents.Open(InventorFullName) End If ' 遍历下一级 If Not oRow.ChildRows Is Nothing Then Call CheckIsInvHaveIdwSub(oRow.ChildRows, StrInName) End If 999: Next End Sub '打开部件中所有子集对应的工程图 ，部件文件，指定的图号 Public Function OpenAllDrwInAsm(ByVal oAssemblyDocument As AssemblyDocument, ByVal StockNum As String) As Boolean ' Set a reference to the BOM Dim oBOM As BOM oBOM = oAssemblyDocument.ComponentDefinition.BOM ' Set the structured view to 'all levels' oBOM.StructuredViewFirstLevelOnly = False ' Make sure that the structured view is enabled. oBOM.StructuredViewEnabled = True ' Set a reference to the "Structured" BOMView Dim oBOMView As BOMView '获取结构化的bom页面 For Each oBOMView In oBOM.BOMViews If oBOMView.ViewType = BOMViewTypeEnum.kStructuredBOMViewType Then '遍历这个bom页面 OpenAllDrwInAsmSub(oBOMView.BOMRows, StockNum) End If Next Return True End Function '打开部件中所有子集对应的工程图 Public Sub OpenAllDrwInAsmSub(ByVal oBOMRows As BOMRowsEnumerator, ByVal StockNum As String) Dim i As Long For i = 1 To oBOMRows.Count Dim oRow As BOMRow oRow = oBOMRows.Item(i) Dim oComponentDefinition As ComponentDefinition oComponentDefinition = oRow.ComponentDefinitions.Item(1) Debug.Print(oComponentDefinition.Document.FullFileName) Dim InventorFullName As String '模型文件 Dim IdwFullFileName As String '工程图全文件名 InventorFullName = oComponentDefinition.Document.FullFileName If IsFileExsts(InventorFullName) = False Then '跳过不存在的文件 GoTo 999 End If If InStr(InventorFullName, ContentCenterFiles) > 0 Then '跳过零件库文件 GoTo 999 End If '获取对应工程图文件名 IdwFullFileName = Strings.Replace(InventorFullName, LCaseGetFileExtension(InventorFullName), ".idw") Select Case StockNum Case "" '打开全部 '存在对于工程图，打开它 If IsFileExsts(IdwFullFileName) = True Then ThisApplication.Documents.Open(IdwFullFileName) End If Case Else '打开指定图号 If Strings.InStr(Strings.LCase(GetFileNameInfo(InventorFullName).ONlyName), Strings.LCase(StockNum)) = 0 Then Exit Select End If If IsFileExsts(IdwFullFileName) = True Then ThisApplication.Documents.Open(IdwFullFileName) End If End Select '遍历下一级 If Not oRow.ChildRows Is Nothing Then Call OpenAllDrwInAsmSub(oRow.ChildRows, StockNum) End If 999: Next End Sub '打开活动文件对应的工程图 Public Sub OpenDrawingDocument(ByVal InventorDocument As Inventor.Document) Try SetStatusBarText() 'If IsInventorOpenDoc() = False Then ' Exit Sub 'End If 'If ThisApplication.ActiveDocument.DocumentType = kDrawingDocumentObject Then ' MsgBox("该功能仅适用于部件或零件", MsgBoxStyle.Information) ' 'Return False ' Exit Sub 'End If Dim InventorFullName As String '模型文件 Dim IdwFullFileName As String '工程图全文件名 InventorFullName = InventorDocument.FullDocumentName IdwFullFileName = Strings.Replace(InventorFullName, LCaseGetFileExtension(InventorFullName), ".idw") '当前文件夹查询没有就 到父文件夹查询 If IsFileExsts(IdwFullFileName) = False Then SearchDrawingDocumentInPresentFolder(InventorDocument, 3) End If '查询到工程图 If IsFileExsts(IdwFullFileName) Then ThisApplication.Documents.Open(IdwFullFileName) Else If SearchDrawingDocumentInPresentFolder(InventorDocument, 3) = False Then MsgBox(InventorFullName & "没有对应的工程图。", MsgBoxStyle.Information, "打开工程图") End If End If Catch ex As Exception MsgBox(ex.Message) End Try End Sub '到父文件夹查询工程图 ，inventor 文档 ，向上查询的层级 Public Function SearchDrawingDocumentInPresentFolder(ByVal InventorDocument As Inventor.Document, PresidentLevel As Integer) As Boolean Dim PrsentFolder As String '父文件夹 Dim InventorFullFileName As String '模型文件全名 Dim InventorFileName As String '模型文件名 Dim IdwFullFileName As String '工程图全文件名 Dim IdwFileName As String '工程图名 Dim i As Integer InventorFullFileName = InventorDocument.FullDocumentName InventorFileName = GetFileNameInfo(InventorFullFileName).SigleName IdwFileName = GetFileNameInfo(InventorFullFileName).ONlyName + IDW i = 0 PrsentFolder = System.IO.Directory.GetParent(InventorFullFileName).FullName Do If IsDirectoryExists(PrsentFolder) = True Then PrsentFolder = System.IO.Directory.GetParent(PrsentFolder).FullName i = i + 1 Else Exit Do End If Loop While (i <> PresidentLevel) Dim Files As ReadOnlyCollection(Of String) Files = My.Computer.FileSystem.GetFiles(PrsentFolder, FileIO.SearchOption.SearchAllSubDirectories, IdwFileName) If files.Count <> 0 Then For Each IdwFullFileName In files ThisApplication.Documents.Open(IdwFullFileName) Next Return True Else Return False End If End Function '------------------------------------------------------------------------------------------------------- '批量替换部件下子集的名字 ' 组件，被替换的文件名，替换的文件名 Public Function ReplaceNameInAsm(ByVal AsmDoc As Document, ByVal OldName As String, ByVal NewName As String, ByVal IsSaveAsOld As MsgBoxResult) As Boolean Dim TempFullFileName As String '更改旧模型文件的名字存档 For Each InventorDocument As Inventor.Document In AsmDoc.ReferencedDocuments Dim OldFullFileName As String '被替换的旧文件全名 Dim OldFileName As String '被替换的旧文件仅文件名 Dim NewFullFileName As String '新文件全名 Dim NewFileName As String '新文件名 'InventorDoc = ThisApplication.Documents.ItemByName(OldFullFileName) OldFullFileName = InventorDocument.FullDocumentName If IsFileExsts(OldFullFileName) = False Then '跳过不存在的文件 GoTo 999 End If If InStr(OldFullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 GoTo 999 End If OldFileName = GetFileNameInfo(OldFullFileName).SigleName '替换旧文件全名为新文件全名 If InStr(OldFileName, OldName) Then NewFileName = Replace(OldFileName, OldName, NewName) NewFullFileName = GetFileNameInfo(OldFullFileName).Folder & "\" & NewFileName '打开旧文件,不显示 Dim OldDoc As Inventor.Document OldDoc = ThisApplication.Documents.Open(OldFullFileName, False) '另存为新文件 OldDoc.SaveAs(NewFullFileName, False) '关闭旧图 OldDoc.Close() '后台打开文件，修改ipro Dim NewInventorDocument As Inventor.Document NewInventorDocument = ThisApplication.Documents.Open(NewFullFileName, False) '打开文件，不显示 SetDocumentIpropertyFromFileName(NewInventorDocument, True) '设置Iproperty，打开文件后需关闭 Dim oCO As Inventor.ComponentOccurrences oCO = AsmDoc.ComponentDefinition.Occurrences '全部替换为新文件 For Each ooCO As ComponentOccurrence In oCO If ooCO.ReferencedDocumentDescriptor.FullDocumentName = OldFullFileName Then ooCO.Replace(NewFullFileName, True) Exit For End If Next '是否有对应的工程图文件，同时复制后修改文件名和模型链接 Dim OldIdwFullFileName As String OldIdwFullFileName = GetNewExtensionFileName(OldFullFileName, ".idw") '旧工程图 'Dim TempFullFileName As String '更改旧模型文件的名字存档 If IsFileExsts(OldIdwFullFileName) = True Then Dim NewIdwFullFileName As String NewIdwFullFileName = GetNewExtensionFileName(NewFullFileName, ".idw") '新工程图 FileSystem.FileCopy(OldIdwFullFileName, NewIdwFullFileName) '复制为新工程图 'MsgBox("找到有对应的旧工程图，生成新的工程图，将打开，请链接到文件：" & vbCrLf & NewFullFileName & vbCrLf & "该文件名已复制，粘贴到对话框即可。", MsgBoxStyle.Information) 'Windows.Forms.Clipboard.SetText(NewFullFileName) 'ThisApplication.Documents.Open(NewIdwFullFileName, False) '打开新的工程图，使其手动链接零件或部件 'ThisApplication.Documents.ItemByName(NewIdwFullFileName).Save2() '保存链接并关闭工程图 'ThisApplication.Documents.ItemByName(NewIdwFullFileName).Close() InventorDocument = ThisApplication.Documents.Open(NewIdwFullFileName, False) '打开文件，不显示 InventorDocument.ReferencedDocumentDescriptors(1).ReferencedFileDescriptor.ReplaceReference(NewFullFileName) InventorDocument.Save2() InventorDocument.Close() If IsSaveAsOld = MsgBoxResult.Yes Then TempFullFileName = OldIdwFullFileName & ".old" '暂时更改旧工程图文件的名字存档 ReFileName(OldIdwFullFileName, TempFullFileName) 'ReFileName(TempFullFileName, OldFullFileName) '恢复旧零件或部件文件名 End If End If If IsSaveAsOld = MsgBoxResult.Yes Then TempFullFileName = OldFullFileName & ".old" '暂时更改旧工程图文件的名字存档 ReFileName(OldFullFileName, TempFullFileName) End If '是部件的遍历新文件的子集 NewInventorDocument = ThisApplication.Documents.Open(NewFullFileName, False) If NewInventorDocument.DocumentType = kAssemblyDocumentObject Then ReplaceNameInAsm(NewInventorDocument, OldName, NewName, IsSaveAsOld) End If NewInventorDocument.Close(True) End If 999: Next Return True End Function '导出 bom 平面性 Public Function ExportBOMAsFlat(ByVal oAssemblyDocument As AssemblyDocument, ByVal ExcelFullFileName As String) As Boolean Dim FirstLevelOnly As Boolean FirstLevelOnly = False '============================================================================================== '基于bom结构化数据，可跳过参考的文件 ' Set a reference to the BOM Dim oBOM As BOM oBOM = oAssemblyDocument.ComponentDefinition.BOM oBOM.StructuredViewEnabled = True oBOM.StructuredViewFirstLevelOnly = False 'Set a reference to the "Structured" BOMView Dim oBOMView As BOMView 'Dim ColumnsTitle As String 'ColumnsTitle = "库存编号|空格|零件代号|材料|质量|所属装配代号|数量|总数量|描述" Dim IOS2 As System.IO.StreamWriter If IsFileExsts(ExcelFullFileName) = False Then IOS2 = New IO.StreamWriter(ExcelFullFileName, False, System.Text.Encoding.Default) Else IOS2 = New IO.StreamWriter(ExcelFullFileName, True, System.Text.Encoding.Default) End If '写BOM表头 Dim strColumnsTitle As String strColumnsTitle = "序号," & Strings.Replace(BOMTiTle, "|", ",") IOS2.WriteLine(strColumnsTitle) IOS2.Close() TotalItem = 1 '获取结构化的bom页面 For Each oBOMView In oBOM.BOMViews If oBOMView.ViewType = BOMViewTypeEnum.kStructuredBOMViewType Then '遍历这个bom页面 QueryBOMRowPropertieToExcel(ExcelFullFileName, oBOMView.BOMRows, FirstLevelOnly, BOMTiTle, "0", 1) End If Next Return True End Function '在 bom平面性导出，遍历bom 行文件ipro Private Sub QueryBOMRowPropertieToExcel(ByVal ExcelFullFileName As String, ByVal oBOMRows As BOMRowsEnumerator, ByVal FirstLevelOnly As Boolean, ByVal ColumnsTitle As String, _ ByVal Level As String, ByVal PresentNumber As Integer) Dim i As Short Dim j As Short Dim iStepCount As Short iStepCount = oBOMRows.Count 'Create a new ProgressBar object. 'Dim oProgressBar As Inventor.ProgressBar 'oProgressBar = ThisApplication.CreateProgressBar(False, iStepCount, "当前文件： ") '赋值数组 Dim oBOMRowData(2000, 1) As String ReDim oBOMRowData(oBOMRows.Count - 1, 1) For i = 1 To oBOMRows.Count oBOMRowData(i - 1, 0) = oBOMRows.Item(i).ItemNumber oBOMRowData(i - 1, 1) = oBOMRows.Item(i).ReferencedFileDescriptor.FullFileName Next '冒泡排序() Dim Temp As String '不定义变量类型,以自动适应数组Ar的类型 Dim Flag As Boolean Dim n As Integer = oBOMRowData.Length / oBOMRowData.Rank - 1 For i = 0 To n Flag = False '从第1个元素开始,比较每两个相邻元素的大小,让大元素下沉,小元素上浮 '经过一轮循环,可使数组中最大元素下沉到数组最底部 '进入下一轮循环,只对前 n - i 个元素进行相邻比较(已排到后面的不用比较) For j = 0 To n - i - 1 If Val(oBOMRowData(j, 0)) > Val(oBOMRowData(j + 1, 0)) Then Temp = oBOMRowData(j, 0) oBOMRowData(j, 0) = oBOMRowData(j + 1, 0) oBOMRowData(j + 1, 0) = Temp Temp = oBOMRowData(j, 1) oBOMRowData(j, 1) = oBOMRowData(j + 1, 1) oBOMRowData(j + 1, 1) = Temp Flag = True '如果有排序行为，则设为 True End If Next If Flag = False Then '如未排序,说明已完成整个排序过程,退出 Exit For End If Next '循环每一行 For i = 0 To n '文件指针 Dim FilePointItemNumber As String FilePointItemNumber = oBOMRowData(i, 1) '寻找指针的行，开始提取数据 For j = 1 To oBOMRows.Count Dim oRow As BOMRow oRow = oBOMRows.Item(j) Dim InventorDocFullFileName As String InventorDocFullFileName = oRow.ReferencedFileDescriptor.FullFileName If InventorDocFullFileName = FilePointItemNumber Then ' Set the message for the progress bar 'oProgressBar.Message = InventorDocFullFileName If IsFileExsts(InventorDocFullFileName) = False Then '跳过不存在的文件 GoTo 999 End If '数据操作 '======================================== '测试文件 'Debug.Print(ItemNumber & ":" & InventorDocFullFileName) Dim oInventorDocument As Inventor.Document oInventorDocument = ThisApplication.Documents.Open(InventorDocFullFileName, False) SetStatusBarText(InventorDocFullFileName) Dim oPropSets As PropertySets Dim oPropSet As PropertySet oPropSets = oInventorDocument.PropertySets oPropSet = oPropSets.Item(3) Dim Array_ColumnsTitle() As String Dim Array_ColumnsTitleValue() As String Array_ColumnsTitle = Split(ColumnsTitle, "|") ReDim Array_ColumnsTitleValue(Array_ColumnsTitle.Length) Dim propitem As [Property] For k = 0 To Array_ColumnsTitle.Length - 1 Step 1 Select Case Array_ColumnsTitle(k) Case "空格" Array_ColumnsTitleValue(k) = "" Case Map_PartName propitem = oPropSet.ItemByPropId(Inventor.PropertiesForDesignTrackingPropertiesEnum.kPartNumberDesignTrackingProperties) Array_ColumnsTitleValue(k) = propitem.Value Case Map_StochNum propitem = oPropSet.ItemByPropId(Inventor.PropertiesForDesignTrackingPropertiesEnum.kStockNumberDesignTrackingProperties) Array_ColumnsTitleValue(k) = propitem.Value Case "描述" propitem = oPropSet.ItemByPropId(Inventor.PropertiesForDesignTrackingPropertiesEnum.kDescriptionDesignTrackingProperties) Array_ColumnsTitleValue(k) = propitem.Value Case "材料" Dim strMaterialName As String If oInventorDocument.DocumentType = kPartDocumentObject Then Dim IptDoc As PartDocument IptDoc = oInventorDocument strMaterialName = IptDoc.ComponentDefinition.Material.Name Else strMaterialName = "" End If Array_ColumnsTitleValue(k) = strMaterialName Case "成本中心" propitem = oPropSet.ItemByPropId(Inventor.PropertiesForDesignTrackingPropertiesEnum.kCostCenterDesignTrackingProperties) Array_ColumnsTitleValue(k) = propitem.Value Case "质量" Dim strMass As String strMass = GetMass(oInventorDocument) Array_ColumnsTitleValue(k) = strMass Case "面积" Dim strArea As String strArea = GetArea(oInventorDocument) Array_ColumnsTitleValue(k) = strArea Case "数量" Array_ColumnsTitleValue(k) = oRow.ItemQuantity.ToString Case "所属装配" Dim StockNumPartName As StockNumPartName StockNumPartName = GetStockNumPartName(oRow.ReferencedFileDescriptor.Parent.FullFileName) Array_ColumnsTitleValue(k) = StockNumPartName.StockNum & StockNumPartName.PartName Case "所属装配代号" Dim StockNumPartName As StockNumPartName StockNumPartName = GetStockNumPartName(oRow.ReferencedFileDescriptor.Parent.FullFileName) Array_ColumnsTitleValue(k) = StockNumPartName.StockNum Case "总数量" Array_ColumnsTitleValue(k) = (oRow.ItemQuantity * PresentNumber).ToString Case "缩略图" 'propitem = oPropSet.ItemByPropId(Inventor.PropertiesForDesignTrackingPropertiesEnum.kPartIconDesignTrackingProperties) 'Array_ColumnsTitleValue(k) = propitem.Value End Select Array_ColumnsTitleValue(k) = Strings.Replace(Array_ColumnsTitleValue(k), ",", "，") Next k oInventorDocument.Close(False) Select Case oInventorDocument.DocumentType Case kAssemblyDocumentObject Threading.Thread.Sleep(1000) Case kPartDocumentObject Threading.Thread.Sleep(200) End Select '集合数组数据 Dim ColumnsTitleValue As String ColumnsTitleValue = TotalItem & "," & Join(Array_ColumnsTitleValue, ",") TotalItem = TotalItem + 1 '测试数据 'Debug.Print(ColumnsTitleValue) '写数据到文件 Dim IOS As System.IO.StreamWriter If IsFileExsts(ExcelFullFileName) = False Then IOS = New IO.StreamWriter(ExcelFullFileName, False, System.Text.Encoding.Default) Else IOS = New IO.StreamWriter(ExcelFullFileName, True, System.Text.Encoding.Default) End If IOS.WriteLine(ColumnsTitleValue) IOS.Close() '========================================== 999: 'oProgressBar.UpdateProgress() Exit For End If Next j Next i 'Debug.Print("==================================") '写数据到文件 Dim IOS2 As System.IO.StreamWriter If IsFileExsts(ExcelFullFileName) = False Then IOS2 = New IO.StreamWriter(ExcelFullFileName, False, System.Text.Encoding.Default) Else IOS2 = New IO.StreamWriter(ExcelFullFileName, True, System.Text.Encoding.Default) End If '写空白行 IOS2.WriteLine("") IOS2.Close() For i = 1 To oBOMRows.Count ' Get the current row. Dim PointItemNumber As String If Level = "0" Then PointItemNumber = i Else PointItemNumber = Level & "." & i End If For j = 1 To oBOMRows.Count Dim oRow As BOMRow oRow = oBOMRows.Item(j) Dim ItemNumber As String ItemNumber = oRow.ItemNumber Dim DocFullFileName As String DocFullFileName = oRow.ReferencedFileDescriptor.FullFileName If ItemNumber = PointItemNumber Then '测试文件 'Debug.Print(ItemNumber & ":" & DocFullFileName) ' Set the message for the progress bar 'oProgressBar.Message = DocFullFileName If IsFileExsts(DocFullFileName) = False Then '跳过不存在的文件 GoTo 99 End If '数据操作 '======================================== '========================================== '遍历下一级 If (Not oRow.ChildRows Is Nothing) And FirstLevelOnly = False Then Call QueryBOMRowPropertieToExcel(ExcelFullFileName, oRow.ChildRows, FirstLevelOnly, ColumnsTitle, PointItemNumber, oRow.ItemQuantity) End If 99: 'oProgressBar.UpdateProgress() Exit For End If Next j Next i 88: 'oProgressBar.Close() End Sub '保存文件时的事件 'Public Sub ThisApplicationEvents_OnOnSaveDocument(ByVal DocumentObject As Inventor._Document, _ ' ByVal BeforeOrAfter As Inventor.EventTimingEnum, _ ' ByVal Context As Inventor.NameValueMap, _ ' ByRef HandlingCode As Inventor.HandlingCodeEnum) Handles ThisApplicationEvents.OnSaveDocument 'End Sub '打开文件时的事件 'Public Sub ThisApplicationEvents_OnOpenDocument(ByVal oInventorDocument As Inventor.Document, _ ' ByVal FullDocumentName As String, _ ' ByVal BeforeOrAfter As Inventor.EventTimingEnum, _ ' ByVal Context As Inventor.NameValueMap, _ ' ByRef HandlingCode As Inventor.HandlingCodeEnum) Handles ThisApplicationEvents.OnOpenDocument ' '当打开文件为工程图 ' If oInventorDocument.DocumentType = kDrawingDocumentObject Then ' '写入主视图比例 ' 'If IsSetDrawingScale = 1 Then ' SetDrawingScale(oInventorDocument) ' 'End If ' '写入零部件质量 ' 'If IsSetMass = 1 Then ' SetMass(oInventorDocument) ' 'End If ' End If 'End Sub '激活一个文档时的事件 Public Sub ThisApplicationEvents_OnActivateDocument(ByVal oInventorDocument As Inventor.Document, _ ByVal BeforeOrAfter As Inventor.EventTimingEnum, _ ByVal Context As Inventor.NameValueMap, _ ByRef HandlingCode As Inventor.HandlingCodeEnum) Handles ThisApplicationEvents.OnActivateDocument '当打开文件为工程图 If oInventorDocument.DocumentType = kDrawingDocumentObject Then '写入主视图比例 'If IsSetDrawingScale = 1 Then SetDrawingScale(oInventorDocument) 'End If '写入零部件质量 'If IsSetMass = 1 Then SetMass(oInventorDocument) 'End If End If End Sub '刷新引用 Public Function RefreshShowName(ByVal AsmDoc As Document) As Boolean ' 获取装配定义 Dim oAssemblyComponentDefinition As AssemblyComponentDefinition oAssemblyComponentDefinition = AsmDoc.ComponentDefinition Dim ShortName1 As String Dim ShortName2 As String Dim NumName As String Dim i As Integer For Each oOcc In oAssemblyComponentDefinition.Occurrences If InStr(oOcc.ReferencedDocumentDescriptor.FullDocumentName, ContentCenterFiles) > 0 Then '跳过零件库文件 GoTo 999 End If Debug.Print(oOcc.Name) Debug.Print(oOcc.ReferencedDocumentDescriptor.FullDocumentName) i = InStr(oOcc.Name, ":") ShortName1 = Strings.Left(oOcc.Name, i - 1) NumName = Strings.Right(oOcc.Name, Len(oOcc.Name) - i + 1) ShortName2 = GetFileNameInfo(oOcc.ReferencedDocumentDescriptor.FullDocumentName).ONlyName If ShortName1 <> ShortName2 Then oOcc.Name = ShortName2 & NumName End If 999: Next Return True End Function '对齐XYZ平面 Public Function FlushXYZPlane() As Boolean Dim InventorDocument As Inventor.Document InventorDocument = ThisApplication.ActiveDocument Dim oAsmCompDef As AssemblyComponentDefinition oAsmCompDef = InventorDocument.ComponentDefinition ' Get references to the two occurrences to constrain. ' This arbitrarily gets the first and second occurrence. Dim oComponentOccurrence1 As ComponentOccurrence oComponentOccurrence1 = ThisApplication.CommandManager.Pick(kAssemblyLeafOccurrenceFilter, "选择第一个部件或零件") If oComponentOccurrence1 Is Nothing Then '取消选择 Exit Function End If Dim oComponentOccurrence2 As ComponentOccurrence oComponentOccurrence2 = ThisApplication.CommandManager.Pick(kAssemblyLeafOccurrenceFilter, "选择第二个部件或零件") If oComponentOccurrence2 Is Nothing Then '取消选择 Exit Function End If ' Get the XY plane from each occurrence. This goes to the ' component definition of the part to get this information. ' This is the same as accessing the part document directly. ' The work plane obtained is in the context of the part, ' not the assembly. For i = 1 To 3 Dim oPartPlane1 As WorkPlane oPartPlane1 = oComponentOccurrence1.Definition.WorkPlanes.Item(i) Dim oPartPlane2 As WorkPlane oPartPlane2 = oComponentOccurrence2.Definition.WorkPlanes.Item(i) ' Because we need the work plane in the context of the assembly ' we need to create proxies for the work planes. The proxies ' represent the work planes in the context of the assembly. Dim oAsmPlane1 As WorkPlaneProxy = Nothing oComponentOccurrence1.CreateGeometryProxy(oPartPlane1, oAsmPlane1) Dim oAsmPlane2 As WorkPlaneProxy = Nothing oComponentOccurrence2.CreateGeometryProxy(oPartPlane2, oAsmPlane2) ' Create the constraint using the work plane proxies. Dim oMate As FlushConstraint oMate = oAsmCompDef.Constraints.AddFlushConstraint(oAsmPlane1, oAsmPlane2, 0) Next Return True End Function '获取未读取的文件所在部件并打开该部件 （ 部件文件对象 ； 文件是否需打开，打开的文件用后要关闭） Public Function GetUnkonwDocumentWithBOM(ByVal AsmDoc As AssemblyDocument, ByVal IsNeedClose As Boolean) As Boolean ' 获取所有引用文档 Dim FirstLevelOnly As Boolean FirstLevelOnly = False '============================================================================================== '基于bom结构化数据，可跳过参考的文件 ' Set a reference to the BOM Dim oBOM As BOM oBOM = AsmDoc.ComponentDefinition.BOM oBOM.StructuredViewEnabled = True 'Set a reference to the "Structured" BOMView Dim oBOMView As BOMView '获取结构化的bom页面 For Each oBOMView In oBOM.BOMViews If oBOMView.ViewType = BOMViewTypeEnum.kModelDataBOMViewType Then '遍历这个bom页面 QueryBOMRowToOpenUnkonwDocument(oBOMView.BOMRows, FirstLevelOnly) End If Next '============================================================================================== Return True End Function '遍历BOM结构，获取未读取的文件所在部件并打开该部件 Public Sub QueryBOMRowToOpenUnkonwDocument(ByVal oBOMRows As BOMRowsEnumerator, ByVal FirstLevelOnly As Boolean) Dim i As Integer Dim iStepCount As Short 'Dim oBOMRows As BOMRowsEnumerator 'oBOMRows = oBOM.oBOMView.BOMRows iStepCount = oBOMRows.Count 'Create a new ProgressBar object. 'Dim oProgressBar As Inventor.ProgressBar 'oProgressBar = ThisApplication.CreateProgressBar(False, iStepCount, "当前文件： ") For i = 1 To oBOMRows.Count ' Get the current row. Dim oRow As BOMRow oRow = oBOMRows.Item(i) Dim FullFileName As String FullFileName = oRow.ReferencedFileDescriptor.FullFileName '测试文件 Debug.Print(FullFileName) ' Set the message for the progress bar 'oProgressBar.Message = FullFileName 'If InStr(FullFileName, ContentCenterFiles) > 0 Then '跳过零件库文件 ' GoTo 999 'End If '文件不存在，就打开父级文件 If IsFileExsts(FullFileName) = False Then Dim InventorDoc As Inventor.Document '父级文件名 FullFileName = oRow.ReferencedFileDescriptor.Parent.FullFileName InventorDoc = ThisApplication.Documents.Open(FullFileName, True) '打开文件，显示 End If '遍历下一级 If (Not oRow.ChildRows Is Nothing) And FirstLevelOnly = False Then Call QueryBOMRowToOpenUnkonwDocument(oRow.ChildRows, FirstLevelOnly) End If 999: 'oProgressBar.UpdateProgress() Next 'oProgressBar.Close() End Sub '尺寸精度圆整 Public Function SetDrawingDimPrecision() As Boolean Try SetStatusBarText() If IsInventorOpenDoc() = False Then Exit Function End If If ThisApplication.ActiveDocument.DocumentType <> kDrawingDocumentObject Then MsgBox("该功能仅适用于工程图", MsgBoxStyle.Information) Exit Function End If Dim oDrawingDocument As DrawingDocument oDrawingDocument = ThisApplication.ActiveDocument Dim oLinearGeneralDimension As LinearGeneralDimension '选择的部件或零件 ' 是否已经选择了尺寸 If oDrawingDocument.SelectSet.Count <> 0 Then For Each oSelect As Object In oDrawingDocument.SelectSet If oSelect.Type = ObjectTypeEnum.kLinearGeneralDimensionObject Then oSelect.Precision = 0 End If Next Else oLinearGeneralDimension = ThisApplication.CommandManager.Pick(kDrawingDefaultFilter, "选择要添加Φ的尺寸") If oLinearGeneralDimension Is Nothing Then '取消选择 Return True Exit Function End If oLinearGeneralDimension.Precision = 0 End If Catch ex As Exception MsgBox(ex.Message) End Try End Function End Module