'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)
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
设计之上！
