Single scan measurementA single scan measurement generated by the WiRE2 spectral acquisition wizard.VBScript' StdMeasurement.vbs - Copyright (C) 2001 Renishaw plc ' ' This is the VBScript code used for a standard data acquisition ' ' The basic measurement supports performing a single scan of any ' configured scan type using the configured instrument state. It ' also supports a time series collection where a number of data collections ' may be taken from the same point over a period of time. ' ' Required Named Items: ' InstrumentState : the desired hardware state for running this measurement ' Scan : A configured scan object ' FocusTrack : The Focus Track object ' ' Properties used: ' MeasurementType : a string name for the type of measurement. ' AcquisitionCount : the number of acquisitions to be done, as defined by the wizard. ' ' TimeSeriesCount : The number of data collections to do ' TimeSeriesInterval: The delay between each collection ' BleachTime : An optional delay before data collection to allow sample ' bleaching. ' ' DepthSeriesStartPos :The start position for the depth series. ' DepthSeriesFinalPos : The final position for the depth series. ' DepthSeriesInterval : The vertical step size between each point. ' DepthSeriesCount : The number of points in a depth series acquisition ' ' TemperatureSeriesCount : The number of steps in a temperature series. ' TemperatureSeriesInterval : The interval in degrees C for each step ' TemperatureSeriesStart : The starting temperature for the measurement ' TemperatureSeriesRamp : The rate of temperature change. ' TemperatureSeriesFinal : The temperature to set before exiting. Can be used to restore the initial temp. ' TemperatureSeriesHold : The hold time in ms after each temperature has been achieved before collecting. Optional ' or ' TemperatureRamps : The temperature ramps object ' FocusTrackEnabled : Are we using focus track? ' FocusTrackInterval : Perform focus every nth scan ' ' UserTriggeredMeasurement: show a dialog before each acqusition to allow the user to trigger ' CollectTemperatureValue: for every acquisition, read the TMS temperature ' MaximizeWhitelight: show whitelight unless actually acquiring raman data ' ' imageCapture : 0 = None, 1 = Before, 2 = After, 3 = Both ' imageCapturePause: number of millisecs to wait for the white light to settle. ' illuminationLampOn: flag indicating whether or not the illumination lamp should ' be used for the image capture. N.B The image capture mode ' can be triggered from either the imageCapture flag above OR ' from the Temperature measurements; this flag is applicable to both. ' ' autoSaveInterval: The number of scans to do before each interim save. ' reportCameraStatus: request some additional debugging information from the camera ' responseCalibration: enable or disable the use of Response Calibration ' restoreInstrumentState: preserve and restore the instrument state after running ' closeLaserShutter: force the laser shutter closed on measurement complete. ' cycling: boolean flag set to true if this is a cycling measurement. ' minimizeLaserExposure: keep the laser shutter closed as much as possible ' persistentTempFile: true if unnamed measurements create persistent temp files (default: true) Option Explicit Const s_Version = "3.2.2.2400" ' The following comments load symbols from these type libraries. ' TypeLib: WIRESYSTEMLib 1.0 = {f8c953c2-00fc-11d5-8004-005004f62988} ' TypeLib: WIREMOTORSLib 1.0 = {6F067EE0-6158-11D4-94D9-005004F62988} ' TypeLib: WIREXYZLib 1.0 = {DAE0FF43-C76E-11D4-8945-00003C508B6F} ' TypeLib: WIREAREAKEYLib 1.0 = {D3C457FF-7171-4AFF-9FA9-3A53DE868978} ' TypeLib: WIREFILEHANDLERLib 1.0 = {561A42DF-1A4C-46DD-97B3-0FCA9CB4FBF5} ' TypeLib: WIRESCAN2Lib 1.0 = {9EFE94A0-77E8-11D5-A49F-0060B0CE0147} ' TypeLib: WIREPODULELib 1.0 = {34BEA794-3631-4B81-8961-38AAF888D694} ' TypeLib: WiRETemperatureRampsLib 1.0 = {5B8E254F-3C0F-4FEA-B7B5-A5469D6848F4} ' ------------------------------------------------------------------------- ' Scan use mode. Private Const eSingleScan = 0 Private Const eCompleteSeries = 1 Private Const eInteruptedSeries = 2 Private Const eCustomSeries = 3 ' ------------------------------------------------------------------------- ' Series scan features. can be OR'd together Private Const eSingle = 0 Private Const eTiming = 1 ' eTime is one of WIREFILEHANDLERLib.EDataType Private Const eDepths = 2 Private Const eThermal = 4 ' eTemperature is one of EDataType Private Const eXYArea = 8 Private Const eTriggeredSeries = 16 Private Const eThermal2 = 32 ' uses the temperature ramps object. Not so much a temperature series as a simple series with temperatures 'Private Const eTriggeredSeries = 16 ' see above ' Our timed-out failure scan completion status string. Private Const g_sFailedTimeout = "Failed Timed out" ' ------------------------------------------------------------------------- ' Global Variables ' Private g_nUpdates : g_nUpdates = 0 Private g_bDebugMeasurement : g_bDebugMeasurement = False Private g_bSleeping : g_bSleeping = False Private g_InstrumentStateApplied : g_InstrumentStateApplied = -1 Private Logger : Set Logger = Nothing Private Acquisition : Set Acquisition = Nothing Private Instrument : Set Instrument = Nothing Private ResponseCalibration : Set ResponseCalibration = Nothing Private g_oInitialState : Set g_oInitialState = Nothing Private g_parentHWND : g_parentHWND = 0 Private g_AbortReqCount : g_AbortReqCount = 0 ' used to skip the abort requests if called more than 3 times. Private g_bUseCollectWarning : g_bUseCollectWarning = True ' Should the user see the collection warning dialog on non-podule systems Private g_sDataCollectTitle : g_sDataCollectTitle = "WiRE 3: Check laser position on sample" Private g_sDataCollectMessage : g_sDataCollectMessage = "" Private g_sImageCollectTitle : g_sImageCollectTitle = "WiRE 3: Check sample is visible" Private g_sImageCollectMessage : g_sImageCollectMessage = "" ' ------------------------------------------------------------------------- ' Main -- ' This is the entry point for running the whole measurement script. ' If you need to debug a measurement by running it without all the error ' catching, you should either edit this function, or set the debugMeasurement ' measurement property. eg By evaluating this: ' Application.Measurement.Properties("debugMeasurement") = True Public Function Main() g_sDataCollectMessage = "%nThe system is about to collect data.%nPlease ensure that the laser is on the sample and then select OK to continue.%n" g_sImageCollectMessage = "%nThe system is about to collect a video image of the sample.%nPlease check that the sample is visible in the video and then select OK to continue.%n" On Error Resume Next g_bDebugMeasurement = CBool(Measurement.Properties("debugMeasurement")) g_parentHWND = CLng(Measurement.Properties("HWND")) On Error Goto 0 If g_bDebugMeasurement Then Set Main = DebugMain Else Set Main = StandardMain End If End Function ' ------------------------------------------------------------------------- ' This main function doesn't catch errors. This means that the Designer ' can identify the real location of an error in your script and display the ' location of the error. ' Public Function DebugMain() Set Logger = New CLogger Logger.Log "Starting Debugging Acquisition Measurement " & s_Version Activity FormatMessage("Starting Debugging Acquisition Measurement %1", s_Version) g_bDebugMeasurement = True CommonMain Set DebugMain = Measurement.Result End Function ' ------------------------------------------------------------------------- ' Full error handling main. Any errors occurring in the script are caught ' and returned as Error elements in the result memory file. ' Private Function StandardMain() Set Logger = New CLogger Dim sMsg Logger.Log "Starting Standard Acquisition Measurement " & s_Version Activity FormatMessage("Starting Standard Acquisition Measurement %1", s_Version) Measurement.Result.Add "ScanCompletionStatus", "Incomplete" On Error Resume Next Dim bRestoreInstrumentState : bRestoreInstrumentState = False Dim bCloseLaserShutter : bCloseLaserShutter = False Dim bCycling : bCycling = False Dim oShell : Set oShell = CreateObject("WScript.Shell") ' Read the old values then overwrite with new value -- makes us tolerant of being run on old systems. bRestoreInstrumentState = oShell.RegRead("HKCU\Software\Renishaw\Renishaw WiRE 2.0\Settings\MeasurementRestoreState") bRestoreInstrumentState = oShell.RegRead("HKCU\Software\Renishaw\WiREInterface.exe\Settings\MeasurementRestoreState") bCloseLaserShutter = oShell.RegRead("HKCU\Software\Renishaw\Renishaw WiRE 2.0\Settings\MeasurementCloseShutter") bCloseLaserShutter = oShell.RegRead("HKCU\Software\Renishaw\WiREInterface.exe\Settings\MeasurementCloseShutter") bCycling = CBool(Measurement.Properties("cycling")) ' override registry settings with local settings (may not be present) bRestoreInstrumentState = CBool(Measurement.Properties("restoreInstrumentState")) bCloseLaserShutter = CBool(Measurement.Properties("closeLaserShutter")) Activity FormatMessage("Recording initial instrument state") Set g_oInitialState = CreateObject("Renishaw.WiREInstStateCom") g_oInitialState.System = System g_oInitialState.InitialiseFromSystem Err.Clear CommonMain If Err.Number <> 0 Then If Measurement.Result Is Nothing Then Activity FormatMessage("The measurement result property is invalid.") Else Measurement.Result.Add "ErrorCode", Err.Number Measurement.Result.Add "ErrorSource", Err.Source Measurement.Result.Add "ErrorDescription", Err.Description If Measurement.Result("ScanCompletionStatus") = "Normal" Then Measurement.Result.Add "ScanCompletionStatus", "Failed" End If Dim sErr : sErr = Err.Source & ": " & Err.Description Logger.Error sErr : Activity sErr End If ' error clean up added to fix bug 2614 (probably caused when the MSO ' was moved down into the Acquisition. If Not Acquisition.MSO Is Nothing Then Set Acquisition.MSO = Nothing DisconnectObject System End If End If If bRestoreInstrumentState Then ConnectObject System, "System_" RestoreInitialInstrumentState bCloseLaserShutter DisconnectObject System ElseIf bCloseLaserShutter Then ConnectObject System, "System_" Set Instrument = New CInstrument InstrumentState.ShutterOpen = False Instrument.Init InstrumentState, System Instrument.ApplyLampsAndMotors DisconnectObject System Set Instrument = Nothing End If Set g_oInitialState = Nothing On Error Goto 0 Set StandardMain = Measurement.Result End Function ' Apply the initial instrument state and optionally force the laser shutter closed Private Sub RestoreInitialInstrumentState(bForceCloseLaserShutter) If Not(g_oInitialState Is Nothing) Then Activity FormatMessage("Restoring intial instrument state") If bForceCloseLaserShutter Then g_oInitialState.ShutterOpen = False Set Instrument = New CInstrument Instrument.Init g_oInitialState, System Instrument.ApplyLampsAndMotors Set Instrument = Nothing End If End Sub Private Function CommonMain() ' pass the parent's HWND to the System if g_parentHWND <> 0 then System.ParentHWND = g_parentHWND InstrumentState.ParentHWND = g_parentHWND Logger.Log "Setting the parent HWND to " & CStr(g_parentHWND) end if ' busy lamp removed to allow access from CAcquisition class Dim oBusyLamp : Set oBusyLamp = New CAutoMultiSequenceOperation Set oBusyLamp.System = System oBusyLamp.Name = "Measurement" oBusyLamp.Start ' Initialize the Acquisition data and run Activity FormatMessage("Initializing: Test Area Key") g_AbortReqCount = 0 ' reset the abort request count. ' Check the instrument state object Dim vAreaKeyTest: vAreaKeyTest = System.TestAreaKey (InstrumentState.AreaKey) if CStr(vAreaKeyTest) <> "0" then Err.Raise vbObjectError + 1, "CommonMain", vAreaKeyTest end if ' Raise the Measurement initialised event. Activity FormatMessage("Initializing: RaiseMeasurementInitialised") Measurement.RaiseMeasurementInitialised ' Create the internal Acquisition object and perform basic sanity checking. On Error Goto 0 Set Acquisition = New CAcquisition If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description Set Acquisition.MSO = oBusyLamp Activity FormatMessage("Initializing %1 measurement", Acquisition.AcquisitionTypeName) Dim sMmtType : sMmtType = Measurement.Properties("MeasurementType") Dim aMmtType : aMmtType = Split(sMmtType, " ") On Error Resume Next sMmtType = aMmtType(0) On Error Goto 0 If sMmtType <> Acquisition.AcquisitionTypeName Then Logger.Warn "Measurement type string do not match! (" & sMmtType _ & " != " & Acquisition.AcquisitionTypeName & ")" End If 'Acquisition.Init System, Scan, Measurement ' Connect to the system for events Activity FormatMessage("Initializing: Connect to system") ConnectObject System, "System_" Scan.System = System ' Use the instrument state area key Scan.AreaKey = InstrumentState.AreaKey ' If we have a mapping-on-the-fly specification, apply it now. Dim oMapSpec : Set oMapSpec = Nothing On Error Resume Next Set oMapSpec = Measurement.NamedItems("MappingSpecification") If Not oMapSpec Is Nothing Then Set Scan.MappingSpecification = oMapSpec End If On Error Goto 0 ' ensure that the instrument is in the correct areakey so that the grating and calibration ' parameters are correct. Set Instrument = New CInstrument Instrument.Init InstrumentState, System ' copy over our required instrument state parameters Instrument.ApplyAreaKey ' and apply the specified areakey. Set Instrument = Nothing ' Move the grating to the correct region to avoid potential timeouts InitializeGrating ' This is a good place to call one-off measurement initializations for user-modified measurements. ' MoveToOrigin ' Initialize the Response Calibration Dim bUseCalibration : bUseCalibration = False On Error Resume Next bUseCalibration = Measurement.Properties("responseCalibration") On Error Goto 0 Scan.UseResponseCal = bUseCalibration ' Apply the instrument state - this sets the following in order ' applies the areakey ' then podule motors, beam expander, pinhole, waveplates, NDs, ' and then the laser shutter. Set Instrument = New CInstrument Instrument.Init InstrumentState, System ' set the podule path to external or internal depending on the microscope ModPodulePathForMicroscope InstrumentState, System dim oILock: Set oILock = System.HostedObject(eSHO_INTERLOCK) dim bInterlockAtStart: bInterlockAtStart = oILock.InterlockStatus(0) ' 0 is eILC_INTERLOCK dim interlockRelaysAtStart: interlockRelaysAtStart = oILock.RefreshRelayState dim shutterPos: shutterPos = InstrumentState.ShutterOpen ' store the shutter open in case we want to force it closed ' check to see if the measurement is accidentally being run with no laser if (InstrumentState.RunSilent = true AND _ oILock.InterlockChainClosed = false AND _ InstrumentState.ShutterOpen = true) then Measurement.Result.Add "InterlockPreventedOpeningOfShutter", true end if if (Acquisition.MinimizeLaserShutter() = true) then ' in temp series mmts, there might be a long delay before the first acq so ' we should start with the laser shutter closed. InstrumentState.ShutterOpen = false end if If Acquisition.MaximizeWhitelight Then Instrument.ApplyAllWhitelight ElseIf Acquisition.ImageCaptureBeforeDataCollection then ' this prevents the podule being driven to the wrong position if ' an image is to be captured before data collection. ' The downside of this is that the recorded inst state will not reflect the ' data collection state, but the image capture state. Instrument.ApplyForImageCapture Acquisition.ImageCapture.IlluminationLampOn Else Instrument.Apply End If InstrumentState.ShutterOpen = shutterPos ' restore the laserShutter state to what it should be. Instrument.Record g_nUpdates = 0 ' Store the version of WiRE used to run this measurement On Error Resume Next Dim oSHO : Set oSHO = System.HostedObject(WIRESYSTEMLib.eSHO_PROPERTIES) Measurement.Result.Add "WiRE2 Version", oSHO.Item("WiRE2 Version") g_bUseCollectWarning = CBool(oSHO.Item("MeasurementCollectWarningEnabled")) On Error Goto 0 ' Store the firmware version number of the CCD on which this measurement is run. On Error Resume Next Dim oFWVersion: Set oFWVersion = System.HostedObject(WIRESYSTEMLib.eSHO_CAMERA_VERSION) If oFWVersion.Emulating then Measurement.Result.Add "CCD emulating" Else Measurement.Result.Add "CCD not emulating" End if Measurement.Result.Add "CCD serial number", oFWVersion.serialNumber Measurement.Result.Add "CCD firmware version", oFWVersion.firmwareVersion Measurement.Result.Add "CCD plm version", oFWVersion.plmVersion On Error Goto 0 ' Store the username running this measurement On Error Resume Next Dim wshNet : Set wshNet = CreateObject("WScript.Network") Measurement.Result.Add "User", wshNet.UserName On Error Goto 0 ' Set the estimated completion time and status elements Measurement.Result.Add "ScanCompletionStatus", "Incomplete" Measurement.Result.Add "lastScanCompletionStatus", "Incomplete" Measurement.Properties("ETA") = DateAdd("s", TimeToComplete()/1000, UTCNow()) Measurement.Result.Add "RevisedDuration", Scan.DurationEstimate * Acquisition.Count Measurement.Result.Add "StartTime", UTCNow() ' Setup the result data file parameters for this measurement type Dim dataOriginIndex: dataOriginIndex = 0 Dim alternateOriginIndex: alternateOriginIndex = 0 ' Are we using X and Y positions? If (Acquisition.AcqType AND eXYArea) = eXYArea Then AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eX_SPATIAL, WIREFILEHANDLERLib.eMICROMETRES, "X" dataOriginIndex = dataOriginIndex + 1 AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eY_SPATIAL, WIREFILEHANDLERLib.eMICROMETRES, "Y" dataOriginIndex = dataOriginIndex + 1 End If ' Are we using Z (depth) positions? If (Acquisition.AcqType AND eDepths) = eDepths Then AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eZ_SPATIAL, WIREFILEHANDLERLib.eMICROMETRES, "Z" dataOriginIndex = dataOriginIndex + 1 End If ' Are we using Timing? If (Acquisition.AcqType AND eTiming) = eTiming Then AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eTIME, WIREFILEHANDLERLib.eSECONDS, "Elapsed Time" dataOriginIndex = dataOriginIndex + 1 End If ' Are we using Temperature? If (Acquisition.AcqType AND eThermal) = eThermal Then AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eTEMPERATURE, WIREFILEHANDLERLib.eKELVIN, "Temperature" dataOriginIndex = dataOriginIndex + 1 End If ' Are we a user-triggered series? If (Acquisition.AcqType AND eTriggeredSeries) = eTriggeredSeries then AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eTIME, WIREFILEHANDLERLib.eSECONDS, "Elapsed Time" dataOriginIndex = dataOriginIndex + 1 AddAlternativeOriginInfo alternateOriginIndex, WIREFILEHANDLERLib.eTEMPERATURE, WIREFILEHANDLERLib.eCELCIUS, "Temperature" alternateOriginIndex = alternateOriginIndex + 1 elseif (Acquisition.AcqType AND eThermal2) = eThermal2 Then AddDataOriginInfo dataOriginIndex, WIREFILEHANDLERLib.eTIME, WIREFILEHANDLERLib.eSECONDS, "Elapsed Time" dataOriginIndex = dataOriginIndex + 1 AddAlternativeOriginInfo alternateOriginIndex, WIREFILEHANDLERLib.eTEMPERATURE, WIREFILEHANDLERLib.eCELCIUS, "Temperature" alternateOriginIndex = alternateOriginIndex + 1 AddAlternativeOriginInfo alternateOriginIndex, WIREFILEHANDLERLib.eDERIVED, WIREFILEHANDLERLib.eKELVINPERMINUTE, "Ramp rate" alternateOriginIndex = alternateOriginIndex + 1 End If If (dataOriginIndex > 0) then Measurement.Result.Add "dataOriginCount", dataOriginIndex End If If (alternateOriginIndex > 0) then Measurement.Result.Add "alternativeOriginCount", alternateOriginIndex End If ' If we have an Image named item then save XPath query into Result. On Error Resume Next Dim oImage : Set oImage = Measurement.NamedItems("Image") If Err.Number = 0 Then Measurement.Result.Add "whiteLightImage", "?xpath?/WiREXMLDoc/MeasurementInformation/Measurement/NamedItems/Image" End If On Error Goto 0 ' Support cycling measurements. Dim bCycling : bCycling = False On Error Resume Next bCycling = CBool(Measurement.Properties("cycling")) On Error Goto 0 Dim bWasCycling : bWasCycling = bCycling Do If bCycling Then Acquisition.WaitForSystem 250 ' wait for the system to be idle. (#3819) MinimalDoScan Else ' Run the measurement (optionally without all the error handling). If Not g_bDebugMeasurement Then On Error Resume Next Acquisition.Run UpdateResultErrors Err.Number, Err.Description, Err.Source If Acquisition.AcqType = eThermal Then Acquisition.CheckFinalTemperature On Error Goto 0 End If On Error Resume Next bCycling = CBool(Measurement.Properties("cycling")) On Error Goto 0 If bCycling Then Activity FormatMessage("Cycling measurement") Loop While bCycling If TypeName(Measurement.Result) = "WiREMemoryFileCom" Then Activity FormatMessage("FinalizeResult") Measurement.Result = FinalizeResult(Measurement.Result, bWasCycling) Else Dim nFile For nFile = 1 To Measurement.Result.Count Activity FormatMessage("FinalizeResult for file %1", nFile) FinalizeResult Measurement.Result.Item(nFile), bWasCycling Next End If ' record the state of the interlock on completion. dim bInterlockAtEnd: bInterlockAtEnd = oILock.InterlockStatus(0) ' 0 is eILC_INTERLOCK dim interlockRelaysAtEnd: interlockRelaysAtEnd = oILock.RefreshRelayState ' record the interlock chain and peripheral info. ' this means that if the interlock is tripped at any stage, then ' client software can determine where the trip occurred. Measurement.Result.Add "InterlockChainAtEnd", oILock.interlockChainStatus Measurement.Result.Add "InterlockPeripheralsAtEnd", oILock.interlockPeriphals Measurement.Result.Add "InterlockOKStart", bInterlockAtStart Measurement.Result.Add "InterlockOKEnd", bInterlockAtEnd Measurement.Result.Add "InterlockRelaysStart", interlockRelaysAtStart Measurement.Result.Add "InterlockRelaysEnd", interlockRelaysAtEnd Set Acquisition.MSO = Nothing DisconnectObject System Measurement.Result.Add "EndTime", UTCNow() Activity FormatMessage("Completed") If g_bDebugMeasurement Then Measurement.Result.Save "c:\debugging.wxd", 0, True Logger.Log "Standard Acquisition Measurement Completed." Set CommonMain = Measurement.Result End Function Private Function AddDataOriginInfo(index, OriginType, OriginUnits, OriginName) Measurement.Result.Add "dataOriginType" & CStr(index), OriginType Measurement.Result.Add "dataOriginUnits" & CStr(index), OriginUnits Measurement.Result.Add "dataOriginName" & CStr(index), OriginName End Function Private Function AddAlternativeOriginInfo(index, OriginType, OriginUnits, OriginName) Measurement.Result.Add "AlternativeOriginType" & CStr(index), OriginType Measurement.Result.Add "AlternativeOriginUnits" & CStr(index), OriginUnits Measurement.Result.Add "AlternativeOriginLabel" & CStr(index), OriginName End Function Private Function FinalizeResult(oResult, bWasCycling) ' Move the temporary status string over the official string If Not(bWasCycling) Then oResult.Element("", "ScanCompletionStatus") = oResult.Element("", "lastScanCompletionStatus") End If ' Clear up the activity trace elements On Error Resume Next oResult.RemoveElement "", "CurrentScanNumber" oResult.RemoveElement "", "RevisedDuration" oResult.RemoveElement "", "lastScanCompletionStatus" Dim nCn : nCn = Measurement.Properties("AcquisitionCount") If nCn <> g_nScan Then Logger.Warning "AcquitionCount and g_nScan disagree!" Measurement.Properties("AcquisitionCount") = g_nScan On Error Goto 0 ' bug #1963: Add CustomProperties items from the System. Dim oSysProps : Set oSysProps = System.HostedObject(WIRESYSTEMLib.eSHO_PROPERTIES) On Error Resume Next Dim oCustomProps : Set oCustomProps = oSysProps.Item("CustomProperties") If IsObject(oCustomProps) Then Dim vKey For Each vKey In oCustomProps.Keys oResult.Element("", CStr(vKey)) = oCustomProps.Item(vKey) Next End If ' bug #3030: NumberOfPoints must be updated after linefocus mapping oResult.Add "NumberOfPoints", oResult.Element("","collectedDatasets").Count ' Write the recorded instrument state into the result Instrument.WriteState oResult ' move the on error goto 0 to below adding the NumberOfPoints to the Result. On Error Goto 0 ' Bug 3141 - On HF3077 scan error messages are lost Set FinalizeResult = oResult End Function ' Update the result memory file with any error information. Private Sub UpdateResultErrors(nCode, sDescription, sSource) If TypeName(Measurement.Result) = "WiREMemoryFileCom" Then UpdateResultFileErrors Measurement.Result, nCode, sDescription, sSource Else Dim nFile For nFile = 1 To Measurement.Result.Count UpdateResultFileErrors Measurement.Result.Item(nFile), nCode, sDescription, sSource Next End If End Sub Private Sub UpdateResultFileErrors(oResult, nCode, sDescription, sSource) If nCode = 0 Then oResult.Add "ErrorCode", nCode Dim sStatus: sStatus = oResult.Element("", "lastScanCompletionStatus") If sStatus = g_sFailedTimeout Then oResult.Add "ErrorDescription", sStatus oResult.Add "ErrorSource", "StdMeasurement_Main" End If Else oResult.Add "ErrorCode", nCode oResult.Add "ErrorSource", sSource oResult.Add "ErrorDescription", sDescription Dim sErr : sErr = sSource & ": " & sDescription Logger.Error sErr : Activity sErr End If End Sub ' ' ------------------------------------------------------------------------- ' ' Handle scan events and waiting for scan complete. This minimal version is ' called when we are doing a cycling measurement. In this case we avoid the ' data manipulations involved in creating a properly formed measurement ' result. ' Private g_bMinimalScanComplete Private g_bMinimalScan : g_bMinimalScan = False Public Function MinimalDoScan g_bMinimalScan = True g_bMinimalScanComplete = False On Error Resume Next Scan.MeasurementHandle = Measurement.Properties("queueHandle") On Error Goto 0 Scan.DoScan2 System, g_parentHWND MinimalWaitForScanComplete 1000, 480000 g_bMinimalScan = False End Function Public Sub MinimalWaitForScanComplete(nCheckInterval, nMaxTimeout) Dim nTime : nTime = 0 Do While Not(g_bMinimalScanComplete) And nTime < nMaxTimeout Dim nWaited: nWaited = Sleep2(nCheckInterval) nTime = nTime + CLng(nWaited) Loop If Not(g_bMinimalScanComplete) Then Err.Raise vbObjectError + 1, "WaitForScanComplete", "Wait timeout" End If End Sub ' ------------------------------------------------------------------------- Class CAcquisition Private m_eMode ' Mode of use for the acquisition. Single scan, custom series, complete series or interupted series Private m_eType ' type can be eSingle, eTiming, eDepthSeries Private m_nCount ' the number of scans to perform in a series Private m_nInterval ' the interval between scans in milliseconds or depth step size Private m_nInitialValue ' the initial value for a series (if needed) Private m_nBleachTime ' the number of milliseconds to laser bleach the sample. Private m_nScan ' the number of the current scan Private m_dtSeriesStart ' the time we began the first scan. Private m_dtScanStart ' the time we started the current scan Private m_nAvgScanTime ' the average elapsed real time taken for scans Private m_bScanComplete ' flag set whenever a scan completes Private m_eTermination ' copy of the scan termination status (ok, failed, aborted) Private m_bTimedOut ' flag set true if a scan times out. Private m_oTStage ' object wrapper for controlling a temperature stage Private m_oCameraWrapper ' additional camera status reporting object Private m_nMapPoints ' size of the points array Private m_Point ' the target point when using the XYZ stage Private m_nRate ' set the rate of change for temperature or other dimensions Private m_nTSHoldms ' the time in ms to pause at each temperature before collecting. Private m_bFocusTrackEnabled Private m_nFocusTrackInterval Private m_bFocusTrackComplete Private m_dFocalPoint ' the last focus track focal position (or the current Z-position) Private m_nAutoSaveInterval Private m_aMapDepths ' Depth slice depth positions. Private m_nMapDepths ' Number of depth slice positions. Private m_sFocusTrackCompletionString Private m_eFocusTrackCompletionCode Private m_oScanResult ' Temporary storage of the scan result so we can delay the sending of scan complete events Private m_nMapPointIndex ' Index into the map points array. Private m_bHaltAfterScan ' to let the acquisition know that it should stop after the next scan Private m_bHaltAfterAcc ' Private m_bLineFocusMapping ' Is this a linefocus mapping measurement? Private m_nLastUID ' the last unique dataset number. Private m_oImageCapture ' image capture object Private m_oMSO ' the multi sequence operation object Private m_bSaturationMod ' Saturation protection modification of the ND percent or exposure time Private m_bSaturated ' Data saturation has been detected Private m_dSaturationNDPercent ' ND value used for saturation avoidance Private m_lSaturationExpTime ' Exposure time value used for saturation avoidance Private m_bMinimalShutter ' Flag to control minimizing laser exposure on sample Private m_oShutterIS ' Shutter control instrument object Private m_nTemperatureCount ' Number of temperatures in the series Private m_nTimeSeriesCount ' Number of collections in a time series Private m_LastDatasetCount ' Number of items in the collected datasets collection after the previous scan. Private m_nTrueCount ' Expected number of scans. Actually reflects the number of scans or fast mapping scans Private m_lastSave ' when the last save was done. Type VariantTime. Private m_bCollectTemperatureValues ' true if we should read the TMS temperature each scan Private m_bMaximizeWhitelight ' true to switch to whitelight after every scan Private m_oTempRamps ' Temperature ramps object Private m_bCollectTempProfile ' Collect a temperature profile dataset, and add it into the result Private m_oTempDL ' A datalist containing the temperatures Private m_oTimeDL ' A datalist containing the times at which temperatures were read Private m_dExpTime ' The scan exposure time last time we started the scan Private m_nAccs ' The number of accumulations last time we started a scan Private m_dLaserPower ' The laser power (ND percent) last time we started a scan Private m_oMPL ' A dictionary item containing a log of changes to the measurement params Public Property Get ScanCount() : ScanCount = m_nTrueCount: End Property Public Property Get MSO() : Set MSO = m_oMSO : End Property Public Property Set MSO(oMSO) : Set m_oMSO = oMSO : End Property Public Property Get TemperatureStage() : Set TemperatureStage = m_oTStage : End Property Public Property Get HaltAfterScan(): HaltAfterScan = m_bHaltAfterScan : End Property Public Property Get HaltAfterAcc(): HaltAfterAcc = m_bHaltAfterAcc : End Property Public Property Get MaximizeWhitelight() : MaximizeWhitelight = m_bMaximizeWhitelight : End Property Public Property Get MinimizeLaserShutter() : MinimizeLaserShutter = m_bMinimalShutter : End Property Public Property Get ImageCapture() : Set ImageCapture = m_oImageCapture : End Property Private Sub Class_Initialize m_eMode = eSingle m_lastSave = 0 m_nCount = 0 m_nTrueCount = 0 ' Expected number of scans. Actually reflects the number of scans or fast mapping scans m_nInterval = 0 m_eTermination = WIRESYSTEMLib.eWAS_OK m_bScanComplete = true m_bTimedOut = False m_bHaltAfterScan = False m_bHaltAfterAcc = False m_nInitialValue = 0 m_eType = eSingle m_nAutoSaveInterval = 0 m_dFocalPoint = 0.0 m_nRate = 10 m_nTSHoldms=0 ' no hold time for temperature stage initially m_nAvgScanTime = 0 m_nMapDepths = 0 m_nMapPointIndex = 0 m_nLastUID = 0 m_nTemperatureCount = 0 m_LastDatasetCount = 0 m_bCollectTemperatureValues = False m_bMaximizeWhitelight = False ' m_sFocusTrackCompletionCode is reset in pre-scan Set m_oTStage = Nothing Set m_oCameraWrapper = Nothing Set m_oScanResult = Nothing Set m_oTempRamps = Nothing Set m_oImageCapture = New CImageCapture m_bMinimalShutter = False m_bCollectTempProfile = False Set m_oShutterIS = Nothing set m_oMPL = Nothing On Error Resume Next m_nBleachTime = Measurement.Properties("BleachTime") m_bFocusTrackEnabled = False m_bFocusTrackEnabled = Measurement.Properties("FocusTrackEnabled") m_nFocusTrackInterval = Measurement.Properties("FocusTrackInterval") m_bCollectTemperatureValues = Measurement.Properties("CollectTemperatureValues") m_bMaximizeWhitelight = Measurement.Properties("MaximizeWhitelight") m_dExpTime = Scan.ExpTimeInMillSecs m_nAccs = Scan.NumOfAccumulations m_dLaserPower = InstrumentState.NDPercent System.ScanType = Scan.ScanType ' needed to identify between depthslice and streamlineHR depth slice. ' Check for custom series If m_eMode = eSingle Then Err.Clear m_nCount = Measurement.Properties("customScanCount") If Err.Number = 0 Then If m_nCount > 1 Then m_eMode = eCustomSeries Else m_nCount = 0 End If End If End If If m_eMode = eSingle Then Err.Clear Dim bTriggered : bTriggered = False bTriggered = Measurement.Properties("UserTriggeredMeasurement") If bTriggered Then Logger.Debug "Setting acquisition type to eTriggered series" m_eMode = eInteruptedSeries m_eType = eTriggeredSeries m_nCount = Measurement.Properties("AcquisitionCount") m_nTrueCount = m_nCount Scan.CustomLoopCount = m_nCount End If End If ' Check for area map If m_eMode = eSingle Then LogMessage "Searching for measurement configuration" m_nCount = 1 Err.Clear ' Check for depth series m_nMapDepths = Measurement.Properties("DepthSeriesCount") If m_nMapDepths <> 0 Then m_nInterval = Measurement.Properties("DepthSeriesInterval") m_nInitialValue = Measurement.Properties("DepthSeriesStartPos") End If Err.Clear Dim oMapArea : Set oMapArea = Measurement.NamedItems("MapArea") If m_nMapDepths > 1 then if Err.Number <> 0 then ' No map area object, but we want one for the depth series info Err.Clear Set oMapArea = CreateObject("Renishaw.WiREMapAreaCom") End If oMapArea.SetMappingDepths m_nInitialValue, m_nInterval, m_nMapDepths End If If Err.Number = 0 Then System.WiREMapArea = oMapArea Scan.MapArea = oMapArea Scan.SetLinefocusParams GetLinefocusStepSize, CalculateYCenterPixel ' XY map m_eMode = eCompleteSeries m_nMapPoints = oMapArea.TotalPointsCount If m_nMapPoints > 0 And Err.Number = 0 Then ' If we can do fast mapping then do it. m_eType = m_eType OR eXYArea m_nCount = m_nCount * m_nMapPoints End If ' Map with Z info Err.Clear m_nMapDepths = oMapArea.GetAllMappingDepths(m_aMapDepths) ' If we say this is a depth map then it adds a Z data origin. The scan does not understand this for XY maps ' or streamline maps, because they would be volume maps, which we don't do. ' Therefore, don't say this is a depth map unless there is more than 1 depth. if m_nMapDepths > 1 then m_eType = m_eType OR eDepths m_nCount = m_nCount * m_nMapDepths end if End If ' Time info m_nTimeSeriesCount = Measurement.Properties("TimeSeriesCount") If m_nTimeSeriesCount > 1 Then m_eType = m_eType OR eTiming m_nCount = m_nCount * m_nTimeSeriesCount If m_nMapDepths > 1 Then m_nCount = m_nCount * m_nMapDepths End If Err.Clear If (m_nTimeSeriesCount > 1 OR m_nBleachTime > 0) Then Dim nTimeSeriesInterval : nTimeSeriesInterval = 0 nTimeSeriesInterval = Measurement.Properties("TimeSeriesInterval") If Err.Number <> 0 Then Logger.Error "Failed to read TimeSeriesInterval for time series measurement. Using default value of 0" End If Scan.SetTimeSeriesInfo nTimeSeriesInterval, m_nTimeSeriesCount, m_nBleachTime End If ' Check for temperature series set m_oTempRamps = Measurement.Properties("TemperatureRamps") m_nTemperatureCount = Measurement.Properties("TemperatureSeriesCount") If IsObject(m_oTempRamps) And Not(m_oTempRamps Is Nothing) Then m_eType = eThermal2 m_nCount = 2000 m_nRampID = 1 Scan.CustomLoopCount = m_nCount m_eMode = eInteruptedSeries m_bCollectTempProfile = True ElseIf m_nTemperatureCount > 1 Then m_eType = eThermal m_nCount = m_nCount * m_nTemperatureCount m_nInterval = Measurement.Properties("TemperatureSeriesInterval") m_nInitialValue = Measurement.Properties("TemperatureSeriesStart") m_nRate = Measurement.Properties("TemperatureSeriesRamp") m_nTSHoldms = Measurement.Properties("TemperatureSeriesHold") Scan.CustomLoopCount = m_nTemperatureCount End If m_nTrueCount = m_nCount Dim sInfo : sInfo = "" If (m_nTemperatureCount > 1 Or m_bFocusTrackEnabled Or (m_bSaturationMod) _ Or (m_oImageCapture.CaptureMode <> 0) Or m_eType = eThermal2 ) Then m_eMode = eInteruptedSeries sInfo = "Doing interupted series of " & CStr(m_nTrueCount) & " scans." _ & " Time: " & CStr(m_nTimeSeriesCount) _ & " Temp: " & CStr(m_nTemperatureCount) _ & " FT: " & CBool(m_bFocusTrackEnabled) _ & " Sat: " & CBool(m_bSaturationMod) _ & " Image: " & CBool(m_oImageCapture.CaptureMode <> 0) Else m_nCount = 1 m_eMode = eCompleteSeries sInfo = "Doing complete series of " & CStr(m_nTrueCount) & " scans." _ & " Time: " & CStr(m_nTimeSeriesCount) _ & " Temp: " & CStr(m_nTemperatureCount) _ & " FT: " & CBool(m_bFocusTrackEnabled) _ & " Sat: " & CBool(m_bSaturationMod) _ & " Image: " & CStr(m_oImageCapture.CaptureMode) End If Logger.Log sInfo : LogMessage sInfo End If ' Get the map measurement autosave interval (in number of scans) m_nAutoSaveInterval = Measurement.Properties("autoSaveInterval") ' Get the FocusTrack usage ' Check for minimal laser shutter flag. m_bMinimalShutter = Measurement.Properties("minimizeLaserExposure") If m_bMinimalShutter Then Set m_oShutterIS = New CInstrument m_oShutterIS.Init InstrumentState, System End If Scan.MinimiseLaserExposure = m_bMinimalShutter ' Log some details about the camera state ReportCameraStatus On Error Goto 0 If m_nCount = 0 Then m_nCount = 1 Dim sErrMsg ' Initialize for temperature series measurement If (m_eType AND eThermal) = eThermal Then Logger.Log "Initialize for temperature series measurement" Set m_oTStage = New CTemperatureStage m_oTStage.Init System m_oTStage.Ramp = m_nRate Sleep 100 ' Try and read the temperature from the stage. ie: check it works. Dim n, t, e, src : e = vbObjectError + 1 On Error Resume Next For n = 0 To 6 Activity FormatMessage("Reading current temperature from the TMS stage") t = m_oTStage.Temperature e = Err.Number : src = Err.Source : sErrMsg = Err.Description Err.Clear If e = 0 Then Exit For Next On Error Goto 0 If e <> 0 Then Err.Raise e, src, sErrMsg End If ElseIf (m_eType AND eThermal2) = eThermal2 Then Set m_oTStage = New CTemperatureStage m_oTStage.Init System m_bCollectTemperatureValues = False ElseIf m_bCollectTemperatureValues Then Set m_oTStage = New CTemperatureStage m_oTStage.Init System m_oTStage.Ramp = m_nRate End If if (m_bCollectTempProfile) then set m_oTempDL = CreateObject("Renishaw.WiREDataListCom") set m_oTimeDL = CreateObject("Renishaw.WiREDataListCom") end if ' Check for linefocus mapping measurements m_bLineFocusMapping = False On Error Resume Next m_bLineFocusMapping = CBool( Measurement.Properties("LineFocusMode") ) On Error Goto 0 If m_bLineFocusMapping Then Logger.Debug "line focus mapping enabled" ' Check we have a valid FocusTrack object if this is enabled. We could create one, but it shouldn't ' happen. The Wizard is supposed to sort this for us. If m_bFocusTrackEnabled Then If IsObject(FocusTrack) And Not(FocusTrack Is Nothing) Then Set FocusTrack.System = System If FocusTrack.UseInstStateAreaKey Then FocusTrack.InstrumentState.AreaKey = InstrumentState.AreaKey End If FocusTrack.parentHWND = g_parentHWND Logger.Debug "Initialising focustrack with system object" Else sErrMsg = "FocusTrack is enabled but no FocusTrack named item is present!" Logger.Error sErrMsg Err.Raise vbObjectError + 1, "Acquisition_Init", sErrMsg End If End If End Sub Public Property Get SeriesStartTime() SeriesStartTime = m_dtSeriesStart End Property Public Property Get ScanStartTime() ScanStartTime = m_dtScanStart End Property Public Property Get SampleBleachTime() SampleBleachTime = m_nBleachTime End Property Public Sub StopAfterScan m_bHaltAfterScan = True if (m_eMode = eCompleteSeries AND m_nTrueCount > 1) then ' Doing a fast map scan with multiple points. Abort it after the current scan Scan.AbortAfterMapScan End If Activity FormatMessage("scanning") 'TestForAbort ' do it now if we can. End Sub Public Sub StopAfterAcc If m_bScanComplete Then System.Abort WIRESYSTEMLib.eWAS_USER_ABORT m_eTermination = WIRESYSTEMLib.eWAS_USER_ABORT ' just in case a sequence was not running. Else Scan.AbortAtEndOfAccumulation m_bHaltAfterAcc = True Activity FormatMessage("scanning") End If End Sub Private Sub TestForAbort If (Not(IsScanRunning()) And (m_bHaltAfterScan or m_bHaltAfterAcc)) Then Logger.Log "Mmt TestForAbort aborting" 'System.Abort WIRESYSTEMLib.eWAS_USER_ABORT m_eTermination = WIRESYSTEMLib.eWAS_USER_ABORT ' because a sequence may not be running. Else Logger.Log "mmt TestForAbort not aborting; scanrunning = " & CStr(IsScanRunning()) End If End Sub Public Property Get CurrentScan() CurrentScan = m_nScan End Property Public Property Get Count() Count = m_nCount End Property Public Property Get AcqType() AcqType = m_eType End Property Public Property Get AcqMode() AcqMode = m_eMode End Property ' These are set by the Wizard as Measurement.Properties("MeasurementType") Public Property Get AcquisitionTypeName() Select Case m_eType Case eSingle AcquisitionTypeName = "SingleScan" Case eTiming AcquisitionTypeName = "TimeSeries" Case eDepths AcquisitionTypeName = "DepthSeries" Case eThermal AcquisitionTypeName = "TemperatureSeries" Case eXYArea AcquisitionTypeName = "AreaMap" Case (eDepths OR eXYArea) AcquisitionTypeName = "AreaMap DepthSlice" Case eCustomSeries AcquisitionTypeName = "Custom Series" Case eTriggeredSeries AcquisitionTypeName = "UserSeries" Case eThermal2 AcquisitionTypeName = "Temperature Controlled Series" Case Else AcquisitionTypeName = "UnknownType" End Select End Property Public Property Get Interval() Interval = m_nInterval End Property Public Property Get Aborted() Aborted = (m_eTermination = WIRESYSTEMLib.eWAS_USER_ABORT) And Not(m_bTimedOut) End Property Public Property Get Failed() Failed = (m_eTermination = WIRESYSTEMLib.eWAS_FAILED_TO_START) _ Or (m_eTermination = WIRESYSTEMLib.eWAS_FAILED_SEQUENCE) _ Or (m_eTermination = WIRESYSTEMLib.eWAS_CAMERA_DISCONNECTED) _ Or m_bTimedOut End Property Public Sub CheckFinalTemperature() On Error Resume Next If m_eType = eThermal Then Dim dEstFinal: dEstFinal = m_nInitialValue + (m_nInterval * (m_nCount - 1)) Dim dActFinal: dActFinal = m_oTStage.Temperature Dim dReqFinal: dReqFinal = Measurement.Properties("TemperatureSeriesFinal") Dim s : s = FormatMessage("Final sample temperature %1 °C.", FormatNumber(dActFinal-AbsoluteZero,1)) If dReqFinal <> dEstFinal Then s = s & " " & FormatMessage("Asynchronously setting to %1 °C.", FormatNumber(dReqFinal-AbsoluteZero,1)) m_oTStage.SetTemperatureAsync dReqFinal End If Logger.Debug s : Activity s End If End Sub Public Function DisplayValue(oMemFile, vValue, eUnits) On Error Resume Next Dim sDisplay : sDisplay = CStr(vValue) Dim sUnits : sUnits = oMemFile.DataUnitDescription(eUnits) If Err.Number = 0 Then sDisplay = sDisplay & " " & sUnits End If On Error Goto 0 DisplayValue = sDisplay End Function Public Property Let TerminationStatus(newVal) m_eTermination = newVal End Property Public Property Get TerminationStatus() TerminationStatus = m_eTermination End Property ' Revise the duration estimate for this acquisition (in ms) Public Property Get DurationEstimate() Dim nScansLeft : nScansLeft = (m_nCount - m_nScan - 1) If m_nAvgScanTime = 0 Then Dim nInterval : nInterval = 0 If m_eType = eTiming Then nInterval = m_nInterval DurationEstimate = (Scan.DurationEstimate * nScansLeft) + (nInterval * nScansLeft) Else DurationEstimate = m_nAvgScanTime * nScansLeft End If End Property Public Sub ScanComplete() m_bScanComplete = True End Sub Public Property Get FocalPoint() FocalPoint = m_dFocalPoint End Property ' FocusTrack results we want added to the next dataset (FT is run during the pre-scan). ' This means we know which DS the FT operated on. Public Sub FocusTrackComplete(bSuccess, dCentre, oMemFile) Dim sMsg : sMsg = "" Dim eCode : eCode = 0 ' 0 is eFSS_UNINITIALISED On Error Resume Next sMsg = FocusTrack.CompletionString eCode = FocusTrack.CompletionStatus On Error Goto 0 m_sFocusTrackCompletionString = sMsg m_eFocusTrackCompletionCode = eCode Logger.Debug "FocusTrack completed with centre " & FormatNumber(dCentre) & ", code " & eCode & " """ & sMsg & """" Activity FormatMessage("FocusTrack completed with centre %1, code %2 '%3'", FormatNumber(dCentre), eCode, sMsg) m_dFocalPoint = dCentre m_bFocusTrackComplete = True End Sub Public Sub Run() ReportCameraStatus m_dtSeriesStart = UTCNow() Dim nSumScanTime : nSumScanTime = 0 m_nAvgScanTime = 0 m_nScan = 0 ' Check if the scan zeldac type is measurement. If it is we need to tell the scan it's being run for the first time CheckZeldacForFirstScan Do While (m_nScan < m_nCount Or ((m_eType And eTriggeredSeries) = eTriggeredSeries) _ Or ((m_eType And eThermal2) = eThermal2)) m_dtScanStart = UTCNow() If Not(PreScan) Then Exit Do End If If m_eMode = eCompleteSeries And m_nScan = 0 Then PostScan ' Do a file save now so that we can resave by simply calling save with no file name End If If Me.Aborted Then Exit Do ' TimeSeries sleep / Temperature ramp may be aborted. Dim sCompleted If m_nCount < 1 Then Activity FormatMessage("Beginning scan.") sCompleted = FormatMessage("Completing scan.") Else Activity FormatMessage("Beginning scan %1 of %2", m_nScan + 1, m_nCount) sCompleted = FormatMessage("Completing %1 of %2", m_nScan + 1, m_nCount) End if DoScan Scan ' uses global Scan object Activity sCompleted ReportCameraStatus ' update the end condition On Error Resume Next Err.Clear If m_eMode = eCustomSeries Then m_nCount = Measurement.Properties("customScanCount") Logger.Debug "Read customScanCount: " + CStr(m_nCount) ElseIf (m_eType AND eXYArea) = eXYArea Then ' retrieve move state Dim bNoMove : bNoMove = False bNoMove = CBool(Measurement.Properties("dontMoveStage")) If (Err.Number = 0) And (bNoMove = true) Then ' additional scans. update end condition m_nCount = m_nCount + 1 End If End If On Error Goto 0 TestForAbort ' if AbortAfterScan/Acc was called this cause me.Aborted to be TRUE. If Me.Aborted Then Exit Do ' must be after the TestForABort. PostScan nSumScanTime = nSumScanTime + (DateDiff("s", m_dtScanStart, UTCNow()) * 1000) m_nAvgScanTime = nSumScanTime / (m_nScan + 1) Logger.Debug "Average scan completion time at scan " & m_nScan & " is " & CStr(m_nAvgScanTime / 1000) & "s." If (m_eType and eThermal2) = eThermal2 Then if (Not UpdateRampState) Then Exit Do End If Dim bNoIncrement : bNoIncrement = False On Error Resume Next bNoIncrement = CBool(Measurement.Properties("dontIncrementDatasetIndex")) If Not bNoIncrement Then m_nScan = m_nScan + 1 Logger.Debug "End of run loop. m_nScan = " + CStr(m_nScan) + " m_nCount = " + CStr(m_nCount) On Error Goto 0 Loop If ((m_eType And eTriggeredSeries) = eTriggeredSeries) or _ ((m_eType And eThermal2) = eThermal2) Then Scan.FinalizeMapping Measurement.Result If ((m_eType And eThermal2) = eThermal2) Then On Error Goto 0 Dim sDSName: sDSName = "DataSet" + CStr(Measurement.Result.NumberOfDataSets) Dim sDSLabelKey: sDSLabelKey = "dataSetLabels" + CStr(Measurement.Result.NumberOfDataSets) ' Thermal2 measurements collect the temperature profile as we go along. ' We now need to insert this data into the result Measurement.Result.CreateDataList sDSName, "DataList0", 0, False Measurement.Result.CreateDataList sDSName, "DataList1", 0, False Measurement.Result.Data(sDSName, "DataList0", 0, -1) = m_oTimeDL.Data(0, -1) Measurement.Result.Data(sDSName, "DataList1", 0, -1) = m_oTempDL.Data(0, -1) Measurement.Result.Element("", sDSLabelKey) = "Temperature profile" ' Add dataset metadata Dim oDS: set oDS = Measurement.Result.Element("", sDSName) oDS.NumberOfDataLists = 2 oDS.Add "dataListUnits0", WIREFILEHANDLERLib.eSECONDS oDS.Add "dataListType0", WIREFILEHANDLERLib.eTIME oDS.Add "dataListLabels0", "Elapsed Time / s" oDS.Add "dataListUnits1", WIREFILEHANDLERLib.eCELCIUS oDS.Add "dataListType1", WIREFILEHANDLERLib.eTEMPERATURE oDS.Add "dataListLabels1", "Temperature / °C" Dim oARs: set oARs = Measurement.Result.GetNewAnalysisResults() Dim oAR : set oAR = CreateObject("Renishaw.WiREAnalysisResultCom") oAR.Type = "Temperature profile" oAR.Result = sDSName oAR.Version = s_Version Dim oNet: Set oNet = CreateObject("WScript.Network") ' Get the username from the Wsh Network object oAR.Operator = oNet.UserName oAR.ReadOnly = True oARs.Add(oAR) Set oAR = Nothing set oARs = Nothing Set oNet = Nothing End if If Not (m_oMPL Is Nothing) Then On Error Resume Next ' Measurement params changed during the measurement set oARs = Measurement.Result.GetNewAnalysisResults() set oAR = CreateObject("Renishaw.WiREAnalysisResultCom") oAR.Type = "Measurement parameter change log" oAR.Result = m_oMPL oAR.Version = s_Version Set oNet = CreateObject("WScript.Network") ' Get the username from the Wsh Network object oAR.Operator = oNet.UserName oAR.ReadOnly = True oARs.Add(oAR) End if If Me.Aborted Then Dim sStatus: sStatus = Measurement.Result.Element("", "lastScanCompletionStatus") If sStatus = "Incomplete" Then Measurement.Result.Element("", "lastScanCompletionStatus") = "Aborted" Measurement.Result.Add "ErrorDescription", "Measurement aborted." End If End If ' Ensure that the video is left in USER mode EnsureUserVideoMode DisconnectFocusTrack ' added to ensure it does not hold itself or the system open. End Sub Private Sub CheckZeldacForFirstScan On Error Resume Next dim res: res = System.TestAreaKey( Scan.AreaKey) Logger.Log "Getting Zeldac object from system: " & res dim oZeldac: set oZeldac = System.HostedObject(WIRESYSTEMLib.eSHO_PER_AREAKEY_ITEMS).itemByID("zeroLevel_darkCurrent", Scan.AreaKey.ID) if Err.Number = 0 then if oZeldac.ExpiryType = 1 then ' 1 = EZeldacExpiryType::eZET_MEASUREMENT oZeldac.UpdateOnNextScan = true Logger.Log "Setting Zeldac::UpdateOnNextScan to true" end if else Logger.Error "Failed to retrieve the Zeldac object. " & Err.Description end if Err.Clear On Error Goto 0 End Sub ' Ensure that the video is left in USER mode Private Sub EnsureUserVideoMode Logger.Debug "EnsureUserVideoMode" If IsObject(System) then Dim CurrentVideoMode CurrentVideoMode=System.VideoUseMode If CurrentVideoMode <> eUSERVIDEO Then System.VideoUseMode=eUSERVIDEO End If Else Logger.Error "System is NULL" End If End Sub Private m_nRampID Private m_bRampStarted Private m_rampStart Private m_currentRamp Private m_increment Private m_lastCollection Private m_bRampPaused Private m_RampElapsed Private Function ContinueMeasurement() Dim bContinue: bContinue = False On Error Resume Next bContinue = Measurement.Properties("continueMeasurement") If Err.Number <> 0 Then bContinue = True ' flag not present so continue On Error Goto 0 ContinueMeasurement = bContinue End Function Private Function RampPaused() Dim bPaused: bPaused = False On Error Resume Next bPaused = Measurement.Properties("rampPaused") If Err.Number <> 0 Then bPaused = False ' flag not present so continue On Error Goto 0 RampPaused = bPaused End Function ' called to determine if we want to capture images ' before we collect data so we know where to start the podule. Public Function ImageCaptureBeforeDataCollection() ImageCaptureBeforeDataCollection = False Dim ICM: ICM = m_oImageCapture.CaptureMode ' try to tread the Image capture mode from the temperature series if there is one. If ((m_eType and eThermal2) = eThermal2) Then If m_oTempRamps Is Nothing Then _ set m_oTempRamps = Measurement.Properties("TemperatureRamps") if (m_oTempRamps.Count > 0) Then Dim oRamp: Set oRamp = m_oTempRamps.Item(1) ICM = oRamp.ImageCaptureMode End if End if If ICM = 1 or ICM = 3 Then ' 1 is BEFORE and 3 is BOTH ImageCaptureBeforeDataCollection = True End if End Function Private Function RampToNextCollection() Do While (not me.aborted) If (Not m_bRampStarted) Then m_bRampPaused = RampPaused if (m_bRampPaused) then ' If the ramping is paused then we cannot start the ramp ' Collect the current temperature the the profile Dim T T = m_oTStage.ReadQuietly - 273.15 ' Add the current temperature to the plot m_oTempDL.Add T m_oTimeDL.Add ElapsedTime ' However, we may still collect if the continueMeasurement flag is true if (ContinueMeasurement) then RampToNextCollection = true Exit Function End If Sleep2(500) else ' Start the next ramp section if (m_nRampID > m_oTempRamps.Count) then ' No more ramps. RampToNextCollection = false Exit Function else set m_currentRamp = m_oTempRamps.Item(m_nRampID) dim ICM : ICM = m_currentRamp.ImageCaptureMode if (ICM = WiRETemperatureRampsLib.eICM_NONE) then m_oImageCapture.CaptureMode = 0 elseif (ICM = WiRETemperatureRampsLib.eICM_BEFORE) then m_oImageCapture.CaptureMode = 1 elseif (ICM = WiRETemperatureRampsLib.eICM_AFTER) then m_oImageCapture.CaptureMode = 2 elseif (ICM = WiRETemperatureRampsLib.eICM_BOTH) then m_oImageCapture.CaptureMode = 3 end if if (m_currentRamp.DataCollectionMode = WiRETemperatureRampsLib.eDCM_INCL_START or _ m_currentRamp.DataCollectionMode = WiRETemperatureRampsLib.eDCM_INCL_BOTH) then ' Don't start the ramp here. We'll start it in post scan ' Just drop out because this is the time to take the first scan of this ramp. RampToNextCollection = true Exit Function Else StartRamp m_currentRamp End if End If End If End If if (m_bRampStarted) then dim res: res = WaitForNextCollection if (res <> 2) then RampToNextCollection = (1 = res) exit Function end if end if Loop End Function ' Called to update the temperature ramps progress after a scan. Return false if we should finish the measurement ' now, or true if we should continue on Private Function UpdateRampState() if (RampPaused) then ' Ramps are paused. We cannot complete while paused UpdateRampState = true elseif (Not m_bRampStarted) then ' If we've got to post scan and the ramp hasn't been started, then we can assume ' that the data collection mode means that the ramp should be started after the first scan ' Start the ramp now StartRamp m_currentRamp UpdateRampState = true else dim currentVal dim totalDelta dim endVal ' Check to see if this ramp is over if (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP) Then currentVal = m_oTStage.ReadQuietly - 273.15 totalDelta = Abs(m_rampStart - currentVal) endVal = m_currentRamp.EndTemperature elseif (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_HOLD) Then currentVal = Now() totalDelta = Abs(m_rampStart - currentVal) endVal = m_rampStart + (m_currentRamp.HoldTime / 86400) end if if (totalDelta >= Abs(m_rampStart - endVal)) then m_bRampStarted = 0 m_nRampID = m_nRampID + 1 Logger.Log "Next ramp in UpdateRampState. TD = " & CStr(totalDelta) & " rs=" & CStr(m_rampStart) & " ev=" & CStr(endVal) ' Check to see if there are any more ramps left UpdateRampState = m_nRampID <= m_oTempRamps.Count Else UpdateRampState = True End If End If End Function Private Sub StartRamp (currentRamp) if currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP then ' Ramp to the given temperature Activity "Starting ramp to " & CStr(currentRamp.EndTemperature) & "°C at " & CStr(currentRamp.RampRate) & "°C/min" m_rampStart = m_oTStage.ReadQuietly - 273.15 m_oTStage.Ramp = currentRamp.RampRate m_oTStage.SetTemperatureAsync currentRamp.EndTemperature + 273.15 else m_RampElapsed = 0 m_rampStart = Now() end if m_lastCollection = m_rampStart m_bRampStarted = true m_bRampPaused = false End Sub Private Sub PauseCurrentRamp() if m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP then ' Stop this ramp. When we resume we will simply set the target temperature again. Effectively restarting the ramp ' from whatever the temperature is at that point Activity "Pausing ramp" m_oTStage.Hold else Activity "Pausing ramp" m_RampElapsed = m_RampElapsed + (Now() - m_rampStart) end if m_bRampPaused = true End Sub Private Sub ResumeRamp() if m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP then ' Resume this ramp. Simply set the target temperature again effectively restarting the ramp. Activity "Resuming ramp" StartRamp m_currentRamp else ' adjust ramp start so that the end time is correct Activity "Resuming hold. " & CStr(CInt(m_currentRamp.HoldTime - (m_RampElapsed / 86400))) & " S remaining" m_rampStart = Now() - m_RampElapsed m_RampElapsed = 0 end if m_bRampPaused = false End Sub ' Wait for the next collection, ramp completion or abort. Return 0 on abort, 1 on collection due, 2 on ramp complete (no collection) Private Function WaitForNextCollection() dim currentVal dim totalDelta dim endVal dim increment if (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP) Then endVal = m_currentRamp.EndTemperature increment = m_currentRamp.AcquisitionInterval elseif (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_HOLD) Then ' the ramp specifies times in seconds, but the integer part of vbdate is a number of days endVal = m_rampStart + (m_currentRamp.HoldTime / 86400) increment = m_currentRamp.AcquisitionInterval/86400 end if WaitForNextCollection = 0 Do While (not Me.Aborted) Dim T T = m_oTStage.ReadQuietly - 273.15 ' Add the current temperature to the plot m_oTempDL.Add T m_oTimeDL.Add ElapsedTime ' Check to see if the measurement property has been set to pause the ramp if (RampPaused) then if (not m_bRampPaused) then ' The ramp wasn't paused before now. Pause the ramp Activity "Pausing ramp" PauseCurrentRamp end if if (ContinueMeasurement) then ' The flag to collect a single spectrum is set Activity "Collecting spectrum on command" WaitForNextCollection = 1 Exit Function end if else if (m_bRampPaused) then ' This ramp was paused. Restart it Activity "Resuming ramp" ResumeRamp ' recalc interval values if (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP) Then endVal = m_currentRamp.EndTemperature increment = m_currentRamp.AcquisitionInterval elseif (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_HOLD) Then ' the ramp specifies times in seconds, but the integer part of vbdate is a number of days endVal = m_rampStart + (m_currentRamp.HoldTime / 86400) increment = m_currentRamp.AcquisitionInterval/86400 end if end if if (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP) Then currentVal = T Activity "Ramping to " & CStr(endVal) & "°C Current T = " & CStr(currentVal) & "°C" totalDelta = Abs(m_rampStart - currentVal) elseif (m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_HOLD) Then currentVal = Now() totalDelta = Abs(m_rampStart - currentVal) Activity "Holding temperature for " & CStr(CInt(m_currentRamp.HoldTime - (totalDelta * 86400))) & " more seconds" end if ' The next collection will take place when we pass the next increment, or ' when we reach the target val, but only if the collection mode is correct if (totalDelta >= Abs(m_rampStart - endVal)) then Logger.Log "Ramp finished. elapsed = " & CStr(totalDelta) if (m_currentRamp.DataCollectionMode = WiRETemperatureRampsLib.eDCM_INCL_END or _ m_currentRamp.DataCollectionMode = WiRETemperatureRampsLib.eDCM_INCL_BOTH) then WaitForNextCollection = 1 else m_bRampStarted = 0 m_nRampID = m_nRampID + 1 WaitForNextCollection = 2 end if Exit Function elseif (m_currentRamp.DataCollectionMode <> WiRETemperatureRampsLib.eDCM_NONE and _ (increment > 0 and Abs(m_lastCollection - currentVal) >= increment)) Then ' The increment has passed. Collect now Activity "Collecting data at increment" WaitForNextCollection = 1 Exit Function end if end if Sleep2 (500) Loop End Function Private Function ElapsedTime() ElapsedTime = (UTCNow() - m_dtSeriesStart) * 86400 End Function Private Function PreScan() PreScan = False Dim sMsg ' Reset the focustrack result log items m_eFocusTrackCompletionCode = 0 ' eFSS_UNINITIALISED m_sFocusTrackCompletionString = "" If (m_eType and eThermal) = eThermal Then ' Move to target temperature If m_nScan = 0 Then m_Point = m_nInitialValue Else m_Point = m_Point + m_nInterval End If Logger.Log "Changing temperature to " & FormatNumber(m_Point-AbsoluteZero,1) & "°C" Activity FormatMessage("Changing temperature to %1 °C", FormatNumber(m_Point-AbsoluteZero,1)) On Error Resume Next m_oTStage.Temperature = m_Point If Err.Number <> 0 Then Logger.Error "Failed to set temperature: " & Err.Description Scan.CustomDataOriginValues = m_oTStage.Temperature ' enable monitoring ' hold at the specified temperature. If m_nTSHoldms > 0 then Logger.Log "Holding temperature at " & FormatNumber(m_Point-AbsoluteZero,1) & "°C" & _ " for " & FormatNumber(m_nTSHoldms/1000, 0) & "s" Activity FormatMessage("Holding temperature at %1°C for %2s", _ FormatNumber(m_Point-AbsoluteZero,1), FormatNumber(m_nTSHoldms/1000, 0)) SleepWithAbort m_nTSHoldms, 200 End If On Error Goto 0 End If ' Raise the before scan event here Measurement.RaiseBeforeScan m_nScan If (m_eType and eThermal2) = eThermal2 Then dim bContinue: bContinue = RampToNextCollection ' Check for abort if (Not bContinue or Me.Aborted) then PreScan = false exit function end if Else If (m_eType And eTriggeredSeries) = eTriggeredSeries Then Scan.CustomDataOriginValues = m_nScan ' We could read the temperature here for the alternate origin value End If End If If (m_eType And (eXYArea Or eDepths)) <> 0 then ' We are using the map area object and the system object to do the moves for us. Tell it to move to the ' next position System.MoveToMapAreaPosition m_nScan end if ' Pause the multi-sequence operation and wait in a sleep loop for the "continueMeasurement" flag to be set Call WaitForContinueMeasurement ' Check for abort if (Me.Aborted) then PreScan = false exit function end if ' For the first acquisition for a map without image acquisition, prompt the user ' if we don't have a podule. NB: must prompt if only collecting the post image. dim bSystemHasMicroscope: bSystemHasMicroscope = true if ((System.SystemType And WIRESYSTEMLib.eWSY_RA801) = WIRESYSTEMLib.eWSY_RA801) or _ ((System.SystemType And WIRESYSTEMLib.eWSY_RA802) = WIRESYSTEMLib.eWSY_RA802) then bSystemHasMicroscope = false end if ' if system is an RA100 then it does not have one either - but we don't run mapping ' on these so this msg should never present. Dim bHavePodule: bHavePodule = CBool(System.SystemType And eWSY_PODULE) ' we must prompt on dual microscope systems if using the external scope. if bHavePodule And MicroscopeUsesExternalPath(System) then _ bHavePodule = false' pretend there is no podule... If bSystemHasMicroscope And Not bHavePodule And g_bUseCollectWarning Then If m_nScan = 0 _ And Not(m_bFocusTrackEnabled) _ And ((m_eType AND eXYArea) = eXYArea Or (m_eType AND eDepths) = eDepths) _ And (m_oImageCapture.CaptureMode = 0 Or m_oImageCapture.CaptureMode = 2) Then MsgBox FormatMessage(g_sDataCollectMessage), vbOKOnly + vbQuestion + vbSystemModal, _ FormatMessage(g_sDataCollectTitle) End If End If ' Do FocusTrack after stage motion but before scanning. If m_bFocusTrackEnabled Then If Not(bHavePodule) And (m_nScan = 0 Or m_oImageCapture.CaptureMode <> 0) Then MsgBox FormatMessage(g_sDataCollectMessage), vbOKOnly + vbQuestion + vbSystemModal, _ FormatMessage(g_sDataCollectTitle) End If If (m_nScan Mod m_nFocusTrackInterval) = 0 Then Activity FormatMessage("Adjusting focus.") m_bFocusTrackComplete = False FocusTrack.Start Do While Not m_bFocusTrackComplete Sleep 250 Loop End If End If m_oImageCapture.GrabImage 1, Not(m_bMaximizeWhitelight) ' maybe capture the pre image if (Acquisition.MinimizeLaserShutter() = true) or _ Acquisition.MaximizeWhitelight or _ Acquisition.ImageCaptureBeforeDataCollection then Logger.Debug "Forcing instrument state to instrument" On Error Resume Next Instrument.Apply ' force switch to raman view If Err.Number <> 0 Then Logger.Error Err.Source & ": " & Err.Description On Error Goto 0 end if ' We need to force the filename into the scan if we have one so that the first call to ' Transfer() doesnt create a temporary file If m_nScan = 0 Then If Len(Measurement.DataSaveFile) > 0 Then If Measurement.DataSaveMode = WIREEXPERIMENT2Lib.dsmIncrement Then Measurement.DataSaveFile = UniqueFilename(Measurement.DataSaveFile) Measurement.DataSaveMode = WIREEXPERIMENT2Lib.dsmOverwrite Logger.Log "Changing data save file to " & Measurement.DataSaveFile End If Logger.Debug "PreScan save file" Measurement.Result.Save Measurement.DataSaveFile, Measurement.DataFileFormat, True Else ' bug #3821: if no filename, provide a persistent temp file (queue cleans them after a week). Dim bPersistentTempFile: bPersistentTempFile = True On Error Resume Next bPersistentTempFile = CBool(Measurement.Properties("persistentTempFile")) On Error Goto 0 If bPersistentTempFile Then Measurement.DataSaveFile = GetTemporaryFile("wxd") Measurement.DataSaveMode = WIREEXPERIMENT2Lib.dsmOverwrite Logger.Log "Forcing filename to a chosen temporary file '" & Measurement.DataSaveFile & "'" Measurement.Result.Save Measurement.DataSaveFile, Measurement.DataFileFormat, True End If End If End If If (m_eType and eThermal2) = eThermal2 Then ' It's important to record the stage temperature and ramp rate as close as possible to the data collection Dim T dim arrParams(1) T = m_oTStage.ReadQuietly - 273.15 arrParams(0) = T if m_currentRamp.RampType = WiRETemperatureRampsLib.eRT_RAMP then m_lastCollection = T if (T > m_currentRamp.EndTemperature) then arrParams(1) = -m_currentRamp.RampRate else arrParams(1) = m_currentRamp.RampRate end if else arrParams(1) = 0 m_lastCollection = Now() end if Scan.CustomDataOriginValues = ElapsedTime Scan.AlternativeDataOriginValues = arrParams elseif m_bCollectTemperatureValues then Scan.AlternativeDataOriginValues = m_oTStage.ReadQuietly - 273.15 End If PreScan = True End Function Private Sub PostScan() Dim sLogMessage m_oImageCapture.Reset ' clear any capture images ' record the last collect sequence duration - this is obviously irrelevant for multiple collect ' sequences handled from the measurement script; but for in-scan managed ' collections this value is very useful Measurement.Result.Add "SequenceDurationMS", System.sequenceDurationMS dim bSaveNow: bSaveNow = false dim elapsedTimeS dim lastS, lastM, lastH, nowS, nowM, nowH lastS = Second(m_lastSave) lastM = Minute(m_lastSave) lastH = Hour(m_lastSave) nowS = Second(Time()) nowM = Minute(Time()) nowH = Hour(Time()) if nowH < lastH then nowH = lastH+24 elapsedTimeS = (nowH-lastH)*60*60 + (nowM-lastM)*60 + nowS-lastS ' the autosave has been set to 1 for the in-scan mapping. However, if it is a ' focustrack map then we only want to save once every 20 minutes or so. if m_eMode = eInteruptedSeries then ' ie a focustrack map ? Logger.Log "eInteruptedSeries last save " & CStr(m_lastSave) & _ ", now = " & CStr(Time()) & ": elapsed = " & CStr(elapsedTimeS) & "s" If (m_nScan = 0) or (elapsedTimeS > (20*60)) then ' save every 20 minutes. bSaveNow=true end if else If m_nAutoSaveInterval > 0 Then If (m_nScan Mod m_nAutoSaveInterval) = 0 And Measurement.DataSaveFile <> "" Then bSaveNow = true end if End If end if If bSaveNow Then m_lastSave = Time() 'bug #1662: dont save as eSPC_EVEN for incremental saves Dim eFileFormat : eFileFormat = Measurement.DataFileFormat If eFileFormat = eSPC_EVEN Then eFileFormat = eSPC Logger.Log "Autosaving measurement result on scan #" & CStr(m_nScan) Activity FormatMessage("Autosaving measurement result on scan #%1", CStr(m_nScan)) If Measurement.DataSaveMode = WIREEXPERIMENT2Lib.dsmIncrement Then Measurement.DataSaveFile = UniqueFilename(Measurement.DataSaveFile) Measurement.DataSaveMode = WIREEXPERIMENT2Lib.dsmOverwrite Logger.Log "Changing data save file to " & Measurement.DataSaveFile End If On Error Resume Next If TypeName(Measurement.Result) = "WiREMemoryFileCom" Then Measurement.Result.Save Measurement.DataSaveFile, eFileFormat, True Else Dim nFile For nFile = 1 To Measurement.Result.Count Dim sFilename If nFile = 1 Then sFilename = Measurement.DataSaveFile Else sFilename = SequencedFilename(Measurement.DataSaveFile, nFile-1) End If 'sFilename = GetBaseName(sFilename) & "_x." & GetExtension(sFilename) Measurement.Result.Item(nFile).Save sFilename, eFileFormat, True Next End If ' The below error catch is for the 2 instances that a 'Permission denied' error has been ' that ultimately can result in too many datasets being held open in memory (#2797) If Err.Number <> 0 Then Logger.Error "Autosave error: " & Err.Description MsgBox FormatMessage("Error saving %s%n%2%n%nIt is recommended that you Abort and restart the measurement", sFilename, Err.Description), _ vbCritical, FormatMessage("WiRE2 Measurement") end if Logger.Debug "Calling garbage collector" Measurement.Result.GarbageCollect WIREFILEHANDLERLib.gcfImmediate If Err.Number <> 0 Then Logger.Error "Autosave error: " & Err.Description On Error Goto 0 End If End Sub Public Property Set ScanResult( newResult ) if m_oScanResult is nothing then set m_oScanResult = newResult else Logger.Log "Set ScanResult: m_oScanResult is not nothing" end if End Property Public Sub WaitForSystem(nmsec) Dim oInstrument : Set oInstrument = New CInstrument oInstrument.WaitForIdleSystem System, nmsec, "WaitForSystem" End Sub Public Sub DoScan(oScan) m_bTimedOut = False if (m_eTermination <> eWAS_USER_ABORT) then m_eTermination = WIRESYSTEMLib.eWAS_OK else ' Shouldn't be here. Logger.Error "Encountered user abort at start of DoScan. Will not perform scan" Exit Sub End If ' Saturation protection m_bSaturationMod = False ' Initially no modification to the collection parameters for saturation Dim bSaturationCheck, lOriginalExpTime, dOriginalNDPercent Dim nRepeat: nRepeat = 0 Dim nSatRepeat: nSatRepeat = 0 On Error Resume Next nSatRepeat = CLng(Measurement.Properties("SaturationProtectionRepeat")) On Error GoTo 0 If (nSatRepeat > 0) Then ' Saturation protection: store the starting values of exposure time and ND percent lOriginalExpTime = oScan.ExpTimeInMillSecs dOriginalNDPercent = InstrumentState.NDPercent ' and set the starting values of the potentially modified variables to these m_lSaturationExpTime = lOriginalExpTime m_dSaturationNDPercent = dOriginalNDPercent End If Do ' Modify scan and instrument ND value (incl. apply) here if saturation protection is active. This sets the ' CAquisition member variables m_bSaturationMod = True and m_lSaturationExpTime, m_dSaturationNDPercent ' to the new values which will subsequently be logged to the resulting (unsaturated) dataset If (nSatRepeat > 0) And (nRepeat > 0) Then ModifyForSaturationProtection oScan If m_bSaturationMod = False Then _ Logger.Warn "CAquisition::ModifyForSaturationProtection failed - scan will be recollected with no parameters changed." Activity FormatMessage("Saturation protection - repeat %1 (maximum %2)", nRepeat, nSatRepeat) Logger.Log "Saturation protection - repeat " & CStr(nRepeat) & " (maximum " & CStr(nSatRepeat) & ")" ' Reset scan variables m_bTimedOut = False m_eTermination = WIRESYSTEMLib.eWAS_OK g_nUpdates = 0 End If WaitForSystem 250 On Error Resume Next Scan.MeasurementHandle = Measurement.Properties("queueHandle") On Error Goto 0 Dim oLocalResult, nLocalScan, nLocalScanCount If (m_eMode <> eCompleteSeries) Then ' Do one scan at a time Dim bNoAdd: bNoAdd = False On Error Resume Next bNoAdd = CBool(Measurement.Properties("dontAddDatasets")) On Error Goto 0 If (bNoAdd) then 'Call DoScan2 Set oLocalResult = Nothing nLocalScan = 0 nLocalScanCount = -1 Else 'Call DoScan3 for just one scan Set oLocalResult = Measurement.Result nLocalScan = m_nScan nLocalScanCount = 1 End If Else ' Call DoScan3 for all scans Set oLocalResult = Measurement.Result nLocalScan = 0 nLocalScanCount = -1 End If ' Check here to see if the scan params have changed CheckScanParams LocalDoScan System, oScan, g_parentHWND, oLocalResult, nLocalScan, nLocalScanCount ' Fire the scan started event Measurement.RaiseScanStarted m_nScan ' Final parameter in WaitForScanComplete is <Check for saturation / log data> - see sub for description m_bSaturated = False ' m_bSaturation will be reset True only if saturation has occurred. WaitForScanComplete oScan, 1200, Abs(CLng(nSatRepeat > 0)) + Abs(CLng(nRepeat = nSatRepeat And nSatRepeat > 0)) ' check to see if it was aborted: If oScan.NumOfAccumulations <> oScan.AccumulationsCollected Then Measurement.Result.Element("", "AccumulationsCollected") = oScan.AccumulationsCollected End If ' If we timed out then call abort and wait some more If (Not m_bScanComplete) And (Not Me.Aborted) Then Logger.Warn "Aborting scan due to measurement timeout." m_bTimedOut = True oScan.AbortScan WaitForScanComplete oScan, 1200, 0 Logger.Warn "Aborted scan due to measurement timeout - setting status" Measurement.Result.Element("", "lastScanCompletionStatus") = "Timed out" Exit Do End If nRepeat = nRepeat + 1 Loop Until ((m_bSaturated = False) Or (nRepeat > nSatRepeat)) ' if we are still saturated then move on. if nSatRepeat > 0 then ' if the last collect was still saturated then we need to pretend that ' it succeeded - which means the below line must update m_LastDatasetCount to ' the correct value. Dim oCollectedDatasets Set oCollectedDatasets = Measurement.Result.Element("","collectedDatasets") if IsObject(oCollectedDatasets) And Not(oCollectedDatasets Is Nothing) then if m_bSaturated = True And nSatRepeat > 0 then _ m_LastDatasetCount = oCollectedDatasets.Count end if end if If m_bSaturationMod Then ' Restore original scan and instrument state settings here if saturation protection is active oScan.ExpTimeInMillSecs = lOriginalExpTime If (m_dSaturationNDPercent <> dOriginalNDPercent) Then ' Ensure we only reapply instrument state where necessary InstrumentState.NDPercent = dOriginalNDPercent If Not(Instrument Is Nothing) Then Instrument.ApplyLampsAndMotors End If End If End Sub Private Sub CheckScanParams() Dim dExpTime: dExpTime = Scan.ExpTimeInMillSecs Dim nAccs: nAccs = Scan.NumOfAccumulations Dim dLaserPower: dLaserPower = InstrumentState.NDPercent if (dExpTime <> m_dExpTime Or nAccs <> m_nAccs Or dLaserPower <> m_dLaserPower) Then ' Something has changed Dim oEntry: set oEntry = CreateObject("Renishaw.WiREDictionaryCom") oEntry.Add "Acquisition index", m_nScan+1 if (dExpTime <> m_dExpTime) then oEntry.Add "Exposure time (ms)", dExpTime m_dExpTime = dExpTime End If If (nAccs <> m_nAccs) Then oEntry.Add "Accumulation count", nAccs m_nAccs = nAccs End If If (dLaserPower <> m_dLaserPower) Then oEntry.Add "Laser ND percent", dLaserPower m_dLaserPower = dLaserPower If Not(Instrument Is Nothing) Then Instrument.ApplyLampsAndMotors End If if (m_oMPL Is Nothing) Then set m_oMPL = CreateObject("Renishaw.WiREDictionaryCom") End If if m_oMPL.Exists(m_nScan+1) then m_oMPL.Item(m_nScan+1) = oEntry else m_oMPL.Add m_nScan+1, oEntry End If End If End Sub ' We must trap any error from DoScan and reset our completion flag on error to avoid waiting for ever. Private Sub LocalDoScan(oSystem, oScan, hwnd, oResult, nScan, nCount) Dim code,src,desc On Error Resume Next m_bScanComplete = False If oResult Is Nothing Then oScan.DoScan2 oSystem, hwnd Else oScan.DoScan3 oSystem, hwnd, oResult, nScan, nCount End If If Err.Number <> 0 Then code = Err.Number : src = Err.Source : desc = Err.Description m_bScanComplete = True On Error Goto 0 Err.Raise code, src, desc End If End Sub Public Sub ReportCameraStatus() Dim bReport : bReport = False On Error Resume Next bReport = Measurement.Properties("reportCameraStatus") If bReport Then If m_oCameraWrapper Is Nothing Then Set m_oCameraWrapper = New CCameraWrapper m_oCameraWrapper.Init System End If Dim s : s = m_oCameraWrapper.ReportCameraStatus Logger.Warn s End If Err.Clear End Sub Private Property Get UsingExternalTriggers() UsingExternalTriggers = False Dim oTriggers: Set oTriggers = System.HostedObject(eSHO_EXT_TRIGGERS) Dim oTrigger Dim sKey If (IsObject(oTriggers)) Then For each sKey in oTriggers.Keys Set oTrigger = oTriggers.Item(sKey) If oTrigger.InputTrigger Then If oTrigger.UseTrigger Then UsingExternalTriggers = True Logger.Log "Waiting on external triggers" Exit For End If End If Next End If End Property ' ' UsingSoftwareTrigger ' Private Property Get UsingSoftwareTrigger(oScan) UsingSoftwareTrigger = False On Error Resume Next ' halt error handling. Dim softTriggersFlag softTriggersFlag = oScan.SoftwareTriggerState If softTriggersFlag AND eSTT_TRIGGER_IN = eSTT_TRIGGER_IN Then UsingSoftwareTrigger = true Logger.Log "Waiting on Software triggers" End If On Error Goto 0 ' restore error handling. End Property Public Sub WaitForScanComplete(oScan, nMilliseconds, nSaturationTestMode) ' Wait for the bScanComplete flag to become True. This is set by the ScanComplete ' handler. ' Adding an extra two minutes (120secs = 120 000ms) to allow for motor movement ' bug #2208: change to the greater of 10% of ScanDurationEstimate or 120s ' Final parameter in WaitForScanComplete is <Test for saturation / log data mode>: ' = 0: no check, data will be logged (unless dontAddDatasets flag is set) ' = 1: check for saturation and log data unless saturated ' = 2: check for saturation and log data regardless of result (last pass) Dim nTime : nTime = 0 Dim nLimit : nLimit = 2 ' how many tries do we give it? Dim nOverrun : nOverrun = 0 Dim sErr : sErr = "" g_bSleeping = True Dim bUsingTriggers: bUsingTriggers = UsingExternalTriggers or UsingSoftwareTrigger(oScan) 'Dim nMax : nMax = 120000 + oScan.DurationEstimate Dim nExcess : nExcess = 120000 Dim nSDE : nSDE = oScan.DurationEstimate if oScan.MapScanCount > 1 then nSDE = nSDE * oScan.MapScanCount End If If (nSDE / 10.0) > nExcess Then nExcess = nSDE / 10.0 Dim nMax : nMax = nSDE + nExcess Logger.Debug "Setting Scan completion timeout to " & nMax & " ms (" & nSDE & " ms plus " & nExcess & " ms)" Do While (Not m_bScanComplete ) And nTime <= nMax And (Not Me.Aborted) and (g_bSleeping) Dim nWaited: nWaited = Sleep2(nMilliseconds) ' Don't time out if we're waiting on input triggers if (not bUsingTriggers) then nTime = nTime + CLng(nWaited) 'Activity CStr(System.SequenceStatusAsString(-1)) If nTime > nMax Then If nOverrun < nLimit Then nTime = 0 sErr = "Exceeded scan duration estimate." Activity FormatMessage("Exceeded scan duration estimate.") Logger.Warn sErr nOverrun = nOverrun + 1 End If Loop If m_bMaximizeWhitelight Then Instrument.ApplyWhitelight true If Me.Aborted Then Logger.Debug "Scan aborted while waiting for scan to complete (" _ & nTime & " ms with max " & nLimit * nMax & " ms)" ElseIf Not m_bScanComplete Then Logger.Error "Timeout expired waiting for scan to complete (" _ & nTime & " ms with max " & nLimit * nMax & " ms)" ElseIf m_eMode = eInteruptedSeries or m_eMode = eCustomSeries Then Logger.Debug "Scan completed after " & nTime & " ms with max " & nLimit * nMax & " ms" ' now do the scan complete stuff Dim oResult If IsObject(m_oScanResult) Then If nSaturationTestMode > 0 Then m_bSaturated = CheckDataForSaturation(m_oScanResult) If ((nSaturationTestMode = 1) And m_bSaturated) Then m_oScanResult.Element("", "saturationProtectionDiscard") = "True" elseIf nSaturationTestMode = 2 then on error resume next if m_oScanResult.Element("", "saturationProtectionDiscard") = "True" Then m_oScanResult.Element("", "saturationProtectionDiscard") = "False" Logger.Debug "setting saturationProtectionDiscard to FALSE" End if on error goto 0 End if Logger.Log "Saturation protection - test for saturation returned " & CStr(m_bSaturated) End If Dim bNoAdd: bNoAdd = False On Error Resume Next bNoAdd = CBool(Measurement.Properties("dontAddDatasets")) ' Dont add the dataset if nSaturationTestMode = 1 and saturated, or if dontAddDatasets flag is set bNoAdd = bNoAdd Or ((nSaturationTestMode = 1) And m_bSaturated) On Error Resume Next ' reset any error resulting from above - property wont be present in general m_oImageCapture.GrabImage 2, True ' maybe capture the post image If Err.Number <> 0 Then sErr = "WaitForScanComplete: " & Err.Source & ": " & Err.Description Activity sErr : Logger.Error sErr End If On Error Goto 0 If bNoAdd Then Logger.Debug "ScanComplete using m_oScanResult" Set oResult = m_oScanResult Else Logger.Debug "ScanComplete using Measurement.Result" Set oResult = Measurement.Result End If Set m_oScanResult = Nothing On Error Resume Next Dim oCollectedDatasets: set oCollectedDatasets = Measurement.Result.Element("","collectedDatasets") Dim nCollectedDataset if IsObject(oCollectedDatasets) And Not(oCollectedDatasets Is Nothing) then Logger.Debug "ScanComplete looking for focus track and sat protection" On Error Goto 0 For nCollectedDataset = m_LastDatasetCount to oCollectedDatasets.Count - 1 dim sDataset: sDataset = oCollectedDatasets.Item(nCollectedDataset+1) m_oImageCapture.UpdateDataset oResult, sDataSet If (m_bFocusTrackEnabled) Then Measurement.Result.Element(sDataSet, "FocustrackValue") = FocalPoint End If If m_bSaturationMod Then Measurement.Result.Element("", "SaturationProtectionModification") = "True" Measurement.Result.Element(sDataSet, "SaturationProtectionLaserPower") = CStr(m_dSaturationNDPercent) Measurement.Result.Element(sDataSet, "SaturationProtectionExposureTime") = m_lSaturationExpTime Measurement.Result.Element(sDataSet, "DataSaturation") = CStr(m_bSaturated) End If Next If (not m_bSaturated) then m_LastDatasetCount = oCollectedDatasets.Count End If End If Logger.Debug "Scan complete about to raise data update" Measurement.RaiseDataUpdate dutScanComplete, oResult Call WaitForContinueMeasurement Else Logger.Error "Scan completed but cached scan result is not an object" End If Else Logger.Debug "Map scan completed after" & nTime & " ms with max " & nLimit * nMax & " ms" End If End Sub Public function IsScanRunning IsScanRunning = Not m_bScanComplete End function Private Sub DisconnectFocusTrack on error resume next ' we don't worry if this fails Logger.Debug "Disconnecting focustrack from system object" If IsObject(FocusTrack) And Not(FocusTrack Is Nothing) Then FocusTrack.ReleaseSystem End If Err.Clear End Sub ' Pause the multi-sequence operation and wait in a sleep loop for the "continueMeasurement" flag to be set Private Sub WaitForContinueMeasurement If (m_eType and eThermal2) <> eThermal2 Then Dim bContinue: bContinue = False Dim bMSOPaused: bMSOPaused = False On Error Resume Next bContinue = Measurement.Properties("continueMeasurement") If Err.Number <> 0 Then bContinue = True ' flag not present so continue On Error Goto 0 If bContinue = False Then Logger.Log "Pausing multi-sequence operation while measurement sleeps" m_oMSO.Halt bMSOPaused=True End If Dim nFailCount: nFailCount = 0 ' Seem to get some failures while other objects access result file Do While Not (bContinue Or Me.Aborted Or nFailCount > 4) On Error Resume Next bContinue = Measurement.Properties("continueMeasurement") If Err.Number = 0 Then nFailCount = 0 Else nFailCount = nFailCount + 1 Logger.Warn "Unexpected failure reading continueMeasurement " & CStr(nFailCount) End If On Error Goto 0 Sleep 100 Loop If bMSOPaused Then Logger.Log "Restarting multi-sequence operation following measurement sleep" m_oMSO.Start End If End If End Sub ' Modify the passed-in scan to reduce the exposure time by half or if this is not possible knock down the ' instrument state ND filter value one notch. In the latter case we also need to apply the instrument ' state. Set the CAquisition member variables m_bSaturationMod = True and m_lSaturationExpTime, ' m_dSaturationNDPercent to the new values subsequently logged to the resulting (unsaturated) dataset Private Sub ModifyForSaturationProtection(oScan) m_bSaturationMod = False Dim lMinExpTime: lMinExpTime = 100 ' 100 ms min exposure time for static scans If (oScan.ScanType = WIRESCAN2Lib.eWST_CONTINUOUS_GRATING_SCAN Or oScan.ScanType = WIRESCAN2Lib.eWST_CONTINUOUS_GRATING_IMAGE) Then ' For continuous extended scans we read the min time from the grating object lMinExpTime = 10000 If Not (Instrument Is Nothing) Then lMinExpTime = Instrument.GratingMinExposureTime End If Dim lNewExpTime: lNewExpTime = CLng(oScan.ExpTimeInMillSecs / 2) If lNewExpTime >= lMinExpTime Then m_lSaturationExpTime = lNewExpTime oScan.ExpTimeInMillSecs = lNewExpTime Logger.Log "Saturation protection - exposure time modified to " & CStr(lNewExpTime) & " ms" m_bSaturationMod = True Else ' Already close to min exposure time - have to mod ND value If Not(Instrument Is Nothing) Then Dim dLowerNDValue: dLowerNDValue = Instrument.NextLowerNDPercent If dLowerNDValue <>0 Then ' NextLowerNDPercent succeeded - set in instrument state and apply m_dSaturationNDPercent = dLowerNDValue InstrumentState.NDPercent = dLowerNDValue Instrument.ApplyLampsAndMotors Logger.Log "Saturation protection - ND percent modified to " & CStr(dLowerNDValue) & "%" m_bSaturationMod = True End If End If End If End Sub ' Intent: Check all datasets (may be multitrack) for hitting the ADC saturation threshold which we ' (conservatively) will assume is 60,000. Assume the minimum of start and end pixel size ' in cm-1 and the appropriate # e- / count for the camera gain (high = 2.5; low = 10). ' ' Actual implementation: checks the dataSaturated flag set by the scan. ' The threshold where this is tripped is the WiREDebugFlag "SaturationThreshold" ' which defaults to 65535. Private Function CheckDataForSaturation(oMemoryFile) CheckDataForSaturation = False Dim nDataSetIndex, sDataSet: sDataSet = "DataSet0" Dim lNumLists: lNumLists = oMemoryFile.NumberOfDataLists(sDataSet) ' For each dataset in the collectedDatasets check whether any have intensity values > saturation threshold dim oCollectedDatasets: set oCollectedDatasets = oMemoryFile.Element("","collectedDatasets") dim nCollectedDataset if IsObject(oCollectedDatasets) And Not(oCollectedDatasets Is Nothing) then Logger.Log "Saturation threshold checking Datasets " & CStr(m_LastDatasetCount) & " to " & CStr(oCollectedDatasets.Count - 1) For nDataSetIndex = m_LastDatasetCount to oCollectedDatasets.Count - 1 dim bSat: bSat = false on error resume next bSat = oMemoryFile.Element("DataSet" & CStr(nDataSetIndex), "DataSaturated") On Error GoTo 0 if bSat = true then CheckDataForSaturation = True Logger.Log "Saturation threshold check: returned TRUE" Exit For End If Next End If End Function End Class ' ------------------------------------------------------------------------- ' Instrument Initialization ' ------------------------------------------------------------------------- ' Class CInstrument Private m_oInstrumentState Private m_nStateApplied Private m_vCalibrationState Private m_vInstrumentState Private Sub Class_Initialize() m_nStateApplied = -1 End Sub Public Sub Init(oInstrumentState, oSystem) ' Check that the Instrument State object is initialised with a useful area key. ' If not, use the systems current area key. Set m_oInstrumentState = oInstrumentState m_oInstrumentState.System = oSystem If m_oInstrumentState.AreaKey.LaserName = "" Then m_oInstrumentState.AreaKey = oSystem.AreaKey End If m_oInstrumentState.ParentHWND = g_parentHWND End Sub Public Sub Apply() ' Apply the Instrument State and wait for it to complete Activity FormatMessage("Applying instrument state") WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.Apply pre" WaitForIdleInstrument 250, "CInstrument.Apply" m_nStateApplied = -1 : g_InstrumentStateApplied = -1 m_oInstrumentState.ApplyAll WaitForInstrumentState 250 WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.Apply post" End Sub ' returns the logical position of the current motor public function CurrentMotorPos(eMtr) CurrentMotorPos = 0 on error resume next Dim oMotors: Set oMotors = m_oInstrumentState.System.HostedObject(eSHO_MOTOR_COLLECTION) Dim oMotor: set oMotor = oMotors.GetMotorByEnum(eMtr) CurrentMotorPos = oMotor.MotorPositionInUnits on error goto 0 end function ' returns the motor name for the passed in logical position. public function NamedMotorPos(eMtr, mtrPosition) NamedMotorPos = "" on error resume next Dim oMotors: Set oMotors = m_oInstrumentState.System.HostedObject(eSHO_MOTOR_COLLECTION) Dim oMotor: set oMotor = oMotors.GetMotorByEnum(eMtr) Dim oNamedPositions: Set oNamedPositions = oMotor.MotorNamedPositions NamedMotorPos = oNamedPositions.Key(mtrPosition) on error goto 0 end function Public Sub ApplyForImageCapture(bIlluminationLampOn) Dim nPoduleUpper : nPoduleUpper = m_oInstrumentState.PoduleUpperWheel Dim nPoduleLower : nPoduleLower = m_oInstrumentState.PoduleLowerWheel Dim bLampState : bLampState = m_oInstrumentState.IlluminationLampOn m_oInstrumentState.PoduleUpperWheel = CurrentMotorPos(eWMO_PODULE_UPPER_SELECTOR_WHEEL) m_oInstrumentState.PoduleLowerWheel = CurrentMotorPos(eWMO_PODULE_LOWER_SELECTOR_WHEEL) if LCase(NamedMotorPos(eWMO_PODULE_LOWER_SELECTOR_WHEEL, nPoduleLower)) <> _ LCase("5% Beamsplitter") then ' select Eye Piece / 50% Sample m_oInstrumentState.PodulePath = WIREPODULELib.ePWC_EYE_PIECES_SAMPLE_VIDEO End if m_oInstrumentState.IlluminationLampOn = bIlluminationLampOn ' Apply the Instrument State and wait for it to complete Activity FormatMessage("Applying instrument state") WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyForImageCapture pre" WaitForIdleInstrument 250, "CInstrument.ApplyForImageCapture" m_nStateApplied = -1 : g_InstrumentStateApplied = -1 m_oInstrumentState.ApplyAll WaitForInstrumentState 250 WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyForImageCapture post" m_oInstrumentState.PoduleUpperWheel = nPoduleUpper m_oInstrumentState.PoduleLowerWheel = nPoduleLower m_oInstrumentState.IlluminationLampOn = bLampState End Sub Public Sub CloseShutter m_oInstrumentState.ShutterOpen = False ApplyShutter End Sub Public Sub OpenShutter m_oInstrumentState.ShutterOpen = True ApplyShutter End Sub Public Sub ApplyShutter Activity FormatMessage("Operating laser shutter") WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyShutter pre" WaitForIdleInstrument 250, "CInstrument.ApplyShutter" m_nStateApplied = -1 : g_InstrumentStateApplied = -1 m_oInstrumentState.ApplyShutter WaitForInstrumentState 250 WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyShutter post" End Sub Public Sub ApplyAreaKey() ' Apply the Instrument State'a area key only and wait for it to complete Activity FormatMessage("Applying instrument state's areakey") WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyAreaKey" WaitForIdleInstrument 250, "CInstrument.ApplyAreaKey" ' applyareakey is synchrnous and does not wait for a sequence complete message. m_oInstrumentState.ApplyAreaKey End Sub 'For inverted microscopes, they might want to do image capture ' with the podule in the correct position but the illumination lamp OFF. ' Therefore the state of the lamp is passed in as a parameter Public Sub ApplyWhitelight(bIlluminationLampOn) Dim nPoduleUpper : nPoduleUpper = m_oInstrumentState.PoduleUpperWheel Dim nPoduleLower : nPoduleLower = m_oInstrumentState.PoduleLowerWheel Dim bLampState : bLampState = m_oInstrumentState.IlluminationLampOn ' Lower podule wheel in position 4 indicates 5% beamsplitter for Roche. ' In this position we do not want to move the podule for more white light ' as the video settings have been adjusted to cope. With the Mk2 podule ' this position is the internal calibration source, but as noone is going to run ' a measurement of the internal calibration source while collecting ' white light images of the sample, it's unlikely to be a problem. m_oInstrumentState.PoduleUpperWheel = CurrentMotorPos(eWMO_PODULE_UPPER_SELECTOR_WHEEL) m_oInstrumentState.PoduleLowerWheel = CurrentMotorPos(eWMO_PODULE_LOWER_SELECTOR_WHEEL) if LCase(NamedMotorPos(eWMO_PODULE_LOWER_SELECTOR_WHEEL, nPoduleLower)) <> _ LCase("5% Beamsplitter") then ' select Eye Piece / 50% Sample m_oInstrumentState.PodulePath = WIREPODULELib.ePWC_EYE_PIECES_SAMPLE_VIDEO end if m_oInstrumentState.IlluminationLampOn = bIlluminationLampOn On Error Resume Next Me.ApplyLampsAndMotors If Err.Number <> 0 Then Logger.Error "Failed to switch to white-light view: " & Err.Description On Error Goto 0 m_oInstrumentState.PoduleUpperWheel = nPoduleUpper m_oInstrumentState.PoduleLowerWheel = nPoduleLower m_oInstrumentState.IlluminationLampOn = bLampState End Sub Public Sub ApplyAllWhitelight() Dim nPoduleUpper : nPoduleUpper = m_oInstrumentState.PoduleUpperWheel Dim nPoduleLower : nPoduleLower = m_oInstrumentState.PoduleLowerWheel Dim bLampState : bLampState = m_oInstrumentState.IlluminationLampOn ' select Eye Piece / 50% Sample m_oInstrumentState.PodulePath = WIREPODULELib.ePWC_EYE_PIECES_SAMPLE_VIDEO m_oInstrumentState.IlluminationLampOn = True On Error Resume Next Me.Apply If Err.Number <> 0 Then Logger.Error "Failed to switch to white-light view: " & Err.Description On Error Goto 0 m_oInstrumentState.PoduleUpperWheel = nPoduleUpper m_oInstrumentState.PoduleLowerWheel = nPoduleLower m_oInstrumentState.IlluminationLampOn = bLampState End Sub Public Sub ApplyLampsAndMotors() ' Apply the Instrument State and wait for it to complete Activity FormatMessage("Applying instrument state for lamps and motors") WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyLampsAndMotors pre" WaitForIdleInstrument 250, "CInstrument.ApplyLampsAndMotors" m_nStateApplied = -1 : g_InstrumentStateApplied = -1 m_oInstrumentState.ApplyLampsAndMotors WaitForInstrumentState 250 WaitForIdleSystem m_oInstrumentState.System, 250, "CInstrument.ApplyLampsAndMotors post" End Sub Public Sub Record() ' record the current state for the result file. Activity FormatMessage("Recording current instrument state") Logger.Debug "Begin record instrument state" Dim oInstrumentState Set oInstrumentState = m_oInstrumentState.System.HostedObject(eSHO_INSTRUMENT_STATE) oInstrumentState.System = m_oInstrumentState.System oInstrumentState.AreaKey = m_oInstrumentState.System.AreaKey On Error Resume Next Set m_vInstrumentState = oInstrumentState.ReadInstrumentState If Err.Number <> 0 Then Logger.Error "Recording instrument state: " & Err.Description Set m_vCalibrationState = oInstrumentState.ReadCalibrationState If Err.Number <> 0 Then Logger.Error "Recording calibration state: " & Err.Description On Error Goto 0 Logger.Debug "End record instrument state" End Sub Public Sub WaitForIdleSystem(oSystem, nMilliseconds, sParentName) Dim nTime: nTime = 0 Dim nMax : nMax = 300000 ' 5 minutes Logger.Debug "Waiting for System to be Idle : " & CStr(sParentName) 'Dim oSystem 'Set oSystem = m_oInstrumentState.System Do While oSystem.IsSequenceRunning And nTime < nMax Dim nWaited: nWaited = Sleep2(nMilliseconds) nTime = nTime + CLng(nWaited) Loop If oSystem.IsSequenceRunning Then Logger.Error "Timeout expired while waiting for system to be idle (" _ & nTime & " ms with max " & nMax & " ms)" Else Logger.Debug "System Idle after " & CStr(nTime) & " nTime : " & CStr(sParentName) End If End Sub Sub WaitForInstrumentState(nMilliseconds) Dim nTime: nTime = 0 Dim nMax : nMax = 300000 ' 5 minutes Dim nWaited: nWaited = 0 Logger.Debug "Waiting for Instrument state to be applied" Do While g_InstrumentStateApplied < 0 And nTime < nMax nWaited = Sleep2(nMilliseconds) nTime = nTime + CLng(nWaited) Loop m_nStateApplied = g_InstrumentStateApplied If m_nStateApplied < 0 Then Logger.Error "Timeout expired while applying instrument state (" _ & nTime & " ms with max " & nMax & " ms)" ElseIf m_nStateApplied = 0 Then Logger.Debug "Instrument state applied. Status " & m_nStateApplied Else Err.Raise vbObjectError + m_nStateApplied, _ "StdMeasurement_ApplyInstrumentState", "User aborted during application of instrument state." End If End Sub Public Sub WaitForIdleInstrument(nMilliseconds, sParentName) Dim nTime: nTime = 0 Dim nMax : nMax = 300000 ' 5 minutes Dim nWaited: nWaited = 0 Logger.Debug "Waiting for idle instrument : " & CStr(sParentName) Do While Not(m_oInstrumentState.Ready) And nTime < nMax nWaited = Sleep2(nMilliseconds) nTime = nTime + CLng(nWaited) Loop Logger.Debug "Finished waiting for idle instrument after " & CStr(nTime) & ": " & CStr(sParentName) End Sub Public Property Let StateApplied(nStatus) If m_nStateApplied <> nStatus Then m_nStateApplied = nStatus End If End Property Public Property Get StateApplied() StateApplied = m_nStateApplied End Property Public Sub WriteState(oMemFile) Logger.Debug "Writing Instrument State into memory file." oMemFile.Add "InstrumentState", m_vInstrumentState oMemFile.Add "CalibrationState", m_vCalibrationState End Sub Public Function GratingMinExposureTime() Dim oSystem: Set oSystem = m_oInstrumentState.System Dim oAreaKey: Set oAreaKey = oSystem.AreaKey Dim oGratings: Set oGratings = oSystem.GratingCollection Dim oGrating: Set oGrating = oGratings.Item(oAreaKey.GratingName) GratingMinExposureTime = oGrating.MinimumExposureTime End Function Public Function NextLowerNDPercent() NextLowerNDPercent = 0 ' Default to 0 => client should interpret 0 as failed Dim oSystem: Set oSystem = m_oInstrumentState.System Dim oAreaKey: Set oAreaKey = oSystem.AreaKey Dim oNDFilters: Set oNDFilters = oSystem.HostedObject(WIRESYSTEMLib.eSHO_NDFILTERS) Dim vNDSettings: vNDSettings = oNDFilters.GetAvailableNDPercentsForLaser2(oAreaKey.LaserName, true) Dim dCurrentND: dCurrentND = m_oInstrumentState.NDPercent ' Go though the ND values until the current value is identified Dim i, lIndex: lIndex = -1 For i = LBound(vNDSettings) To UBound(vNDSettings) If CDbl(vNDSettings(i)) = dCurrentND Then lIndex = i Exit For End If Next If lIndex > LBound(vNDSettings) Then lIndex = lIndex - 1 NextLowerNDPercent = vNDSettings(lIndex) Else Logger.Warn "CInstrument::NextLowerNDPercent - failed to determine next lower ND value" End If End Function Public Function LaserWavenumber() Dim oSystem: Set oSystem = m_oInstrumentState.System LaserWavenumber = oSystem.CurrentLaserWavenumber End Function End Class ' ------------------------------------------------------------------------- ' Initialize the grating start up position. ' ' This is done separately from the remaining instrument state work because it can ' potentially take a very long time if the instrument has a slow grating motor. ' NB - the areakey must have been previously applied for the ' calibration parameters to be correct. ' ------------------------------------------------------------------------- Private g_nGratingMotorInitialized Private Sub InitializeGrating If InstrumentState.AreaKey.BeamPathKey = eBEAMPATH_GRATING Then Dim oGrating : Set oGrating = System.HostedObject(eSHO_CURRENT_GRATING) If oGrating.IsMotorAttached Then Dim oGratingMotor : Set oGratingMotor = oGrating.IMotor Dim bGratingMovedRequired: bGratingMovedRequired = false If oGratingMotor.IsMotorPresent Then Dim dTarget On Error Resume Next dTarget = Scan.CentreXAxisValue If Err.Number <> 0 Then dTarget = Scan.FirstXAxisValue On Error Goto 0 dTarget = ConvertToWaveNumber(dTarget, Scan.ScanToFileHandlerUnits(Scan.UserUnits)) Dim oCurrentPos, oTargetPos oCurrentPos = oGratingMotor.MotorPosition oTargetPos = oGrating.GetMotorPosition( dTarget, 0 ) if oCurrentPos <> oTargetPos then MoveGratingMotor oGrating, oGratingMotor, dTarget end if End If ' grating present ? End If ' motor attached to grating ? End If End Sub Private Sub MoveGratingMotor(oGrating, oGratingMotor, dTargetWavenumber) Dim oProgram : Set oProgram = CreateObject("Renishaw.WiREUSBProgramCom") oGrating.Add2prog_MoveGratingToWavenumber dTargetWavenumber, 0, oProgram oGratingMotor.Add2prog_WaitOnMotor oProgram g_nGratingMotorInitialized = -1 Activity FormatMessage("Initializing grating to %1 /cm", FormatNumber(dTargetWavenumber)) Dim oInstrument : Set oInstrument = New CInstrument oInstrument.WaitForIdleSystem System, 250, "InitializeGrating" System.RunNamedSequence 0, 0, "InitializeGratingMotor", oProgram Dim nTime, nMax, nMilliseconds nTime = 0 : nMilliseconds = 250 : nMax = 3600000 ' 1 hour Do While (g_nGratingMotorInitialized < 0) And nTime < nMax Dim nWaited: nWaited = Sleep2(nMilliseconds) nTime = nTime + CLng(nWaited) Loop If g_nGratingMotorInitialized = 2 Then Measurement.Result.Element("", "ScanCompletionStatus") = "Aborted" Err.Raise vbObjectError + g_nGratingMotorInitialized, _ "StdMeasurement_InitializeGrating", "User aborted during grating motor initialization" ElseIf g_nGratingMotorInitialized <> 0 Then Measurement.Result.Element("", "ScanCompletionStatus") = "Failed" Err.Raise vbObjectError + g_nGratingMotorInitialized, _ "StdMeasurement_InitializeGrating", "Failure during grating motor initialization" End If Activity FormatMessage("Grating motor initialized to %1 /cm", FormatNumber(dTargetWavenumber)) End Sub ' ModPodulePathForMicroscope ' checks the current microscope's podule path to see if we ' need to override the default path for the 'external' path. ' If so, then the InstrumentState object has its path changed. ' main usage : dual microscope systems. Private sub ModPodulePathForMicroscope (oInstrumentState, oSystem) On error resume next Dim oMicroscope: Set oMicroscope = GetMicroscope(oSystem) If IsObject(oMicroscope) And Not(oMicroscope Is Nothing) Then ' only override the podule path if it is the default. if oInstrumentState.PodulePath = WIREPODULELib.ePWC_LASER_SAMPLE Then if oMicroscope.PodulePath <> WIREPODULELib.ePWC_NOTSET AND _ oMicroscope.PodulePath <> WIREPODULELib.ePWC_NULL AND _ oMicroscope.PodulePath <> WIREPODULELib.ePWC_LASER_SAMPLE Then oInstrumentState.PodulePath = oMicroscope.PodulePath Logger.Log "Overriding Podule Path to " & CStr(oInstrumentState.PodulePath) end if end if end if on error goto 0 End Sub private function MicroscopeUsesExternalPath(oSystem) MicroscopeUsesExternalPath = false on error resume next ' if there is a microscope AND it uses the external path then return TRUE. Dim oMicroscope: Set oMicroscope = GetMicroscope(oSystem) If IsObject(oMicroscope) And Not(oMicroscope Is Nothing) Then if oMicroscope.PodulePath = WIREPODULELib.ePWC_EXTERNAL then _ MicroscopeUsesExternalPath = true end if on error goto 0 end function private function GetMicroscope(oSystem) on error resume next Set GetMicroscope = Nothing Dim oMicroscopes: Set oMicroscopes = oSystem.HostedObject(eSHO_MICROSCOPES) If IsObject(oMicroscopes) And Not(oMicroscopes Is Nothing) Then Set GetMicroscope = oMicroscopes.GetCurrentMicroscope() end if on error goto 0 End function Private Function ConvertToWavenumber(dPos, eUnits) Dim oQ : Set oQ = CreateObject("Renishaw.WiREQueueCom") Dim System : Set System = oQ.Systems(0) Dim oArith : Set oArith = CreateObject("Renishaw.WiREArithmeticFunctionsCom") Dim oLasers : Set oLasers = System.HostedObject(eSHO_LASERS) Dim oLaser : Set oLaser = oLasers.Item(System.AreaKey.LaserName) Dim dLaser : dLaser = oLaser.Wavenumber ConvertToWavenumber = oArith.ConvertWavenumberUnits(dPos, eUnits, eABSOLUTE_WAVENUMBER, dLaser) End Function ' ------------------------------------------------------------------------- ' On System SequenceComplete is used to tell us that the ' instrument state has been applied. ' Also, if any sequence is aborted it will be caught here. Public Sub System_SequenceCompleteEvent2(nTerminateStatus, sSequenceName) Logger.Debug "Sequence complete received (current status = " & CStr(Acquisition.TerminationStatus) & _ "). Termination status " & nTerminateStatus & ". Sequence name " & sSequenceName if (Acquisition.IsScanRunning) then ' A scan is running. It will handle the abort and complete when it is ready Logger.Debug "Not handling abort as a Scan is running" else ' Deal with abortable sleep (time series) If nTerminateStatus = eWAS_USER_ABORT And g_bSleeping Then g_bSleeping = False Logger.Debug "System_SequenceCompleteEvent2 clearing g_bSleeping" End If if Not(Acquisition.TerminationStatus = nTerminateStatus) then dim s s = "seqComplete upgrading acquisition. TerminateStatus(" & Cstr(Acquisition.TerminationStatus) & ")" s = s & " to (" & Cstr(nTerminateStatus) & ")" s = s & " for seq (" & Cstr(sSequenceName) & ")" Logger.Debug s end if If sSequenceName = "InitializeGratingMotor" Then g_nGratingMotorInitialized = nTerminateStatus ElseIf sSequenceName = "ApplyLampsAndMotors" Or sSequenceName = "ApplyShutter" Then g_InstrumentStateApplied = nTerminateStatus if (Acquisition.TerminationStatus = eWAS_OK or _ Acquisition.TerminationStatus = eWAS_USER_ABORT_REQUEST) then Acquisition.TerminationStatus = nTerminateStatus ' this could have been any instState apply ' so terminate the acquistion too. ' if we were aborted do we need to set the abortstate in the measurement here too ? else Logger.Debug "seqComplete " & CStr(sSequenceName) & _ " not passing abort " & Cstr(nTerminateStatus) & _ " on to the acquisition because acq.abort was already " & CStr(Acquisition.TerminationStatus) end if Else ' If we are now running scans then record the termination status If Instrument Is Nothing Then 'g_bResponseInitializationTimeout = True Logger.Error "Unexpected scanComplete ni the measurement script" Else If Instrument.StateApplied < 0 Then Logger.Debug "Setting Instrument to halt (" & nTerminateStatus & ")." g_InstrumentStateApplied = nTerminateStatus Else if (Acquisition.TerminationStatus = eWAS_OK or _ Acquisition.TerminationStatus = eWAS_USER_ABORT_REQUEST) then Acquisition.TerminationStatus = nTerminateStatus Logger.Debug "Setting Acquisition to halt (" & nTerminateStatus & ")." ' if the existing state in the measurement is eWAS_OK AND this sequence ' was aborted then we need to record the abort info in the measurement result. if MmtAbortState = eWAS_OK AND nTerminateStatus <> eWAS_OK then _ Measurement.Result.Element("", "abortState") = WIRESYSTEMLib.eWAS_USER_ABORT end if End If End If End If Wake End If End Sub ' ' System_AbortRequest ' Fired by the system object, initially with AbortType = AbortRequest ' The mmtScript fires this uip to a parent object. ' If a scan is runing then the parent has the option to display an abort dialog. ' The abort dialog will allow the user to select AbortAtEndOfAccumulation or EndOfScan. ' These two items cause the parent to tell the system to abort again, and we catch a ' new abort event from the system with the appropriate AbortType parameter. ' NB It is possible for this not to be called in some situations... If this happens then ' the abortRequest will be upgraded to an immediate sequence abort. Public Sub System_AbortRequest(abortType) Logger.Warn "In SystemAbortRequest(" & CStr(abortType) & ")" Logger.Warn "In SystemAbortRequest, current state(" & Cstr(Acquisition.TerminationStatus) & _ "); new abortType(" & CStr(abortType) & "); " Dim bWasSleeping: bWasSleeping = false On Error Resume Next if g_bMinimalScan then Measurement.Properties("cycling") = False end if Select Case abortType Case WIRESYSTEMLib.eWAS_USER_ABORT ' record the abort in measurement result If MmtAbortState = WIRESYSTEMLib.eWAS_OK Then ' do not overwrite existing entries Measurement.Result.Element("", "abortState") = WIRESYSTEMLib.eWAS_USER_ABORT End If ' Deal with abortable sleep (time series) If g_bSleeping Then bWasSleeping = True g_bSleeping = False Logger.Debug "System_AbortRequest clearing g_bSleeping" If (Acquisition.TerminationStatus = eWAS_OK) Then Acquisition.TerminationStatus = eWAS_USER_ABORT End If ' Support aborting a temperature ramp. If Not(Acquisition.TemperatureStage Is Nothing) Then Logger.Debug "System_AbortRequest aborting temperature ramp" Acquisition.TemperatureStage.Abort = True If (Acquisition.TerminationStatus = eWAS_OK) Then Acquisition.TerminationStatus = eWAS_USER_ABORT End If ' If the scan isn't yet running, make sure we don't try to run it If Not (Acquisition.IsScanRunning) then If (Acquisition.TerminationStatus = eWAS_OK) Then Acquisition.TerminationStatus = eWAS_USER_ABORT End If Case WIRESYSTEMLib.eWAS_USER_ABORT_REQUEST If g_AbortReqCount > 2 then ' the user has tried to abort 3 times so clearly something is not working so lets just abort anyway. Logger.Warn "In SystemAbortRequest (eWAS_USER_ABORT_REQUEST) AGAIN (3 times now). Forcing abort..." Measurement.Result.Element("", "abortState") = WIRESYSTEMLib.eWAS_USER_ABORT Else ' we'll let the parent decide what to do with this. The parent can call system.SuspendAbort() ' in its RaiseAbortRequest handler which effectively means that the parent will take responsibility ' for aborting. In this case, the abort will be triggered by an abort event form the system with one ' of the following termination statuses: ' eWAS_USER_ABORT, - immediate abort ' eWAS_USER_ABORT_AFTER_ACC, - handled in-scan ' eWAS_USER_ABORT_AFTER_SCAN, - handled in this measurement script. Logger.Warn "In SystemAbortRequest (eWAS_USER_ABORT_REQUEST); " dim mmtAS: mmtAS = MmtAbortState ' the measurement will call System.SuspendAbort if it needs to. Measurement.RaiseAbortRequest Scan.NumOfAccumulations, Acquisition.ScanCount, mmtAS ' note that if System.SuspendAbort was not called in the RaiseAbortRequest event handler then ' the system object will the abort as an abort with a status of eWAS_USER_ABORT g_AbortReqCount = g_AbortReqCount+1 ' increment the number of times we've seen this. if System.SuspendAbort = false then ' looks like the abort was not suspended - so we'll set the abort status now. Logger.Error "UserAbortRequest: after Measurement.RaiseAbortRequest system.suspendAbort was still FALSE" if MmtAbortState = WIRESYSTEMLib.eWAS_OK then ' do not overwrite existing entries Measurement.Result.Element("", "abortState") = WIRESYSTEMLib.eWAS_USER_ABORT end if end if end if Case WIRESYSTEMLib.eWAS_USER_ABORT_AFTER_ACC ' Abort at end of current accumulation Logger.Warn "In SystemAbortRequest (eWAS_USER_ABORT_AFTER_ACC) " System.SuspendAbort = true If g_bMinimalScan then If Not g_bMinimalScanComplete Then ' in a scan ? Scan.AbortAtEndOfAcc Else ' not in a scan System.Abort WIRESYSTEMLib.eWAS_USER_ABORT ' just abort End If Else Acquisition.StopAfterAcc End If Measurement.Result.Element("", "abortState") = WIRESYSTEMLib.eWAS_USER_ABORT_AFTER_ACC Case WIRESYSTEMLib.eWAS_USER_ABORT_AFTER_SCAN ' Abort at end of current scan System.SuspendAbort = true if MmtAbortState = WIRESYSTEMLib.eWAS_USER_ABORT_AFTER_ACC then ' this should be impossible. Logger.Error "AbortAfterScan called when state was already AbortAfterAcc" else Logger.Warn "In SystemAbortRequest (eWAS_USER_ABORT_AFTER_SCAN) " if not g_bMinimalScan then Acquisition.StopAfterScan end if Measurement.Result.Element("", "abortState") = WIRESYSTEMLib.eWAS_USER_ABORT_AFTER_SCAN end if Case Else ' ignore End Select If Err.Number <> 0 Then System.Abort WIRESYSTEMLib.eWAS_USER_ABORT ' abort Dim sErr : sErr = "System_AbortRequest handler: " & Err.Source & ": " & Err.Description Logger.Error sErr End If If bWasSleeping Then Wake On Error Goto 0 End Sub ' ' AbortState ' Returns the abort state of the current measurement ' Public Function MmtAbortState MmtAbortState = WIRESYSTEMLib.eWAS_OK On Error Resume Next MmtAbortState = Measurement.Result.Element("", "abortState") Logger.Info "mmt abort state = " & CStr(MmtAbortState) & ": errNum = " & CStr(Err.Number) On Error Goto 0 end function ' ' ------------------------------------------------------------------------- ' Sleep for a while whilst permitting Abort to work ' Private Sub SleepWithAbort(nDelay, nInterval) Dim nTime : nTime = 0 g_bSleeping = True Do While g_bSleeping And nTime < nDelay Dim nWaited: nWaited = Sleep2(nInterval) nTime = nTime + CLng(nWaited) Loop End Sub Private Sub SleepWithAbortMsg(nDelay, nInterval, sTemplate) Dim nTime : nTime = 0 Dim nMsgChange : nMsgChange = 1000 g_bSleeping = True Do While g_bSleeping And nTime < nDelay Dim nWaited: nWaited = Sleep2(nInterval) nTime = nTime + CLng(nWaited) If nTime > nMsgChange Then Activity FormatMessage(sTemplate, CLng(nTime / 1000), CLng(nDelay / 1000)) nMsgChange = nMsgChange + 1000 End If Loop End Sub '<HACK> ' ------------------------------------------------------------------------- ' Replicate datasets to simulate RA scan result ' Private Function Replicate(oMemfile) Dim nCount : nCount = oMemfile.NumberOfDataSets LogMessage "Replicate: received " & nCount & " datasets." If nCount < 2 Then Dim n: For n = nCount To 2 Dim sNew : sNew = "DataSet" & CStr(n) LogMessage "Replicate: add dataset " & sNew CloneDataSet oMemfile, "DataSet0", sNew Next LogMessage "Replicate: oMemfile now has " & oMemfile.NumberOfDataSets & " datasets." End If Set Replicate = oMemfile End Function ' Clone a dataset from oSourceDataSet to oMemfile,sNewName Public Sub CloneDataSet(oMemfile, sSourceDataSet, sNewDataSet) Dim oNew, oSource ' Get the source dataset Set oSource = oMemfile.Element("", sSourceDataSet) ' Create the new destination dataset oMemfile.CreateDataSet(sNewDataSet) Set oNew = oMemfile.Element("", sNewDataSet) ' Get the set of keys to use Dim nIndex, oKeys, sKey Set oKeys = CreateObject("Renishaw.WiRECollectionCom") For nIndex = 1 To oSource.Count oKeys.Add oSource.Key(nIndex) Next For Each sKey in oKeys On Error Resume Next If TypeName(oSource.Item(sKey)) = "IWiREDataListCom2" Then Dim oDL, oNewDL Set oDL = oSource.Item(sKey) oMemfile.CreateDataList sNewDataSet, sKey, oDL.Count, True Set oNewDL = oMemfile.Element(sNewDataSet, sKey) oNewDL.VariantData(0, -1) = oDL.VariantData(0, -1) Else oNew.Add sKey, oSource.Item(sKey) End If On Error Goto 0 Next End Sub '</HACK> ' ------------------------------------------------------------------------- ' On Scan complete, add the resulting data to the main memory file. ' Also notify the measurement listers that the data has changed. ' Public Sub Scan_ScanComplete(sFilename, oMemfile) If g_bMinimalScan Then Measurement.Result = oMemfile g_bMinimalScanComplete = True Measurement.RaiseDataUpdate dutScanComplete, Measurement.Result Else On Error Resume Next Set Acquisition.ScanResult = oMemfile If Err.Number <> 0 Then Logger.Error Err.Source & ": " & Err.Description Acquisition.ScanComplete If Err.Number <> 0 Then Dim sErr : sErr = "ScanComplete handler: " & Err.Source & ": " & Err.Description Activity sErr : Logger.Error sErr End If On Error Goto 0 End If Wake End Sub ' ------------------------------------------------------------------------- ' MapScanComplete event signifies that a new dataset has been ' added by a map scan ' Public Sub Scan_MapScanComplete(sFilename, oMemfile) if (Acquisition.AcqMode <> eCompleteSeries ) then ' Shouldn't get here 'Logger.Error "Map scan complete recieved, but shouldn't be doing one." else On Error Resume Next ' Should probably do our incremental saving here. Measurement.RaiseDataUpdate dutScanComplete, oMemfile If Err.Number <> 0 Then LogMessage "Scan_MapScanComplete: " & "(" & Err.Source & ") " & Err.Description end if ' Don't wake. The scan is not really complete End Sub ' ------------------------------------------------------------------------- ' On Scan update propagate the event to our listeners. ' Public Sub Scan_DataUpdate(sFilename, oMemfile) g_nUpdates = g_nUpdates + 1 On Error Resume Next Measurement.RaiseDataUpdate dutScanUpdate, oMemfile If Err.Number <> 0 Then LogMessage "Scan_DataUpdate: " & "(" & Err.Source & ") " & Err.Description End Sub ' ------------------------------------------------------------------------- ' FocusTrack event handler Public Sub FocusTrack_FocusCompleted(bSuccess, dCentre, oMemFile) Acquisition.FocusTrackComplete bSuccess, dCentre, oMemFile Wake End Sub ' ------------------------------------------------------------------------- ' Calculate the time to complete this measurement. ' Public Function TimeToComplete() If Acquisition Is Nothing Then Logger.Warn "TimeToComplete Created a new Acquisition instance! Check logic?" Set Acquisition = New CAcquisition End If Dim nTime nTime = (Scan.DurationEstimate * Acquisition.Count) _ + (Acquisition.Interval * (Acquisition.Count - 1)) Logger.Log "Calculated measurement time to completion is " & CStr(nTime) & "ms" TimeToComplete = nTime End Function ' ------------------------------------------------------------------------- ' Output activity messages to inform the user of our current activity. Private Sub Activity(newVal) Dim s: s = newVal LogMessage CStr(s) On Error Resume Next If IsObject(Acquisition) And Not(Acquisition Is Nothing) Then If Acquisition.HaltAfterAcc Then s = "Aborting after accumulation: " & s ElseIf Acquisition.HaltAfterScan Then s = "Aborting after scan: " & s End If end if If Err.Number <> 0 then Logger.Error Err.Description On Error Goto 0 If IsObject(Scan) Then On Error Resume Next dim oSys: set oSys = Scan.System if err <> 0 then Scan.System = System end if on Error Goto 0 Scan.Activity = CStr(s) End If End Sub ' ------------------------------------------------------------------------- ' Construct a unique filename by affixing a digit to the end of the ' basename. ' Public Function UniqueFilename(sRootName) Dim nIncrement : nIncrement = 1 'bug 1105 - auto-increment to begin at 1. Dim sTempName : sTempName = sRootName Dim sBaseName : sBaseName = GetBaseName(sRootName) Dim sExtension : sExtension = GetExtension(sRootName) Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject") Do While oFSO.FileExists(sTempName) sTempName = sBaseName & CStr(nIncrement) & "." & sExtension nIncrement = nIncrement + 1 Loop UniqueFilename = sTempName End Function Private Function GetExtension(sName) Dim aSplit : aSplit = Split(sName, ".") GetExtension = aSplit(UBound(aSplit)) End Function Private Function GetBaseName(sName) Dim sExt : sExt = GetExtension(sName) GetBaseName = Left(sName, Len(sName) - Len(sExt) - 1) End Function Private Function SequencedFilename(sRootName, nNumber) SequencedFilename = GetBaseName(sRootName) _ & "-" & CStr(nNumber) & "." & GetExtension(sRootName) End Function ' ------------------------------------------------------------------------- ' Dump an object to an XML file for examination. ' Public Sub DumpToXML(oThing, sFilename) Dim doc, node, bag Set doc = CreateObject("MSXML.DOMDocument") Set node = doc.createElement("Persisted") Set node = doc.appendChild(node) Set bag = CreateObject("Renishaw.PropertyBagOnXML") bag.save oThing, node doc.save sFilename End Sub ''' ------------------------------------------------------------------------- 'Include "wirelib:Logger.vbs" ''' ------------------------------------------------------------------------- ' Logger.vbs - Written by Pat Thoyts, Copyright (C) 2002 Renishaw plc ' ' Provide status logging through the WiRE2 Diagnostic display object. ' ' TypeLib: WIREDIAGNOSTICHELPERLib 1.0 = {69C18F55-7026-41FB-97E5-AE2FF9CBA9DE} ' Import "Renishaw.WiREDiagnosticHelper" Class CLogger Private m_DiagnosticServer Private m_sLogName Private m_eLogType Private Sub Class_Initialize Set m_DiagnosticServer = CreateObject("Renishaw.WiREDiagnosticHelper") m_sLogName = "Measurement" m_eLogType = eWIRE_MEASUREMENT End Sub Public Property Get Name() : Name = m_sLogName : End Property Public Property Let Name(newVal) : m_sLogName = CStr(newVal) : End Property Public Property Get Application() : Application = m_eLogType : End Property Public Property Let Application(newVal) : m_eLogType = newVal : End Property Public Sub Error(Message) m_DiagnosticServer.LogWiRE2Event eAPPLICATION_CRITICAL, _ m_eLogType, m_sLogName, Message End Sub Public Sub Warn(Message) m_DiagnosticServer.LogWiRE2Event eAPPLICATION_NONCRITICAL, _ m_eLogType, m_sLogName, Message End Sub Public Sub Log(Message) m_DiagnosticServer.LogWiRE2Event eAPPLICATION_FUNCTION, _ m_eLogType, m_sLogName, Message End Sub Public Sub Debug(Message) m_DiagnosticServer.LogWiRE2Event eAPPLICATION_INFORMATION, _ m_eLogType, m_sLogName, Message End Sub End Class ''' ------------------------------------------------------------------------- 'Include "wirelib:AutoMultiSequenceOperation.vbs" ''' ------------------------------------------------------------------------- ' AutoMultiSequenceOperation.vbs - Written by Pat Thoyts, Copyright (C) 2002 Renishaw plc ' ' Provide instrument lamp management ' ' Require "wirelib:Logger.vbs" Class CAutoMultiSequenceOperation Private m_oSystem ' the system object Private m_oLogger ' our logger object Private m_sName ' Our multi sequence operation name Private m_bStarted ' True if the operation is started Private m_bDebug ' Set this to True to see Log messages Private Sub Class_Initialize() Set m_oSystem = Nothing Set m_oLogger = New CLogger m_sName = "AutoMultiSequenceOperation" m_bStarted = False m_bDebug = False End Sub Private Sub Class_Terminate If m_bDebug Then Logger.Log "CAutoMultiSequenceOperation Class_Terminate" Halt End Sub Public Sub Init(oSystem) Set Me.System = oSystem End Sub Public Property Get System() : Set System = m_oSystem : End Property Public Property Set System(oSystem) : Set m_oSystem = oSystem : End Property Public Property Get Name() : Name = m_sName : End Property Public Property Let Name(sName) : m_sName = CStr(sName) : End Property Public Property Get Debug() : Debug = m_bDebug : End Property Public Property Let Debug(bDebug) : m_bDebug = CBool(bDebug) : End Property Public Sub Start() If IsObject(m_oSystem ) And Not(m_oSystem Is Nothing) Then On Error Resume Next m_oSystem.MultiSequenceOperation 0, m_sName If Err.Number = 0 Then m_bStarted = True If m_bDebug Then m_oLogger.Log "CAutoMultiSequenceOperation Start(): Started " & m_sName Else If m_bDebug Then m_oLogger.Error "CAutoMultiSequenceOperation Start(): " & Err.Description End If Else Raise "Start", "You must assign the System property to start a multi sequence operation." End If End Sub Public Sub Halt() If IsObject(m_oSystem ) And Not(m_oSystem Is Nothing) Then m_oSystem.MultiSequenceOperation 1, m_sName m_bStarted = False Else Raise "Halt", "You must assign the System property to stop a multi sequence operation." End If End Sub Private Sub Raise(sLocation, sMessage) m_oLogger.Error "CAutoMultiSequenceOperation Error: " & sMessage Err.Raise vbObjectError + 1, "CAutoMultiSequenceOperation_" & sLocation, sMessage End Sub End Class ''' ------------------------------------------------------------------------- 'Include "wirelib:CameraWrapper.vbs" ''' ------------------------------------------------------------------------- ' CameraWrapper.vbs - Written by Pat Thoyts, Copyright (C) 2002 Renishaw plc ' ' Provide a wrapper around the WiRECameraCom object and in particular a method ' to report information about the current state of the camera - ReportCameraStatus ' ' Version: 2.0.9.0 Class CCameraWrapper Private m_oCamera Private m_nInitialDataCount Private m_nLastDataCount Private Sub Class_Initialize() Set m_oCamera = Nothing End Sub ' Initialize the instance from a System object Public Sub Init(oSystem) Set m_oCamera = oSystem.USBCamera m_nInitialDataCount = GetLongAt(Me.Status, 12) m_nLastDataCount = m_nInitialDataCount End Sub ' Initialize from a Camera object Public Property Set Camera(newVal) : Set m_oCamera = newVal : End Property Public Property Get Camera() : Set Camera = m_oCamera : End Property Public Property Get Initialized() Initialized = IsObject(m_oCamera) And Not(m_oCamera Is Nothing) End Property Public Function CreateCommand(nID) CreateCommand = Array(nID, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) End Function ' Dump the contents of a USB command array for debugging Public Function DumpCommand(aCommand) Dim n, s For n = 0 To 15 s = s & " " & CStr(aCommand(n)) Next DumpCommand = s End Function Public Function TraceBuffer() Dim aCmd : aCmd = CreateCommand(99) aCmd(1) = CByte(255) aCmd(2) = 0 Dim aRes, nCount, nIndex, aTrace, nByte aRes = m_oCamera.Exec(aCmd) If aRes(0) <> 0 Then ReDim aTrace(0) Else nCount = aRes(1) + (aRes(2) * &h100) ReDim aTrace(nCount) For nIndex = 0 To nCount Step 13 aCmd(2) = nIndex And 255 aCmd(3) = nIndex / 256 aRes = m_oCamera.Exec(aCmd) For nByte = 0 To 12 If nIndex + nByte < nCount Then _ aTrace(nIndex + nByte) = aRes(nByte+3) Next Next End If TraceBuffer = aTrace End Function Private Function GetLongAt(aArray, nStartPos) 'intel byte order GetLongAt = aArray(nStartPos) + (aArray(nStartPos+1) * &H100) _ + ((aArray(nStartPos+2) + (aArray(nStartPos+3) * &H100)) * &H10000) End Function Public Property Get Status() If Me.Initialized Then Status = m_oCamera.Exec(CreateCommand(19)) ' SEQ_STATUS2 Else Err.Raise vbObjectError+1, "Diagnostics", "CameraWrapper has not been initialized with a camera instance." End If End Property Public Sub SequenceReset() If Me.Initialized Then m_oCamera.Send CreateCommand(2) ' SEQ_RESET Else Err.Raise vbObjectError+1, "Diagnostics", "CameraWrapper has not been initialized with a camera instance." End If End Sub Public Property Get Diagnostics(nSubCommand) If Me.Initialized Then Dim aCmd : aCmd = CreateCommand(99) ' DIAGNOSTICS aCmd(1) = CByte(nSubCommand) Diagnostics = m_oCamera.Exec(aCmd) Else Err.Raise vbObjectError+1, "Diagnostics", "CameraWrapper has not been initialized with a camera instance." End If End Property Public Function ReportCameraStatus() Dim aStatus: aStatus = Me.Status Dim nCount : nCount = GetLongAt(aStatus, 12) Dim aDiags : aDiags = Me.Diagnostics(6) Dim nCCDWords : nCCDWords = GetLongAt(aDiags, 3) Dim nEP2BufCount : nEP2BufCount = GetLongAt(aDiags, 7) Dim s s = s & " ErrCode: " & aStatus(0) s = s & " Running: " & aStatus(1) s = s & " CommandNo: " & aStatus(2) s = s & " FinalCmd: " & aStatus(8) s = s & " CommandID: " & aStatus(3) s = s & " CCD Words: " & nCCDWords s = s & " EP2Buffer: " & nEP2BufCount s = s & " DataCount: " & nCount s = s & " DiffCount: " & nCount - m_nLastDataCount m_nLastDataCount = nCount ReportCameraStatus = s End Function End Class ''' ------------------------------------------------------------------------- 'Include "wirelib:XYZStage.vbs" ''' ------------------------------------------------------------------------- ' XYZStage.vbs - Copyright (c) 2002 Renishaw plc ' ' Wrapper for the XYZ stage object ' ' Requires "wirelib:Logger.vbs" ' TypeLib: WIREXYZLib 1.0 = {dae0ff43-c76e-11d4-8945-00003c508b6f} Import "{dae0ff43-c76e-11d4-8945-00003c508b6f}" Import "Renishaw.WiRESystemCom" ' ------------------------------------------------------------------------- ' Include "wirelib:TemperatureStage.vbs" ' ------------------------------------------------------------------------- ' TemperatureStage.vbs - Copyright (C) 2002-2009 Renishaw plc ' ' Set Linkam hot-cold stage temperature via the RS232 Port ' The TMS93/94 operates in degrees C and degrees C/min. WiRE operates in degrees absolute and ' so we'll need to convert in here. ' Const s_Version_TemperatureStage = "3.2.2.3" Const AbsoluteZero = 273.15 Class CTemperatureStage Private m_sType Private m_oComm Private m_nComPort Private m_sComSettings Private m_nComHandshaking Private m_nRamp Private m_nInterval Private m_bAbort Private m_bLog Private m_bTestMode Private m_TestTemp Private Sub Class_Initialize() m_sType = "TMS94" ' one of TMS92, TMS93, TMS94, T95 m_nComPort = 1 ' default is COM1 m_sComSettings = "19200,N,8,1" ' default params (default for TMS93/94 m_nComHandshaking = 2 ' 0: none, 1: xonxoff, 2: rtscts m_nRamp = 5 m_nInterval = 10 m_bLog = True m_bTestMode = false ' Create using support for licenses classes: requires a license pack for WiRE. Set m_oComm = WiRE.CreateObject("MSCommLib.MSComm") End Sub Private Sub Class_Terminate() If IsObject(m_oComm) And Not(m_oComm Is Nothing) Then On Error Resume Next ' Reset the stage so it's not heating or holding. Reset m_oComm.PortOpen = False End If End Sub Public Sub Init(oSystem) Dim oProps : Set oProps = oSystem.HostedObject(17) ' WIRESYSTEMLib.eSHO_PROPERTIES On Error Resume Next Me.TMSType = CStr(oProps.Item("TemperatureStageType")) Me.Port = CStr(oProps.Item("TemperatureStagePort")) Me.Settings = CStr(oProps.Item("TemperatureStageSettings")) Me.Handshaking = CLng(oProps.Item("TemperatureStageHandshaking")) On Error Goto 0 'Echo "Initialized " & Me.TMSType & " on COM" & Me.Port & " " _ ' & Me.Settings & " handshaking " & Me.Handshaking End Sub Public Property Get Port() : Port = m_nComPort : End Property Public Property Let Port(newVal) : m_nComPort = CLng(newVal) : End Property Public Property Get Settings() : Settings = m_sComSettings : End Property Public Property Let Settings(newVal) : m_sComSettings = CStr(newVal) : End Property Public Property Get Handshaking() : Handshaking = m_nComHandshaking : End Property Public Property Let Handshaking(newVal) : m_nComHandshaking = CLng(newVal) : End Property Public Property Get Ramp() : Ramp = m_nRamp : End Property Public Property Let Ramp(newVal) : m_nRamp = CDbl(newVal) : End Property Public Property Get Object() : Set Object = m_oComm : End Property Public Property Get TMSType() : TMSType = m_sType : End Property Public Property Let TMSType(newVal) m_sType = CStr(newVal) If m_sType = "TMS95" Then m_sType = "T95" ' it is called T95 now End Property Public Property Get Abort() Abort = m_bAbort End Property Public Property Let Abort(newVal) m_bAbort = CBool(newVal) End Property Public Sub Reset() Sleep 100 Call Send("E") End Sub ' Set the TMS target temperature and begin ramping. Public Sub SetTemperatureAsync(newVal) Dim sCommData, nTarget nTarget = Round((newVal - AbsoluteZero) * 10) if (m_bTestMode) then m_TestTemp = newVal If m_bLog Then LogMessage "SetTemperature to " & nTarget & " ramp at " & m_nRamp 'Set step 1: ramp, limit, and hold interval sCommData = Send("R1" & Round(m_nRamp * 100)) sCommData = Send("L1" & nTarget) ' This command appears to be required for pre TMS93 stages If m_sType = "TMS92" Then sCommData = Send("I1" & CLng(m_nInterval)) End If 'Start sCommData = Send("S") End Sub Public Sub Hold () Send("O") End Sub Private Function CelciusFromRaw(sCommData) Dim sHex : sHex = "&h" & Mid(sCommData, 7, 4) CelciusFromRaw = CInt(sHex) / 10 ' NB: must be CInt here - data is WORD. If m_bLog Then Dim sta : sta = Asc(Left(sCommData,1)) And 255 Dim err : err = Asc(Mid(sCommData,2,1)) And 255 LogMessage "TMS Wait: " & CStr(CelciusFromRaw) _ & "°C & status: " & Hex(sta) _ & " error: " & Hex(err) End If End Function ' Set the temperature of the TMS93 Stage ' Parameters should be in degrees K Public Property Let Temperature(newVal) If m_bLog Then LogMessage m_sType & " controller on port " & m_nComPort & " set to " & m_sComSettings SetTemperatureAsync newVal 'Wait for temperature holding Dim sCommData : sCommData = Chr(255) & Chr(13) 'Timeout after 1000secs? Dim iCount : iCount = 0 m_bAbort = False If (Not m_bTestMode) then Dim status : status = &h10 Do While Not(m_bAbort) And (status = &h10 Or status = &h20) And iCount < 100000 Sleep 10 sCommData = Send2("T", False) On Error Resume Next Dim nC : nC = CelciusFromRaw(sCommData) If Err.Number <> 0 Then Logger.Error Err.Description & " : " & Err.Source On Error Goto 0 iCount = iCount + 1 status = Asc(Left(sCommData,1)) And 255 Loop End If 'Set to holding If m_bAbort Then Reset Else sCommData = Send("O") End If 'Close Serial port m_oComm.PortOpen = False End Property Public Property Get Temperature() Dim sReply, nCount, nC, nK nK = -1 : nC = -1 If (not m_bTestMode) then For nCount = 0 To 3 sReply = Send("T") If Len(sReply) > 1 Then On Error Resume Next Dim sHex : sHex = "&h" & Mid(sReply, 7, 4) nC = CInt(sHex) / 10 If Err.Number <> 0 Then Logger.Error Err.Description & " : " & Err.Source On Error Goto 0 nK = nC + AbsoluteZero Temperature = nK Exit For End If LogMessage "Get Temperature sleep" Sleep 200 Next Else nK = m_TestTemp Temperature = m_TestTemp End If If nK < 0 Then Err.Raise vbObjectError + 1, "CTemperatureStage_Temperature", _ "Failed to read reply string from temperature stage." End If End Property Public Function ReadQuietly() On Error Resume Next Do While Not(m_oComm.PortOpen) Err.Clear Me.PortOpen = True If Err.Number <> 0 Then Sleep 250 LogMessage "Retrying port open..." End If Loop ReadQuietly = Me.Temperature m_oComm.PortOpen = False End Function Public Property Let PortOpen(bOpen) ' Connect up the serial object and apply the comms settings. If m_oComm.PortOpen Then m_oComm.PortOpen = False If bOpen Then m_oComm.CommPort = m_nComPort m_oComm.Settings = m_sComSettings m_oComm.Handshaking = m_nComHandshaking m_oComm.InputLen = 0 ' full buffer transfer On Error Resume Next m_oComm.PortOpen = True End If End Property Public Property Get PortOpen() PortOpen = False If IsObject(m_oComm) And Not(m_oComm Is Nothing) Then PortOpen = m_oComm.PortOpen End If End Property Private Function Send(sCommand) Send = Send2(sCommand, m_bLog) End Function Private Function Send2(sCommand, bLog) Dim sReply If m_oComm.PortOpen = False Then Me.PortOpen = True If bLog Then LogMessage "TMS Send: " & sCommand m_oComm.Output = sCommand & Chr(13) Sleep 500 sReply = WaitForCR(m_oComm) If bLog Then LogMessage "TMS Reply: " & sReply Send2 = sReply End Function 'Wait for RS232 reply with CR termination (> 10 sec timeout) Private Function WaitForCR(oComm) Dim sData, iTmp, iCount sData = oComm.Input iCount = 0 Do While Right(SData,1) <> Chr(13) AND iCount < 8 Sleep 200 sData = sData & oComm.Input If m_bLog Then LogMessage "TMS Wait: " & sData iCount = iCount + 1 Loop If Right(sData, 1) <> Chr(13) Then Err.Raise vbObjectError + 1, "Temperature Stage Control", _ "A timeout occurred waiting for a response from the temperature stage. Stage controller not connected?" End If WaitForCR = sData End Function End Class ' ------------------------------------------------------------------------- ' Include "wirelib:ExplodeLineFocus.vbs" ' ------------------------------------------------------------------------- ' ExplodeLineFocus.vbs - Copyright (C) 2002 Renishaw plc ' Modified to explode inplace for each collected dataset. ' Get the Linefocus stepsize value. (Binning independant). Function GetLinefocusStepSize ' The Wizard puts this in to the properties for us. On Error Resume Next GetLinefocusStepSize = Measurement.Properties("yStepSize") If Err.Number = 0 Then Exit Function On Error Goto 0 ' We can also calulate it locally if required. Logger.Warn "Calculating Linefocus step size locally." Dim oCCD, oCCDArea Set oCCD = System.ICCD oCCD.SelectCCDFromKey InstrumentState.AreaKey Set oCCDArea = oCCD.ICurrentArea Dim dMIF, dPixelSizeMM, dObjective, dStepSize dMIF = System.MicroscopeImageFactorForAreakey(InstrumentState.AreaKey.ID) dPixelSizeMM = oCCD.YPixelSizeMillimetres dObjective = GetObjective() dStepSize = (3.0 * dMIF * dPixelSizeMM) / dObjective GetLinefocusStepSize = dStepSize End Function ' Get the current objective value from the motor. Function GetObjective on error resume next Dim oObjective Set oObjective = System.HostedObject(eSHO_OBJECTIVE) ' current objective if err.number <> 0 then Logger.Error "No current objective! Forcing to 50" GetObjective = 50 ' safe default else GetObjective = oObjective.Magnification end if On Error Goto 0 End Function ' Calculate the Y center pixel from the currently selected area key. Function CalculateYCenterPixel() Dim oCCDArea, nTop, nBottom Set oCCDArea = System.ICCD.ICurrentArea nTop = oCCDArea.AreaTop nBottom = oCCDArea.AreaBottom If nTop > nBottom Then nTop = nBottom nBottom = oCCDArea.Top End If CalculateYCenterPixel = nTop + ((nBottom - nTop) / 2) End Function ' ------------------------------------------------------------------------- ' Image Capture ' ' Once initialized, usage is GrabImage(1), GrabImage(2), ' SaveImages(oMemFile), UpdateDataset(oMemfile, sDataset) for 1 or more ' datasets then Reset() to forget the image paths and drop the collected ' images. We _always_ call all the above and the object will determine ' from measurement properties which images are actually captured and ' will update the datasets appropriately. ' ' Set imageCapture to 0 for none, 1 for before, 2 for after or 3 for both ' imageCapturePause to the number of millisecs to wait for the image to ' settle down -- at least 1.5s is desirable. ' Class CImageCapture Private m_eCaptureMode ' none = 0, pre = 1, post = 2, both= 3 Private m_nCapturePause ' millisecs to wait for image to settle. Private m_bIllumLampOn ' whether or not to have the lamp on for the image capture. Private m_oPreImage ' internal storage for the pre image object Private m_oPostImage ' internal storage for the post image object Private m_sPrePath ' path of the pre image in the memory file Private m_sPostPath ' path of the post image in the memory file Private m_nUID ' uid for image paths. Private m_bHavePodule ' do we have a podule? Private m_bNotFirst ' true if we have collected an image Private m_oInstrumentState Private m_oInstrument Private Sub Class_Initialize() m_eCaptureMode = 0 m_nCapturePause = 1500 m_nUID = 0 m_bNotFirst = False Set m_oInstrumentState = Nothing Set m_oInstrument = Nothing m_bHavePodule = CBool(System.SystemType And eWSY_PODULE) m_bIllumLampOn = True ' default to white light illumination ON. On Error Resume Next m_eCaptureMode = CLng(Measurement.Properties("imageCapture")) m_nCapturePause = CLng(Measurement.Properties("imageCapturePause")) m_bIllumLampOn = CBool(Measurement.Properties("illuminationLampOn")) On Error Goto 0 If m_eCaptureMode > 3 Then Logger.Error "Illegal image capture mode """ & m_eCaptureMode & """. Set to 0." m_eCaptureMode = 0 End If ' If capturing, check that the system supports video. If m_eCaptureMode > 0 _ And (System.SystemType And WIRESYSTEMLib.eWSY_VIDEO) <> WIRESYSTEMLib.eWSY_VIDEO Then Logger.Error "Image capture requested but video is unavailable" Else Logger.Debug "Image capture set to """ & m_eCaptureMode & """" _ & ". Image settling delay is " & m_nCapturePause/1000.0 & "s" End If Me.Reset End Sub public property Get IlluminationLampOn() IlluminationLampOn = m_bIllumLampOn End property Public Property Let CaptureMode (newVal) If newVal > 3 Then Logger.Error "Illegal image capture mode """ & m_eCaptureMode & """. Set to 0." m_eCaptureMode = 0 End If ' If capturing, check that the system supports video. If newVal > 0 _ And (System.SystemType And WIRESYSTEMLib.eWSY_VIDEO) <> WIRESYSTEMLib.eWSY_VIDEO Then Logger.Error "Image capture requested but video is unavailable" Else Logger.Debug "Image capture set to """ & newVal & """" _ & ". Image settling delay is " & m_nCapturePause/1000.0 & "s" End If m_eCaptureMode = newVal End Property Public Property Get CaptureMode() CaptureMode = m_eCaptureMode End Property Public Sub GrabImage(eMode, bSettle) If eMode And m_eCaptureMode Then Dim s : If eMode = 1 Then s = "pre-scan" Else s = "post-scan" Logger.Debug "Capturing " & s & " image." If Not m_bHavePodule Then Dim bSkip : bSkip = m_eCaptureMode = 3 And eMode = 1 And m_bNotFirst If Not bSkip Then MsgBox FormatMessage(g_sImageCollectMessage), vbOKOnly + vbQuestion + vbSystemModal, FormatMessage(g_sImageCollectTitle) End If bSettle = False End If On Error Resume Next GrabImageInternal eMode, bSettle If Err.Number <> 0 Then Logger.Error "Image capture error: " & Err.Description & " (" & Err.Source & ")" End If If Not m_bHavePodule Then ' Can skip if we are collecting both and this is the post image If Not(m_eCaptureMode = 3 And eMode = 2) Then MsgBox FormatMessage(g_sDataCollectMessage), vbOKOnly + vbQuestion + vbSystemModal, FormatMessage(g_sDataCollectTitle) End If End If m_bNotFirst = True ElseIf m_eCaptureMode = 2 And eMode = 1 And Not(m_bNotFirst) Then ' For collecting after images, we still need to show the data warning on basis the first time round. If Not m_bHavePodule Then MsgBox FormatMessage(g_sDataCollectMessage), vbOKOnly + vbQuestion + vbSystemModal, FormatMessage(g_sDataCollectTitle) End If End If End Sub Private Sub GrabImageInternal(eMode, bSettle) SwitchToWhitelight On Error Resume Next System.VideoUseMode = eUSERVIDEO If Err.Number <> 0 Then Logger.Error "Caught error from System.VideoUseMode: " & Err.Description End If On Error Goto 0 Dim oVideo: Set oVideo = System.VideoViewer If Not(oVideo.IsDeviceInitialised) Then oVideo.InitialiseDevice 0 If Not(oVideo.IsVideoPreviewing) Then oVideo.StartVideoPreview If bSettle Then SleepWithAbortMsg m_nCapturePause, 200, "Pausing for light balance to settle. %1s of %2s completed" End If If eMode = 1 Then Set m_oPreImage = oVideo.SaveImageToObject(0) Logger.Debug "Captured pre-scan video image." Else Set m_oPostImage = oVideo.SaveImageToObject(0) Logger.Debug "Captured post-scan video image." End If 'SwitchToRaman End Sub Private Sub InitInstrument() Set m_oInstrumentState = InstrumentState 'CreateObject("Renishaw.WiREInstStateCom") Set m_oInstrument = new CInstrument m_oInstrument.Init m_oInstrumentState, System 'm_oInstrumentState.InitialiseFromSystem End Sub Public Sub SwitchToWhitelight() Logger.Debug "Switching to whitelight for image capture" On Error Resume Next Instrument.ApplyWhitelight m_bIllumLampOn If Err.Number <> 0 Then Logger.Warn Err.Source & ": " & Err.Description On Error Goto 0 End Sub Public Sub SwitchToRaman() Logger.Debug "Switching to raman signal after image capture" On Error Resume Next Instrument.Apply If Err.Number <> 0 Then Logger.Warn Err.Source & ": " & Err.Description On Error Goto 0 End Sub Public Sub SaveImages(oMemoryFile) 'Logger.Debug "ImageCapture.SaveImages" m_sPrePath = "" : m_sPostPath = "" If Not(m_oPreImage Is Nothing) Then m_sPrePath = "/Images/Image" & CStr(m_nUID) m_nUID = m_nUID + 1 oMemoryFile.Element(m_sPrePath, "") = m_oPreImage End If If Not(m_oPostImage Is Nothing) Then m_sPostPath = "/Images/Image" & CStr(m_nUID) m_nUID = m_nUID + 1 oMemoryFile.Element(m_sPostPath, "") = m_oPostImage End If End Sub Public Sub UpdateDataset(oMemoryFile, sDataset) 'Logger.Debug "ImageCapture.UpdateDataset for " & sDataset If Not(m_oPreImage Is Nothing) Then If m_sPrePath = "" Then SaveImages oMemoryFile oMemoryFile.Element(sDataset, "ImageBefore") = m_sPrePath End If If Not(m_oPostImage Is Nothing) Then If m_sPostPath = "" Then SaveImages oMemoryFile oMemoryFile.Element(sDataset, "ImageAfter") = m_sPostPath End If End Sub Public Sub Reset() 'Logger.Debug "ImageCapture.Reset" Set m_oPreImage = Nothing Set m_oPostImage = Nothing m_sPrePath = "" m_sPostPath = "" End Sub End Class ' ------------------------------------------------------------------------- ' Checksum: 0x70ee3771 ' Local Variables: ' mode: basic ' basic-initial-indent: 0 ' basic-default-indent: 4 ' End:000<_nitems vt:type="VT_I4">2<_key0 vt:type="VT_BSTR">InstrumentStatelaser321grating2022101050013100100010000020<_key1 vt:type="VT_BSTR">Scan2500laser321grating2022116305001001101001100010<_nitems vt:type="VT_I4">0000<_nitems vt:type="VT_I4">11<_key0 vt:type="VT_BSTR">AcquisitionCount1<_key1 vt:type="VT_BSTR">closeLaserShutter0<_key2 vt:type="VT_BSTR">CreationTime09/10/2019 18:14:50<_key3 vt:type="VT_BSTR">HWND131488<_key4 vt:type="VT_BSTR">LUT_Auto-1<_key5 vt:type="VT_BSTR">MeasurementTypeSingleScan<_key6 vt:type="VT_BSTR">minimizeLaserExposure0<_key7 vt:type="VT_BSTR">OperatorRaman User<_key8 vt:type="VT_BSTR">responseCalibration0<_key9 vt:type="VT_BSTR">restoreInstrumentState0<_key10 vt:type="VT_BSTR">wizardclsid{7A6C14A3-DBB1-4101-A6C7-1D0D58988EF1}{00000000-0000-0000-0000-000000000000}594193012500{8DD949CD-AF27-11D4-932A-0050044F4BA1}125Spectrum Viewer 1<_cx vt:type="VT_UI4">38656<_cy vt:type="VT_UI4">94460.15255-1-100000-1-10-10101-12812400.850.1680672268907560.150.155.81793292265572E-020.020010101677721525500.020.02000.40.40010100.150.150.40.40.10.10.30.30.050.05-13-13-11-11-1-16085-2-2661414-1-1-1-1-1-10000-1-100000000000000001133441111000000ArialArialRaman shift / cm-1CountsArialArial0000010200010047500000-1-1-1-1-1-100020-1-2-210005343678196-10148336755236755236761440

11168010500