Sub main()
'========= SETTINGS =================
'Root save directory For archive
Dim archivePath
archivePath = "S:\Dept\Quality\Inspection\CMM files\Parts in Buffer Programs"
'This is the Name of a PC-Dmis ASSIGNMENT - If it exists the value it holds will be used In the file Name
'of the archived program (i.e. can be a serial number, Or order number etc)
Dim myUID
myUID = "UID"
'NOTE! - File Name will be In the following format...
'SaveDirectory\Program Name\ProgramName_UniqueID_DateTime.prg
'i.e. C:\CMM Files\Part Program Run Instances Archive\123456-01\123456-01_abc123_20140824104232.prg
'Where...
'archivePath = "S:\Dept\Quality\Inspection\CMM files\Parts in Buffer Programs"
'Part program = 123456-01.prg
'Serial Number / Unique Id = abc123
'DateTime = 24/08/2014 10:42:32
Dim strCrntName As String
Dim strNewName As String
Dim bolPassFail As Boolean
Dim Part As Object
Set App = CreateObject ("PCDLRN.Application")
Set Part = App.ActivePartProgram
Set DmisApp = CreateObject ("PCDLRN.Application")
Set DmisPart = DmisApp.ActivePartProgram
strCrntName = Part.FullName
'===========End OF SETTINGS==========
'Create objects
Dim pcapp As Object
Set pcapp = createobject("pcdlrn.application")
Dim pcpart As Object
Set pcpart = pcapp.activepartprogram
'Save existing program
pcpart.save
'Get the current program path
Dim source_path
source_path = pcpart.fullname
'Get program Name (without file extension)
Dim progname
progname = left(pcpart.Name,len(pcpart.Name)-4)
'Create File System Object For file operations
Dim fso As Object
Set fso = createobject("scripting.filesystemobject")
'Check main archive directory And program specific directories exist
Dim ofolder As Object
If Not fso.folderexists(archivepath) Then
Set ofolder = fso.createfolder(archivepath)
End If
If Not fso.folderexists(archivepath & "" & progname) Then
Set ofolder = fso.createfolder(archivepath & "" & progname)
End If
'Get a UID If present
Dim uniqueid
uniqueid=""
Dim myvar As Object
Set myvar = pcpart.getvariablevalue("SER_NUM")
If Not myVar is Nothing Then
uniqueid= myvar.stringvalue
'MsgBox(uniqueid)
End If
'Genrate the destination (save) path
dest_path_prg= archivepath & "" & progname & "" & progname & "_" & myvar.StringValue & "_" & format(now(),"YYYYMMDDHHNN") & ".PRG"
dest_path_cad= archivepath & "" & progname & "" & progname & "_" & myvar.StringValue & "_" & format(now(),"YYYYMMDDHHNN") & ".CAD"
'MsgBox(dest_path)
'Save the file
fso.copyfile source_path, dest_path_prg
fso.copyfile source_path, dest_path_cad
'Tidy up
Set fso = Nothing
Set pcpart = Nothing
Set pcapp = Nothing
End Sub
