'*************************************************************************
'                      PolarExtremums - XY plane only
'
'   Finds the tooth tip points And places them As points In a given scan 
'
'   ARG1 = nam(s) of the source scans - it(they) would ideally describe the 
'          complete circle. It is however working also On segments, but you 
'          may need To eventually discard the 1st And last point
'   ARG2 = Name of the scan where the points will be loaded (typically a scan
'          that is never measured (skipped With GoTo For example) And that
'          is used As container For the End data
'   ARG3 = number of teeth On 360 deg!                             
'
' 29.01.2015  Creation date                                        A.Mavrov
' 28.09.2017  Modified due To GetHit Not workimg stable On W8-W10  A.Mavrov
'
'
'*************************************************************************


Option Explicit

Dim App As Object
Dim Part As Object
Dim Cmds As Object
Dim Cmd As Object
Dim Fcmd As Object
Dim Mypoint As Object
Type Pts
   X As Double
   Y As Double
   Z As Double
   PA As Double
   PR As Double
End Type
Dim TotalPts As Integer  
Dim MyPts(50000) As Pts
Dim ExtrPtsN(10000) As Integer 
Dim ExtractedPts As Integer
Dim PointsOffs As Integer 
Const PI = 3.1415926536
Dim PrbDiam As Double
Dim sSelSCA(100) As String
Dim iSelSCA As Integer


Function InitPCD() As Boolean
    InitPCD = True
    Set App = CreateObject("PCDLRN.Application")
    If App Is Nothing Then
        MsgBox "PC-DMIS initialisation error!",48, "Error!"
        InitPCD = False
    Else
        Set Part = App.ActivePartProgram
        If Part Is Nothing Then
            MsgBox "Part Program not opened!", 48, "Error!"
            InitPCD = False
        Else
            Set Cmds = Part.Commands
            If Cmds Is Nothing Then
                MsgBox "Pointer to commands not valid!", 48, "Error!"
                InitPCD = False
            End If
        End If
    End If
End Function



Sub LoadScan()
    Dim index, myindex, tot_com, pos As Integer
    Dim ustr As String
    Dim XM As Double, YM As Double, ZM As Double, XN As Double, YN As Double, ZN As Double, T As Double
    Dim VI As Double, VJ As Double, VK As Double
    Dim StringOut As String
    Dim j As Integer 
    Dim X1 As Double, Y1 As Double, Z1 As Double  	
    TotalPts=0
    tot_com=Cmds.Count  
    For j=1 To iSelSCA
          index=1
          For index=1 To tot_com 
             Set Cmd = Cmds.Item(index)
             If Cmd.IsFeature Then
                 If Len(Cmd.ID) > 0 Then
                     ' all this stuff With [ is needed For making this script work inside the loops... 
                     ustr = Cmd.ID
                     pos=InStr(1,ustr,"[",1)             
                     If pos <> 0 Then
                         ustr = Left(ustr, pos-1)      
                     End If
                     If ustr = sSelSca(j) Then
                       myindex=index
                       Exit For
                    End If
                 End If
               End If
            Next index
            
            Set Cmd = Cmds.Item(myindex)
            Dim RadCorType As String
            If left(Cmd.Gettext(228,0),1)="N" Then        
                    Dim TipName As String, CfgName As String
                    Do
                        Cmd.Prev
                        If Cmd.Type=60 Then ' tip
                             TipName=Cmd.GetText(REF_ID,0)
                        End If
                        If Cmd.Type=61 Then ' conf
                            CfgName=Cmd.GetText(FILE_Name,0)
                            Exit Do
                        End If
                    Loop        
                    PrbDiam=Part.Probes.Item(Cfgname).Tips.Item(TipName).diam          
            Else
                   PrbDiam=0
            End If

           Set Cmd = Cmds.Item(myindex)

            If Cmd Is Nothing Then
                MsgBox "Feature not existing!", 48, "Error in Feature Name!"
                Exit Sub
            End If


            
            Set Fcmd = Cmd.FeatureCommand
            '214 corresponds To Type Basic Scan
            If  Cmd.Type <> 214 Then
                Cmd.Next
            End If
            Dim Offset As Integer
            Offset=totalPts
            totalPts = totalPts+Fcmd.NumHits

   
            For index = 1 To totalPts
                    'Set Mypoint = Fcmd.GetHit(index, FHITDATA_CENTROID, FDATA_MEAS, FDATA_PART, "", PLANE_TOP)
                    'X1=MyPoint.X                    
                    'Y1=MyPoint.Y                    
                    'Z1=MyPoint.Z                    

                    X1=Cdbl(cmd.GetText(MEAS_X,index)) + (PrbDiam*0.5)*Cdbl(cmd.GetText(THEO_I,index)) 
                    Y1=Cdbl(cmd.GetText(MEAS_Y,index)) + (PrbDiam*0.5)*Cdbl(cmd.GetText(THEO_J,index))
                    Z1=Cdbl(cmd.GetText(MEAS_Z,index)) + (PrbDiam*0.5)*Cdbl(cmd.GetText(THEO_K,index))
                    MyPts(index+Offset).X=X1
                    MyPts(index+Offset).Y=Y1
                    MyPts(index+Offset).Z=Z1
                    MyPts(index+Offset).PR=sqr(X1^2+Y1^2)
                    MyPts(index+Offset).PA=CalcAngle(X1,Y1)
            Next index


    Next j
