Using a Macro to create a copy of existing .ipt + .idw
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hi,
I made a small macro to save a existing part under a new name and a new folder. My probleme is that if I open the part from an assembly the part will be saved with the right name and in the right folder but the part the part in the assembly will also change.
Is there anyone who faced the same probleme ?
See code:
Sub COPY_PART_DRAWING_RESET_R0()
Dim oPart As PartDocument
Dim oDraw As DrawingDocument
Dim oExtension, oName, oPartNum, oPath, oFolder, oDirectory, oSearch, oFind As String
Dim limitCount As Integer
Dim oDesigne, oSummary, oDesigneDraw, oSummaryDraw As PropertySet
'Charge the document
Set oPart = ThisApplication.ActiveDocument
oPath = oPart.FullFileName
oPath = Left(oPath, Len(oPath) - 4) & ".idw"
'Retrive information
Set oDesigne = oPart.PropertySets.Item("Design Tracking Properties")
Set oSummary = oPart.PropertySets.Item("Summary Information")
oName = oDesigne.Item("Description").Value
If oName = "" Then
oName = oSummary.Item("Title").Value
End If
comeback:
oPartNum = InputBox("Enter new Part Number", "STEP1")
If oPartNum Like "##?######" Or oPartNum Like "S#######*" Then
Else
MsgBox ("Invalid Part Number")
limitCount = limitCount + 1
If limitCount = 3 Then
GoTo endoftheworld
End If
GoTo comeback
End If
' Standart verification 1) Folder exists 2) File exists
If oPartNum Like "S*" Then
oFolder = Left(oPartNum, 8)
oDirectory = "\\MATRIX2\Engineering\PARTS\S\"
oSearch = Dir(oDirectory & oFolder & "*", vbDirectory)
If oSearch <> "" Then
oFolder = oSearch
Else
MsgBox ("Project Folder does not exist")
GoTo endoftheworld
End If
oFind = Dir(oDirectory & oFolder & "\" & oPartNum & ".iam", vbDirectory)
If oFind <> "" Then
MsgBox ("Assembly Number Already exists")
GoTo comeback
End If
oDirectory = oDirectory & oFolder & "\" & oPartNum
Else
oFolder = Left(oPartNum, 2)
oDirectory = "\\MATRIX2\Engineering\PARTS\" & oFolder
oFind = Dir(oDirectory & "\" & oPartNum & ".iam", vbDirectory)
If oFind <> "" Then
MsgBox ("Assembly Number Already exists")
GoTo comeback
End If
oDirectory = oDirectory & "\" & oPartNum
End If
oName = InputBox("Enter Part Description/Title", "STEP2", oName)
'Dim oDesigne As PropertySet
'Set nPropCPA1 = nCPASSY.PropertySets.Item("Summary Information")
'nPropCPA1.Item("Description").Value = "STARWHEEL ASSY" & nBottlecc & "(Ø" & NDiam & " x " & nHaut & ")"
'nPropCPA1.Item("Part Number").Value = nCPAssynum
'Open Drawing, save as new part#, change references
Set oDraw = ThisApplication.Documents.Open(oPath, True)
oPart.SaveAs oDirectory & ".ipt", True
oDraw.SaveAs oDirectory & ".idw", True
oPart.Close
oDraw.Close
Set oDraw = ThisApplication.Documents.Open(oDirectory & ".idw", True)
Set oPart = ThisApplication.Documents.Open(oDirectory & ".ipt", True)
Set oDesigne = oPart.PropertySets.Item("Design Tracking Properties")
Set oSummary = oPart.PropertySets.Item("Summary Information")
oDraw.ActiveSheet.DrawingViews(1).ReferencedDocumentDescriptor.ReferencedFileDescriptor.ReplaceReference _
(oDirectory & ".ipt")
Set oDesigneDraw = oPart.PropertySets.Item("Design Tracking Properties")
Set oSummaryDraw = oPart.PropertySets.Item("Summary Information")
oDesigne.Item("Description").Value = oName
oDesigneDraw.Item("Description").Value = oName
oDesigne.Item("Part Number").Value = oPartNum
oDesigneDraw.Item("Part Number").Value = oPartNum
oDesigne.Item("Designer").Value = "Copy"
oDesigneDraw.Item("Designer").Value = ""
oSummary.Item("Title").Value = oName
oSummaryDraw.Item("Title").Value = oName
oSummary.Item("Revision Number").Value = 0
oSummaryDraw.Item("Revision Number").Value = 0
oSummary.Item("Author").Value = "Copy"
oSummaryDraw.Item("Author").Value = ""
oPart.Update
oDraw.Update
endoftheworld:
End Sub
