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

  • #2
    Thank you for posting this. I already have been using this to save programs when I'm running large amounts of parts so I can go back and modify the alignments/reporting etc.
    I changed the UID variable to run_count to suit my purposes.

    One thing I'm struggling with is I will sometimes run programs with multiple subroutines and I want to save the individual subroutines. I put the script at the end of the subroutine, but I know that in your example its calling the active program.

    "Dim pcpart As Object
    Set pcpart = pcapp.activepartprogram"

    I've looked around the object browser and found the command Application.SetActive and was thinking this may be the command i'm looking for. I'm not sure on the correct syntax to "activate" another program though and was hoping you may be able to point me in the right direction.

    Thanks in advance

    Comment


    • #3
      Hmmm, I'm not sure how you'd do that - I tend not to use subroutines (apart from program start / header and footer / printing etc)

      Automettech - Automated Metrology Technology

      Comment


      • #4
        I think I'm getting closer to getting it to work. Its taking a little bit for me to test and everything in between part cycles so i may have to wait till the weekend..

        I'll update this with what I changed to get it to work.

        Comment


        • CodeWarrior
          CodeWarrior commented
          Editing a comment
          Also thanks again. Your script examples with the explanation comments are very helpful to understanding this stuff

      Related Topics

      Collapse

      Working...
      X