Same Outtol script that works on 3 CMM's it doesn't work on this. Gives me this error message. Anyone know what could cause that? Any input is greatly appreciated. Thank you!
Dim objApp As Object
Set objApp = CreateObject("PCDLRN.Application")
Dim objPart As Object
Set objPart = objApp.ActivePartProgram
Dim objCmds 'As Object
Set objCmds = objPart.Commands
Dim objCmd 'As Object
Dim objDimCmd As Object
Dim dblOutTol As Long
dblOutTol = 0
Dim dblTotalMeas As Long
dblTotalMeas = 0
'Open newdir & "\DIMENSIONSEVALUATED.TXT" For Output As #3
Dim prevID1Name As String
Dim count1
Dim count2
Dim prevcount1
Dim prevcount2
Dim prevID2Name As String
Dim objCmdDeviation As Double
Dim objCmdOuttol As Double
Dim ID1 As String
Dim ID2 As String
Dim DimensionName As String
Dim Msg As String
Dim cnt As Integer
For cnt =1 To Objcmds.count
Set objcmd = objcmds.Item(cnt)
If objcmd.marked = True Then 'CHECK For MARKED DIMENSIONS HERE
If objcmd.IsDimension Then
Set Dimensionname = objcmd.DimensionCommand
ID1 = Dimensionname.feat1 'capture the ID Name of the command that is being looked at.
count1 = cnt
If ID1 = "" Then 'Make sure that commands always have a Name.
ID1 = prevID1Name
count1 = prevcount1
End If
prevID1Name = ID1 'Save the old Name just In Case the Next one is ""
prevcount1 = count1
ID2 = Dimensionname.feat2
count2 = cnt
If ID2 = "" Then
ID2 = prevID2Name
count2 = prevcount2
End If
PrevID2Name = ID2
prevcount2 = count2
If count1 = count2 Then 'If .feat1 And .feat2 names were found On the same Line, Then assign them both To the ID thats outtol
ID1 = ID1 & "-" & ID2
End If
End If
'Second Step: first possibility: hunt For legacy dimensions
If objCmd.IsDimension And objCmd.Type<>1000 Then
dblTotalMeas=dblTotalMeas+1
Set objDimCmd=objCmd.DimensionCommand
If objDimCmd.OutTol<>0 Then
dblOutTol=dblOutTol+1
Msg = Msg & ID1 & Chr(10)
End If 'objDimCmd.OutTol<>0
'Print #3, "***LEGACY***" & ID1 & "***"
'Print #3, "objCmd.Type: " & objcmd.Type
'Print #3, "OUTTOL number: " & objDimCmd.OutTol
'Print #3, "Number out of tolerance: " & dblOutTol
'Print #3, "Total evaluated: " & dblTotalMeas
'Print #3, ""
End If 'objCmd.IsDimension
'Third Step: second possibility: hunt For XactMeasure GD&T dimensions
If objCmd.Type=184 Then 'this seems To be the way To find an XactMeasure GD&T Call.
If objCmd.gettext(LINE1_OUTTOL,1)<>"" Then 'look In Line 1 For an OUTTOL
dblTotalMeas=dblTotalMeas+1
If objCmd.gettext(LINE1_OUTTOL,1)<>0 Then 'If there is an OUTTOL In Line 1, is it Not zero?
dblOutTol=dblOutTol+1
Msg = Msg & ID1 & Chr(10)
End If 'objCmd.gettext(LINE1_OUTTOL,1)<>0
'Print #3, "***XactMeasure Line1***" & ID1 & "***"
'Print #3, "OUTTOL number: " & objCmd.gettext(LINE1_OUTTOL,1)
'Print #3, "Number out of tolerance: " & dblOutTol
'Print #3, "Total evaluated: " & dblTotalMeas
'Print #3, ""
End If 'objCmd.gettext(LINE1_OUTTOL,1)<>""
If objCmd.gettext(LINE2_OUTTOL,1)<>"" Then 'look In Line 2 For an OUTTOL
dblTotalMeas=dblTotalMeas+1
If objCmd.gettext(LINE2_OUTTOL,1)<>0 Then 'If there is an OUTTOL In Line 2, is it Not zero?
dblOutTol=dblOutTol+1
Msg = Msg & ID1 & Chr(10)
End If 'objCmd.gettext(LINE1_OUTTOL,1)<>0
'Print #3, "***XactMeasure Line2***" & ID1 & "***"
'Print #3, "OUTTOL number: " & objCmd.gettext(LINE2_OUTTOL,1)
'Print #3, "Number out of tolerance: " & dblOutTol
'Print #3, "Total evaluated: " & dblTotalMeas
'Print #3, ""
End If 'objCmd.gettext(LINE2_OUTTOL,1)<>""
If objCmd.gettext(LINE3_OUTTOL,1)<>"" Then 'look In Line 3 For an OUTTOL
dblTotalMeas=dblTotalMeas+1
If objCmd.gettext(LINE3_OUTTOL,1)<>0 Then 'If there is an OUTTOL In Line 3, is it Not zero?
dblOutTol=dblOutTol+1
Msg = Msg & ID1 & Chr(10)
'End If 'objCmd.gettext(LINE3_OUTTOL,1)<>0
'Print #3, "***XactMeasure Line3***" & ID1 & "***"
'Print #3, "OUTTOL number: " & objCmd.gettext(LINE3_OUTTOL,1)
'Print #3, "Number out of tolerance: " & dblOutTol
'Print #3, "Total evaluated: " & dblTotalMeas
'Print #3, ""
End If 'objCmd.gettext(LINE3_OUTTOL,1)<>""
End If 'objCmd.Type=184
End If 'objcmd.marked = True 'End marked search here
End If
Next cnt
'Close #3
Dim Var
Dim Var2 As Object
If dblouttol = 0 Then
msgbox "Part is GOOD!"
Set Var = objPART.GetVariableValue ("SUB_OUTTOLNUM") 'Grabs the variable SUB_OUTTOLNUM from the subroutine program
Var.stringvalue = dblouttol 'Sets variable As number of outtol dimensions. Change this To actual CMM Name/number
Set Var2 = objPART.getvariablevalue ("SUB_ACCEPTREJECT") 'Grabs the variable Sub_ACCEPTREJECT from the subroutine program
var2.stringvalue = "~~1 ACCEPTED" 'Sets variable As Accept, As part is good
End If
If dblouttol > 0 Then
MsgBox "Part is BAD!" & Chr(10) & "Number of Dimensions Out of Tolerance:" & dblouttol & Chr(10) &"Features out of tolerance:" & Chr(10) & Msg ' Display the ID's that are out of tolerance
Set Var = objPART.GetVariableValue ("SUB_OUTTOLNUM") 'Grabs the variable SUB_OUTTOLNUM from the subroutine program
Var.stringvalue = dblOutTol 'Sets variable As number of outtol dimensions. Change this To actual CMM Name/number
Set Var2 = objPART.getvariablevalue ("SUB_ACCEPTREJECT") 'Grabs the variable Sub_ACCEPTREJECT from the subroutine program
var2.stringvalue = "~~4 REJECTED" 'Sets variable As Accept, As part is good
End If
objPART.SetVariableValue "SUB_OUTTOLNUM", Var 'Passes the number of outtol dimensions back To the subroutine
objPART.SetVariableValue "SUB_ACCEPTREJECT", Var2
End Sub
