Auto Archive Freebie!

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Auto Archive Freebie!

    Hi All,

    Here's my script for archiving programs.

    Copy it to notepad and save it as AUTOARCHIVE.BAS

    NOTE / WARNING -- This script first saves the program with the current measurement data in it, then takes a copy of the file to archive.


    [CODE]
    'JON WOOD - 2013 - AUTOMETTECH LTD (UK) www.automettech.com

    Sub main()


    '========= SETTINGS =================

    'Root save directory For archive
    Dim archivePath
    archivePath = "C:\CMM\Archive\AutoArchive"

    'This is the Name of a PC-Dmis ASSIGNMENT - If it exist 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 = "C:\CMM Files\Part Program Run Instances Archive"
    'Part program = 123456-01.prg
    'Serial Number / Unique Id = abc123
    'DateTime = 24/08/2014 10:42:32


    '===========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 uid
    uid=""

    Dim myvar As Object
    Set myvar = pcpart.getvariablevalue(myUID)

    If Not myVar is Nothing Then
    uid = myvar.stringvalue
    'MsgBox(uid)
    End If

    'Genrate the destination (save) path
    dest_path = archivepath & "\" & progname & "\" & progname & "_" & uid & "_" & format(now(),"YYYYMMDDHHNNSS") & ".prg"
    'MsgBox(dest_path)


    'Save the file
    fso.copyfile source_path, dest_path


    'Tidy up
    Set fso = Nothing
    Set pcpart = Nothing
    Set pcapp = Nothing


    End Sub

    [CODE]


    Usage in part program...

    Code:
    
    ASSIGN/UID="abc123"
    
    
    CS5        =SCRIPT/FILENAME= C:\CMM FILES\SUBROUTINES\AUTOARCHIVE.BAS
                FUNCTION/Main,SHOW=YES,,
                STARTSCRIPT/
                ENDSCRIPT/
    Automettech - Automated Metrology Technology

Related Topics

Collapse

Working...
X