How can I save past runs as individual files

' Save_Copy_And_Write_Protect
'
' By Cris_C 9-12-2019
'
' Credit to NinjaBadger for the original program from which this was created.
' Post Link: https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/390021-auto-archive-freebie
'
' This Basic Script it to be called at the end of a measuring routine.
' It Saves the current measuring routine and then copies the .prg and the .cad file
' to a folder in the same directory as the measuring routine. The folder has the same
' name as the measuring routine .prg name with an "(Archive)" suffix.
' The copies are given a suffix made from operator inputs in the program (such as Serial number) and
' The date/time the copy was made.
' The copy of the .prg file and .cad file are then made Read-Only so data is not lost if someone tries
' to re-execute an archived program.

Sub main()

'Create objects------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Dim pcapp As Object
Set pcapp = createobject("pcdlrn.application")
Dim pcpart As Object
Set pcpart = pcapp.activepartprogram
Dim Cmd As Object
Dim Cmds As Object
Dim ComCmd As Object
Set Cmds = pcpart.Commands

'Figure out where To copy To/from-----------------------------------------------------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'Get the current prg And cad file path
Dim prg_source_path
Dim cad_source_path
prg_source_path = pcpart.fullname
cad_source_path = left(prg_source_path,len(prg_source_path)-4) & ".cad"

'Get program Name (without file extension)
Dim progname
progname = left(pcpart.Name,len(pcpart.Name)-4)

'Define the Archive Path
Dim archivepath
archivepath = left(pcpart.FullName,len(pcpart.FullName)-len(pcpart.Name)) & progname & "(Archive)"

'Get Additional Information from the CMM Program User inputs. --------------------------------------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'Go Through Each of the Commands In the program And Find all the comments. If a comment is an Input comment Then Get the Object And retrieve the user Input.
'take the user Input And concatinate it into one variable. Essentially making a chain of all the user inputs In the order they appear In the program.
Dim userinputs
For Each Cmd In Cmds
If Cmd.IsComment Then
Set ComCmd = Cmd.CommentCommand
If ComCmd.CommentType = 2 Then
userinputs = userinputs & ComCmd.Input & "-"
End If
End If
Next Cmd

'Replace Any characters that will mess up windows If you use them In a file Name. Also some that would be fine but I just don't like To see In a file Name.
Dim revisedinputs
For count=1 To Len(userinputs)
If mid(userinputs,count,1) = "/" Or mid(userinputs,count,1) = "\" Or mid(userinputs,count,1) = "<" Or mid(userinputs,count,1) = ">" Or mid(userinputs,count,1) = ":" Or mid(userinputs,count,1) = "." Or _
mid(userinputs,count,1) = ";" Or mid(userinputs,count,1) = "?" Or mid(userinputs,count,1) = "*" Or mid(userinputs,count,1) = "|" Or mid(userinputs,count,1) = "," Or mid(userinputs,count,1) = """" Then
newchar = "#"
Else
newchar = mid(userinputs,count,1)
End If
revisedinputs = revisedinputs & newchar
Next

'Make sure the inputs are Not too Long For a file Name, Limit it To an arbitrary 30 characters. It leaves lots of space For Long CMM Program names And date And time.
revisedinputs = left(revisedinputs,30)

'Complete the saving Name/path And Get ready To propt the user -----------------------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'Genrate the destination (save) paths
prg_dest_path = archivepath & "\" & progname & "(" & revisedinputs & ")_" & format(now(),"YYMMDDHHNNSS") & ".prg"
cad_dest_path = archivepath & "\" & progname & "(" & revisedinputs & ")_" & format(now(),"YYMMDDHHNNSS") & ".cad"

'Create the Long String of text that will be used In the OK/Cancel Message box
Dim Msg
Msg = "The CMM measuring is complete." & chr(13)
Msg = Msg & chr(13)
Msg = Msg & "Would you like to save the current CMM program and also create a backup with the following name and location?" & chr(13)
Msg = Msg & chr(13)
Msg = Msg & prg_dest_path & chr(13)
Msg = Msg & chr(13)
Msg = Msg & "Click OK to save CMM program and make a backup." & chr(13)
Msg = Msg & "Click CANCEL to skip the saving/backup operation." & chr(13)

'Create title For mesasge box
MsgTitle = "CMM Program Backup Utility"


'Create File System Object For file operations
'Note: This Object is Not documented In the PC-DMIS help file. More details On it can be found On the Microsoft wesite. Try this link:
'https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filesystemobject-object
Dim fso As Object
Dim fo As Object
Set fso = createobject("scripting.filesystemobject")

'Display the OK/Cancel Message box And save/copy If user clicks OK. If the user clicks OK it will return a 1. -----------------------------------------------------------
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
If MsgBox(Msg,1,MsgTitle) = 1 Then
'Save existing program
pcpart.save
'Check If the destination folder exists, If Not Then create one
If Not fso.folderexists(archivepath) Then
Set ofolder = fso.createfolder(archivepath)
End If
'Copy the program And the cad file
fso.copyfile prg_source_path, prg_dest_path
fso.copyfile cad_source_path, cad_dest_path
'Create a file Object pointing To the coppied program And cad file. Then make the program Read-Only.
Set fo = fso.GetFile(prg_dest_path)
fo.Attributes = 1
Set fo = fso.GetFile(cad_dest_path)
fo.Attributes = 1
End If

'Tidy up -----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Set fso = Nothing
Set pcpart = Nothing
Set pcapp = Nothing
Set Cmd = Nothing
Set Cmds = Nothing
Set ComCmd = Nothing

End Sub