End Sub

Sub FindExtr (Z As Integer)
  Dim i As Integer, MaxR As Double, MinR As Double, MaxRAng As Double, MinRAng As Double  
  MaxR=myPts(1).PR
  MinR=myPts(1).PR
  For i=1 To TotalPts
    If myPts(i).PR> MaxR Then 
      MaxR=myPts(i).PR
      MaxRAng=myPts(i).PA
    End If
    If myPts(i).PR< MinR Then 
      MinR=myPts(i).PR 
      MinRAng=myPts(i).PA
    End If
  Next i

  ' Max
  Dim SearchAng As Double, j As Integer, SegmentAng As Double
  Dim SA1 As Double , EA1 As Double, SA2 As Double, EA2 As Double, Cont As Integer 
  SegmentAng=(360/Z)/2
  SearchAng=MaxRAng
  Cont=0
  For i=1 To Z
      SA2=0: EA2=0
      SA1=SearchAng-SegmentAng
      EA1=SearchAng+SegmentAng
      If SA1<0 Then SA1 = 360+SA1 :SA2=0: EA2=EA1 : EA1=360
      If EA1>360 Then EA2 = EA1-360: SA2=0 : EA1=360
      MaxR=0
      For j=1 To TotalPts
        If (myPts(j).PA>SA1 And myPts(j).PA<EA1) Or (myPts(j).PA>SA2 And myPts(j).PA<EA2) Then
            If MaxR=0 Then Cont=Cont+1
            If myPts(j).PR>MaxR Then
               MaxR=myPts(j).PR
               ExtrPtsN(Cont)=j 
            End If
        End If
      Next j
  SearchAng=SearchAng+(360/Z)
  If SearchAng>360 Then SearchAng=SearchAng-360
  Next i

  ExtractedPts=Cont

End Sub



Sub FillScan (NAM As String)

    Dim Bscn As Object, i As Integer 
    Set Cmd = Cmds.Item(NAM)
    If Cmd Is Nothing Then MsgBox "Destination element " & NAM & " does not exists!": Exit Sub 
    Set Bscn = Cmd.BasicScanCommand
    Cmd.PutText 0, 262, 1000001
    Cmd.PutText 0, 263, 1000001
    Cmd.PutText 1, 264, 1000001
    Cmd.PutText MyPts(ExtrPtsN(2)).X, 10, 1000001
    Cmd.PutText MyPts(ExtrPtsN(2)).Y, 11, 1000001
    Cmd.PutText MyPts(ExtrPtsN(2)).Z, 12, 1000001
    Cmd.PutText 0, 268, 1000001
    Cmd.PutText 0, 269, 1000001
    Cmd.PutText 1, 270, 1000001
    Cmd.PutText MyPts(ExtrPtsN(ExtractedPts-1)).X, 13, 1000001
    Cmd.PutText MyPts(ExtrPtsN(ExtractedPts-1)).Y, 14, 1000001
    Cmd.PutText MyPts(ExtrPtsN(ExtractedPts-1)).Z, 15, 1000001
    Cmd.SetToggleString 2, 228, 1000001    

    Cmd.Marked = True
    Cmd.ReDraw

    Cmd.SetToggleString 2, 233, 1000006
    Cmd.PutText CStr(ExtractedPts), 70, 0
    For i = 1 To ExtractedPts

       'MsgBox MyPts(ExtrPtsN(i)).X & "/ " & MyPts(ExtrPtsN(i)).Y
        Cmd.FeatureCommand.SetHit i, FHITDATA_VECTOR, FDATA_THEO, 0, 0, 1
        Cmd.FeatureCommand.SetHit i, FHITDATA_CENTROID, FDATA_THEO, MyPts(ExtrPtsN(i)).X, MyPts(ExtrPtsN(i)).Y, MyPts(ExtrPtsN(i)).Z
        Cmd.FeatureCommand.SetHit i, FHITDATA_CENTROID, FDATA_MEAS, MyPts(ExtrPtsN(i)).X, MyPts(ExtrPtsN(i)).Y, MyPts(ExtrPtsN(i)).Z
    Next i



