hexagon logo
Register Sign in
  • Replies 29 replies
  • Subscribers 32 subscribers
  • Views 614 views
  • Users 0 members are here
Options
Related

Need help on OUTTOL.BAS file

jjewell
I have used this script many time and have even made a couple minor mods.
Here is my issue. It is looking for "END OF DIMENSION" and profiles and distances do not have this. It skips over and ignore those. Anybody have an idea as to how I can mod this script to do this ???

Time is critical, I appreciate anyone who responds and helps !! 

For Each Cmd In Cmds
    ' if the command of the current iteration is a dimension ...
    If Cmd.IsDimension Then
      ' and it is not a start or end dimension object ...
      If Cmd.Type <> DIMENSION_START_LOCATION And _
         Cmd.Type <> DIMENSION_END_LOCATION And _
         Cmd.Type <> DIMENSION_TRUE_START_POSITION And _
         Cmd.Type <> DIMENSION_TRUE_END_POSITION Then
        ' then get the dimensioncommand object from the command
        Set DimCmd = Cmd.DimensionCommand
        ' If it is out of tolerance, increment numberout, otherwise increment numberin
        If DimCmd.OutTol > 0 Then
          NumberOut = NumberOut + 1
        Else
  • The code is missing a subroutine start.

    sub Main()
  • Doh! AstonishedBlush

    Whoops, guys. Sorry Jim. I sent you a new script file anyways that is a bit cleaner. Check your email.
  • Here's the changed bit of code I sent Jim this morning. He substituted it for his and says it works fine with no changes. 

    Sub Main()

'This *.bas is a simple, modified version of Craigs modified outtol.bas (whose original author nobody seems To know).
'Jan.
'Modified 9/23/09 DGG to include feature ID in the outtol comment. 
'Works with anything up to 2 features, including reference features. 
'TP callouts using more than 2 features will not show reference datums
'beyond the first one. 


Dim objApp As Object
Set objApp = CreateObject("PCDLRN.Application")
Dim objPart As Object
Set objPart = objApp.ActivePartProgram
Dim objCmds
Set objCmds = objPart.Commands
Dim objCmd
Dim objDimCmd As Object
Dim dblOutTol As Long
dblOutTol = 0
Dim dblTotalMeas As Long
dblTotalMeas = 0





Dim prevIDName As String
Dim count1
Dim count2
Dim prevcount1
Dim prevcount2
Dim prevID2Name As String
Dim objCmdDeviation As Double
Dim objCmdOuttol As Double
Dim ID 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
        ID = DimensionName.feat1          'capture the ID Name of the command that is being looked at.
        count1 = cnt
        If ID = "" Then            'Make sure that commands always have a Name.
             ID = prevIDName
             count1 = prevcount1
        End If
        prevIDName = ID       '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
           ID = ID & "-" & 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 & ID & Chr(10)
            End If 'objDimCmd.OutTol<>0
        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 & ID & Chr(10)
                End If 'objCmd.gettext(LINE1_OUTTOL,1)<>0
            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 & ID & Chr(10)
                End If 'objCmd.gettext(LINE1_OUTTOL,1)<>0
            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 & ID & Chr(10)
                End If 'objCmd.gettext(LINE3_OUTTOL,1)<>0
            End If 'objCmd.gettext(LINE3_OUTTOL,1)<>""


        End If 'objCmd.Type=184

     End If    'objcmd.marked = True        'End marked search here
  

Next cnt

If dblOutTol = 0 Then
   MsgBox "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
End If


End Sub
  • Taken from N3WPV's thread, all I did was add more credit and revision history: 
    Sub Main()

'This *.bas is a simple, modified version of CraigerNY's modified outtol.bas (whose original author nobody seems To know).
' Contributors: CraigerNY, Jan D., Chally72, N3WPV, VPT.SE
'
'Modified 9/23/09 DGG To include feature ID In the outtol comment. 
'  Works With anything up To 2 features, including reference features. 
'  TP callouts using more than 2 features will Not show reference datums beyond the first one. 
'
'Modified to include Xactmeasure dimensions
'Modified to pass # of out-of-tol dims to PCDMIS to fill in required variable NUMBEROUTTOL


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
Dim objOutTol As Object
Set objOutTol = objPart.GetVariableValue("NUMBEROUTTOL")               'number of outtols found


