Whipped this up, when executed the user are prompted to enter a serial that is used to save the partprogram (to a new copy). Might come in handy for those running serial checks and want to keep the results for each part in it's own partprogram...
The serial is added to the partprogram filename:
Let's say that the partprogram name is 'Heatshield_1' and when entering the serial as 'number 1' the partprogram is saved as 'Heatshield_1_number 1.prg'.
Here is a change I made to VPT.SE's code.
I took out the input for serial number and have pc-dmis save the file using the current time and date as an extension to the file name.
Good luck.
' Displays an inputbox telling the user To enter a serialnumber
' Or other information that will be concatenated To the partprogram
' Name (partname) And saved In the current partprogram folder.
'
' ORIGINAL CODE by vpt.se 2010
'
Sub Main()
Dim PCDApp, PCDPartPrograms, PCDPartProgram
Set PCDApp = CreateObject("PCDLRN.Application")
Set PCDPartPrograms = PCDApp.PartPrograms
Set PCDPartProgram = PCDApp.ActivePartProgram
' my added code HR = HOUR(NOW) MN = MINUTE(NOW) SEC = SECOND(NOW) MON = MONTH(NOW) DY = DAY(NOW) YR = YEAR(NOW) 'my added code
Not sure why the original code was removed from this post. Hopefully vpt.se won't mind me posting an adaptation of his original code and code from Craiger_NY. There is definitly more that could be added to this, like the "Check if file exists", but it gets the job done as I need right now. Hopefully it will be helpful to someone.
Sub Main
' This Script will Append the serial number entered In the C1 Input comment In the PC-DMIS program
' To the part program Name And save the file into a folder named "RESULTS" that resides
' In the same directory As the part program. It will Then resave As the original part program Name In
' the original directory, ready To be executed again.
'---------------------------------------------------------------
' Create a Folder In the same directory As the Part Program called "RESULTS"
' Insert this code at beginning of PC-DMIS program:
' C1 =COMMENT/Input, NO, FULL SCREEN=NO,
' Enter Part Serial Number
' ASSIGN/SER_NUM=(C1.Input)
'-------------------------------------------------------------
Dim App As Object
Dim Part As Object
Dim Serial As Object
Dim strCrntName As String
Dim strPath As String
Dim strPrgName As String
Dim strNewName As String
Dim strNoExt As String
Dim bolPassFail As Boolean
Dim FindDot
Set App = CreateObject ("PCDLRN.Application")
Set Part = App.ActivePartProgram
Set Serial = Part.GetVariableValue ("SER_NUM")
strCrntName = Part.FullName
strPath = Part.Path
strPrgName = Part.Name
FindDot = InStr(1, strPrgName, ".")
strNoExt = Left(strPrgName, FindDot - 1)
strNewName = strPath & "RESULTS\" & strNoExt & "_" & Serial.StringValue & ".prg"
bolPassFail = Part.SaveAs (strNewName)
bolPassFail = Part.SaveAs (strCrntName)
End Sub
Not sure why the original code was removed from this post. Hopefully vpt.se won't mind me posting an adaptation of his original code and code from Craiger_NY. There is definitly more that could be added to this, like the "Check if file exists", but it gets the job done as I need right now. Hopefully it will be helpful to someone.
The original code were removed as a protest when the administrators went bananas Libya/Egypt/Syria-style on the users in the forum, banning them for different reasons (reasons which some were untrue).
Anyhow, feel free to modify the source in any way you want. But like others have done, please post your adaptation/modification of it so others can learn from it.
Here is the source with "fileexists" check:
' Displays an inputbox telling the user To enter a serialnumber
' Or other information that will be concatenated To the partprogram
' Name (partname) And saved In the current partprogram folder.
' If the file already exist, the user will be prompted and told
' to enter a new serial.
'
' vpt.se 2011
Sub Main()
Dim PCDApp, PCDPartPrograms, PCDPartProgram, fso
Set PCDApp = CreateObject("PCDLRN.Application")
Set PCDPartPrograms = PCDApp.PartPrograms
Set PCDPartProgram = PCDApp.ActivePartProgram
Set fso = CreateObject("Scripting.FileSystemObject")
ser$ = InputBox$("Enter serial number:", "Serial", "", 200, 175)
If ser$ <> "" Then
newname = PCDPartProgram.Path & PCDPartProgram.PartName & "_" & ser$ & ".PRG"
If Not fso.FileExists(newname) Then
retval = PCDPartProgram.SaveAs(newname)
Else
MsgBox "File exists - enter a new name!"
Main
End If
End If
' Cleanup
Set fso = Nothing
Set PCDPartProgram = Nothing
Set PCDPartPrograms = Nothing
Set PCDApp = Nothing
End Sub
