hexagon logo
Register Sign in
  • Replies 20 replies
  • Subscribers 36 subscribers
  • Views 665 views
  • Users 0 members are here
Options
Related

Auto Archive Freebie!

NinjaBadger
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. 


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

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

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

'Genrate the destination (save) path
dest_path = archivepath & "\" & progname & "\" & progname & "_" & uniqueid & "_" & 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/
  • 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
  • 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)

  • 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.

    UPDATE:

    I couldn't find a way to make it work using subroutines.

    The solution I came up with was to launch, execute, close multiple programs from a script in excel or visual studio while using your script inside the individual part programs.
    Here's the link for the script I modified:


    https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/32023-automated-execution-of-several-consecutive-programs

    Below is the finished code: 
    Sub ExcelMultiRun()


Dim PCDApp, PCDPartProgram, PCDProgramCommand


''

Set PCDApp = CreateObject("PCDLRN.Application")

    PCDApp.Visible = True

Set PCDPartProgram = PCDApp.PartPrograms


'''Program #1

    PCDPartProgram.Open "C:\CMM Programs\_CMM Programs\Operator Programs\53015-10FPC1.PRG", "CMM1"

Set PCDProgramCommand = PCDApp.ActivePartProgram


    PCDProgramCommand.Execute 'Executes part program..



    PCDProgramCommand.Close   'Closes Program (and saves)


'''Program #2

    PCDPartProgram.Open "C:\CMM Programs\_CMM Programs\Operator Programs\53015-10AUDC1.PRG", "CMM1"

Set PCDProgramCommand = PCDApp.ActivePartProgram


    PCDProgramCommand.Execute 'Executes part program..



    PCDProgramCommand.Close   'Closes Program (and saves)


' Cleanup
Set PCDProgramCommand = Nothing
Set PCDPartProgram = Nothing
Set PCDApp = Nothing


End Sub
  • in reply to CodeWarrior
    Also thanks again. Your script examples with the explanation comments are very helpful to understanding this stuff
  • Nice! I've been tasked to make something like this, this will certainly shorten the work. Slight smile
  • Question on this. Is there a way to get DMIS to save the program when it is done executing without a special nomenclature. I want it to basically do a "CRTL + S" when the execution is finished.

    Here is the problem. We have been running lights out and every now and then we come in the next morning and the computer has restarted with out the program being saved. Last night, we lost 5 hours of CMM run time due to this. All of our programs are on our network then transferred to the local C drive and ran from there so a simple save when the program is done (overwrite itself on the C drive) is ok because we always have the master program on the network.
  • That's whats done first in the script 

    '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

[COLOR=#cccccc]'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[/COLOR]


End Sub
  • I've updated the OP to deal with the change in 2019 onwards where protected keywords can't be used in scripts.
© 2024 Hexagon AB and/or its subsidiaries. Privacy Policy | Cloud Services Agreement