Dim prevIDName As String
Dim count1
Dim count2
Dim prevcount1
Dim prevcount2
Dim prevID2Name As String
Dim objCmdDeviation As Double
Dim objCmdOuttol As Double
Dim ID 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
        ID = DimensionName.feat1          'capture the ID Name of the command that is being looked at.
        count1 = cnt
        If ID = "" Then            'Make sure that commands always have a Name.
             ID = prevIDName
             count1 = prevcount1
        End If
        prevIDName = ID       '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
           ID = ID & "-" & 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 & ID & Chr(10)
            End If 'objDimCmd.OutTol<>0
        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.

            ID = objCmd.ID

            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 & ID & Chr(10)
                End If 'objCmd.gettext(LINE1_OUTTOL,1)<>0
            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 & ID & Chr(10)
                End If 'objCmd.gettext(LINE1_OUTTOL,1)<>0
            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 & ID & Chr(10)
                End If 'objCmd.gettext(LINE3_OUTTOL,1)<>0
            End If 'objCmd.gettext(LINE3_OUTTOL,1)<>""

        End If 'objCmd.Type=184

     End If    'objcmd.marked = True        'End marked search here
  

Next cnt


If dblOutTol = 0 Then
   MsgBox "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
End If


Set objOutTol.DoubleValue=dblOutTol
objPart.SetVariableValue "NUMBEROUTTOL",objOutTol 



End Sub
  • Josh, You have just made me a happy man!
    Your code works perfectly for me.

    One wish is still open for me.
    How do I get the content of Msg to my program?

    I have no problem with the NUMEROUTTOL, but how do I "tell" the script to transfer the Msg variable?


    Regards
  • Hello,
    I am trying execute script, script should work if type output of dimension are "BOTH" or "REPORT".

    This don't work:
    If ReportDim = "BOTH" Or ReportDim = "REPORT" Then

    This also don't work:
    [CheckDim = Cmd.GetText (3 , OUTPUT_TYPE, 0)
    If CheckDim <> "" Then
    ReportDim = CheckDim
    End If
    If ReportDim = "BOTH" Or ReportDim = "REPORT" Then]

    As per picture, Dim.No.122 and Dim.No.126 should be shoved and Dim.No.126 should be shoved only once.

    How I should proper add conditions of "BOTH" and "REPORT" ?

    Regards
    Attached Files
  • Unfortunately the structure of this quite old script doesn't lend itself to that modification. Many legacy dimensions have a structure containing multiple commands (DIMENSION_START, axis1, axis2, … , axisN, DIMENSION_END), and the OutputMode flag (and dimension ID) is only available on the DIMENSION_START command, so the obvious mod, 

    
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

[COLOR=#FF0000]       Set objDimCmd = objCmd.DimensionCommand
        If (objDimCmd.OutputMode = DIMOUTPUT_NONE) Or (objDimCmd.OutputMode = DIMOUTPUT_STATS) Then
          GoTo NextCommand
        End If[/COLOR]

       <the rest of the code>

[COLOR=#FF0000]NextCommand:[/COLOR]
Next cnt


    doesn't work. The script would have to be rewritten to detect the DIMENSION_START, save the OutputMode, and be in state "in a multi line dimension" until DIMENSION_END. I don't have the time for that, but maybe someone else feel adventurous...
  • in reply to AndersI
    Andersl,

    Thanks for bit of info. I have script which exporting data to excel and I'm thinking that structure should be similar. That script depends on type of commands, if yes then I should use :
    If Cmd.Type <> 1299 then
    If Cmd.Type = 1118 then
    if Cmd.Type = 1105 then
    If Cmd.Type = 184 then

    Next step:

    If Cmd.IsDimension Then
    If Cmd.Type = DIMENSION_START_LOCATION Or/and Cmd.Type = DIMENSION_TRUE_START_POSITION Then

    If Cmd.Type <> DIMENSION_START_LOCATION And Cmd.Type <> DIMENSION_END_LOCATION And _
    Cmd.Type <> DIMENSION_TRUE_START_POSITION And Cmd.Type <> DIMENSION_TRUE_END_POSITION Then


    If I do understand well COMMQAND.Type should ensure that script will not miss any type of countable dimension and DIMENSION_START/DIMENSION_END will describe where script should look for "OUT OF TOLERANCE". Am I right?
  • Pseudocode (may contain traces of error…) 

    
If the command is DIMENSION_START then
        extract OutputMode and ID, nothing else.
        set boolean flag InStructuredDimension=True

else if the command is DIMENSION_END then
        set OutputMode to none and ID to "".
        set boolean flag InStructuredDimension=False

else if the command is some other dimensioncommand
        if InStructuredDimensione==True then
              extract everything except OutputMode and ID from the command
        else
              extract everything from the command
        endif
        produce your output
else
        if InStructuredDimension==True then
                structure error (dimension_end missing??)
                set OutputMode to none and ID to "".
                set boolean flag InStructuredDimension=False
        endif
endif
© 2024 Hexagon AB and/or its subsidiaries. Privacy Policy | Cloud Services Agreement