'Programming by DWJ China Tianchang city QQ二次发开交流群：951736200/48805368 Thanks for Autodesk Rocky giving me help！'鼠标先选择零件 再运行
imports File = System.IO.File
Imports Path = System.IO.Path
Sub main()
If ThisDoc.Document.DocumentType = kPartDocumentObject Then
MsgBox("仅在部件环境中使用！", , "DWJ")
return
End If
On Error Resume Next
Dim oOcc As ComponentOccurrence
oOcc = ThisApplication.ActiveDocument.SelectSet.Item(1)
If Err.Number <> 0 Then
MsgBox("你必须选择一个零件！",,"DWJ")
Exit Sub
End If
On Error GoTo 0
Dim oDoc = oOcc.Definition.Document
Err.Clear
filepath = oDoc.fullfilename '获得全路径名称
Dim oFileName = IO.Path.GetFileNameWithoutExtension(filepath) '获取无扩展名的名称 ( returns: 1234)
FName = InputBox("零件名称是:", "请输入...", oFileName)
If FName = "" Then
FName = oldname
MsgBox("名称不能为空！", , "温馨提示DWJ：")
Return
End If
If FName = oFileName Then
MsgBox("名称不能为之前名称！或者相同", , "DWJ：")
Return
End If
On Error Resume Next
PP = IO.Path.GetDirectoryName(filepath) '得到的路径 (returns: C:\Temp\Test)
Dim oExt = IO.Path.GetExtension(filepath) '得到扩展 ( returns: .ipt)
Dim pathstr = PP + "\" + FName + oExt
If File.Exists(pathstr) Then
MsgBox("已存在同名文件！", , "DWJ")
Else
Err.Clear
oDoc.SaveAs(pathstr, False)
oOcc.Replace(pathstr, True)
My.Computer.FileSystem.DeleteFile(filepath, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin, FileIO.UICancelOption.DoNothing)
oDoc.PropertySets.Item("Design Tracking Properties").Item("part number").value=FName
Call idwdrawingnamechangefx(filepath, pathstr)'调用idw工程图修改子函数
Call dwgdrawingnamechangefx(filepath, pathstr)'调用dwg工程图修改子函数
Err.Clear
End If
End Sub
Sub idwdrawingnamechangefx(ByRef oldModelPath, ByRef NewModelPath)
Dim oldDrawingPath As String
Dim NewDrawingPath As String
oldDrawingPath = Strings.Left(oldModelPath, Strings.Len(oldModelPath) -3) + "idw" '老工程图路径
NewDrawingPath = Strings.Left(NewModelPath, Strings.Len(NewModelPath) -3) + "idw" '新工程图路径
IO.File.Copy(oldDrawingPath, NewDrawingPath)'复制工程图新的到指定路径
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.Documents.Open(NewDrawingPath, True)'打开复制后新工程图(打开窗口不显示)
Dim oFD As FileDescriptor
oFD = oDrawDoc.File.ReferencedFileDescriptors(1)
oFD.ReplaceReference(NewModelPath)' 替换引用文档为改名后的模型文档
My.Computer.FileSystem.DeleteFile(oldDrawingPath, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin, FileIO.UICancelOption.DoNothing)'删除旧工程图
oDrawDoc.Close(False)' 保存修改并关闭工程图
End Sub
Sub dwgdrawingnamechangefx(ByRef oldModelPath, ByRef NewModelPath)
Dim oldDrawingPath As String
Dim NewDrawingPath As String
oldDrawingPath = Strings.Left(oldModelPath, Strings.Len(oldModelPath) -3) + "dwg" '老工程图路径
NewDrawingPath = Strings.Left(NewModelPath, Strings.Len(NewModelPath) -3) + "dwg" '新工程图路径
IO.File.Copy(oldDrawingPath, NewDrawingPath)'复制工程图新的到指定路径
Dim oDrawDoc As DrawingDocument
oDrawDoc = ThisApplication.Documents.Open(NewDrawingPath, True)'打开复制后新工程图(打开窗口不显示)
Dim oFD As FileDescriptor
oFD = oDrawDoc.File.ReferencedFileDescriptors(1)
oFD.ReplaceReference(NewModelPath)' 替换引用文档为改名后的模型文档
My.Computer.FileSystem.DeleteFile(oldDrawingPath, FileIO.UIOption.OnlyErrorDialogs, FileIO.RecycleOption.SendToRecycleBin, FileIO.UICancelOption.DoNothing)'删除旧工程图
oDrawDoc.Close(False)' 保存修改并关闭工程图
End Sub
设计之上！