End Sub

Function SeparateScans (ByVal Stringa As String) As Integer
      Dim i As Integer, j As Integer
      Dim Stringa1 As String, Stringa2 As String

      If Instr(1,Stringa,",")<=0 Then 
           SeparateScans=1
      	   sSelSCA(1)=Stringa
           Exit Function
      End If
     
      For j = 1 To 100
        i=InStr(1, Stringa, ",")
        If i=0 Then
            If j=1 Then
               SeparateScans=0
               Exit For
            End If
            sSelSCA(j)=Stringa
            SeparateScans=j 
            Exit For
        End If
        Stringa1 = Left(Stringa, i - 1)
        Stringa2 = Right(Stringa, (Len(Stringa) - InStr(1, Stringa, ",")))
        Stringa = Stringa2
        sSelSCA(j) = Stringa1
      Next j
End Function


Sub Main (NAMSrc As String, NamDst As String, Z As Integer,PrbDia As Double)
    InitPCD
    iSelSCA=SeparateScans(NAMSrc)
    PrbDiam=PrbDia
    LoadScan 
    FindExtr Z  
    FillScan NamDst
      
End Sub


'----------------------
Public Function degrad(ByVal angle As Double) As Double
    degrad = angle * (3.1415926536 / 180)
End Function
Public Function raddeg(ByVal angle As Double) As Double
    raddeg = angle * (180 / 3.1415926536)
End Function
Public Function Radius(ByVal X As Double, ByVal Y As Double) As Double
    Radius = Sqr(X * X + Y * Y)
End Function
Public Function sinus(ByVal Value As Double) As Double
    sinus = Sin(degrad(Value))
End Function
Public Function cosinus(ByVal Value As Double) As Double
    cosinus = Cos(degrad(Value))
End Function
Public Function tangens(ByVal Value As Double) As Double
    tangens = Tan(degrad(Value))
End Function
Public Function cotangens(ByVal Value As Double) As Double
    cotangens = 1 / Tan(degrad(Value))
End Function
Public Function arctangens(ByVal Value As Double) As Double
    arctangens = raddeg(Atn(Value))
End Function
Public Function arcsinus(ByVal Value As Double) As Double
     Select Case Value
           Case 1
               arcsinus = 90
               Exit Function
           Case -1
               arcsinus = -90
               Exit Function
           Case Is < Abs(1)
               arcsinus = arctangens(Value / Sqr(1 - Value * Value))
               Exit Function
           Case Is > Abs(1)
               arcsinus = 0
       End Select
End Function
Public Function arccosinus(ByVal Value As Double) As Double
     Select Case Value
           Case 1
               arccosinus = 0
               Exit Function
           Case -1
               arccosinus = 180
               Exit Function
           Case Is < Abs(1)
               arccosinus = arcsinus(Sqr(1 - Value * Value))
               If Value < 0 Then arccosinus = 180 - arccosinus
               Exit Function
           Case Is > Abs(1)
               arccosinus = 0
       End Select
End Function

Public Sub Rot2D(ByVal X1 As Double, ByVal Y1 As Double, ByVal U1 As Double, ByVal V1 As Double, ByRef X2 As Double, ByRef Y2 As Double, ByRef U2 As Double, ByRef V2 As Double, ByVal transx As Double, ByVal transy As Double, ByVal Rot As Double)
    Dim rot1 As Double
    
    
    rot1 = -degrad(Rot)
    X2 = (X1 * Cos(rot1) + Y1 * Sin(rot1)) + (transx * Cos(rot1) + transy * Sin(rot1))
    Y2 = (Y1 * Cos(rot1) - X1 * Sin(rot1)) + (transy * Cos(rot1) - transx * Sin(rot1))
    U2 = U1 * Cos(rot1) + V1 * Sin(rot1)
    V2 = V1 * Cos(rot1) - U1 * Sin(rot1)
    Exit Sub
End Sub

Public Function CalcAngle(X As Double, Y As Double) As Double
    Dim Rad As Double
    Rad = Sqr(X * X + Y * Y)
    If Y = 0 And X > 0 Then
        CalcAngle = 0
        Exit Function
    End If
    If Y = 0 And X < 0 Then
        CalcAngle = 180
        Exit Function
    End If
    If X = 0 And Y = 0 Then
        CalcAngle = 0
        Exit Function
    End If
    CalcAngle = -(Sgn(Y) - 1) * 180 - arccosinus(X / Rad) * (-Sgn(Y))
End Function