VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CPoint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Implements IShape

Private Xcoord As Double
Private Ycoord As Double
Private NullShape As Boolean

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'PUBLIC PROPERTIES
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

'*****************************************************************************************
'X
'returns the x value of the point
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get X() As Double
    X = Xcoord
End Property

'*****************************************************************************************
'X
'sets the x value of the point
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Let X(ByVal XValue As Double)
    Xcoord = XValue
End Property

'*****************************************************************************************
'Y
'gets the Y value of the point
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get Y() As Double
    Y = Ycoord
End Property

'*****************************************************************************************
'Y
'sets the y value of the point
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Let Y(ByVal YValue As Double)
    Ycoord = YValue
End Property

'=========================================================================================
'PUBLIC FUNCTIONS
'=========================================================================================

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'PUBLIC SUBS
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'FRIEND FUNCTIONS AND METHODS AND PROPERTIEs BELOW HERE
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'FRIEND PROPERTIES
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

'*****************************************************************************************
'SetNull
'set the shape to null
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Friend Property Let SetNull(aNull As Boolean)
    NullShape = aNull
End Property

'=========================================================================================
'FRIEND FUNCTIONS
'=========================================================================================

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'FRIEND SUBS
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'PRIVATE FUNCTIONS AND METHODS AND PROPERTIES BELOW HERE
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'Private PROPERTIES
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

'*****************************************************************************************
'IShape_Bottom
'implements IShape Bottom
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Property Get IShape_Bottom() As Double
    IShape_Bottom = Ycoord
End Property

'*****************************************************************************************
'IShape_IsNull
'implements IShape IsNull
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Property Get IShape_IsNull() As Boolean
    IShape_IsNull = NullShape
End Property

'*****************************************************************************************
'IShape_Left
'implements IShape Left
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Property Get IShape_Left() As Double
    IShape_Left = Xcoord
End Property

'*****************************************************************************************
'IShape_MakeNull
'implements IShape MakeNull
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Property Let IShape_MakeNull(RHS As Boolean)
    NullShape = RHS
End Property

'*****************************************************************************************
'IShape_Right
'Implements IShape Right
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Property Get IShape_Right() As Double
    IShape_Right = Xcoord
End Property

'*****************************************************************************************
'IShape_Top
'implements IShape Top
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Property Get IShape_Top() As Double
    IShape_Top = Ycoord
End Property


'=========================================================================================
'PRIVATE FUNCTIONS
'=========================================================================================

'*****************************************************************************************
'IShape_Distance
'implements IShape Distance
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function IShape_Distance(aShape As Object) As Double

    Dim s As IShape
    
    On Error GoTo ERROR_ROUTINE
    Set s = aShape
    If ((s.IsNull) Or (NullShape = True)) Then
        Err.Raise ERRORCODES.NullShape, "CPoint::IShape_Distance", _
            "Cannot compute distance to a null shape"
    End If
    
    Select Case TypeName(aShape)
        Case "CPoint"
            IShape_Distance = DistanceToPoint(aShape)
        Case "CPolyLine"
            IShape_Distance = DistanceToPolyLine(aShape)
        Case "CPolygon"
            IShape_Distance = DistanceToPolygon(aShape)
    End Select
    Exit Function
ERROR_ROUTINE:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

'*****************************************************************************************
'DistanceToPoint
'returns the distance to a CPoint
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function DistanceToPoint(aPoint As CPoint) As Double
    On Error GoTo ERROR_ROUTINE
    If ((Xcoord = aPoint.X) And (Ycoord = aPoint.Y)) Then
        DistanceToPoint = 0
    Else
        DistanceToPoint = Sqr((Xcoord - aPoint.X) ^ 2 + (Ycoord - aPoint.Y) ^ 2)
    End If
    Exit Function
ERROR_ROUTINE:
    Err.Source = "CPoint::DistanceToPoint"
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

'*****************************************************************************************
'DistanceToPolyLine
'returns the distance to a CPolyLine
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function DistanceToPolyLine(aPolyLine As CPolyLine) As Double
    
    Dim PartPointArray() As Long
    Dim partcount As Long
    Dim pointcount As Long
    Dim part As CPart
    Dim pnt As CPoint
    Dim pnt1 As CPoint
    Dim pnt2 As CPoint
    Dim pnt3 As CPoint
    Dim i As Long
    Dim min As Double
    Dim mintemp As Double
    Dim scalarproj As Double
    Dim x1 As Double
    Dim x2 As Double
    Dim x3 As Double
    Dim y1 As Double
    Dim y2 As Double
    Dim y3 As Double
    Dim twoSegments As Boolean
    Dim firstmin As Boolean
    Dim magnitude As Double
    
    ReDim PartPointArray(1 To aPolyLine.Count)
    
    firstmin = False
    partcount = 0
    For Each part In aPolyLine ' find the closest point in each part
        partcount = partcount + 1
        pointcount = 0
        For Each pnt In part
            pointcount = pointcount + 1
            If (pointcount = 1) Then
                If (firstmin = False) Then
                    min = Sqr((Xcoord - pnt.X) ^ 2 + (Ycoord - pnt.Y) ^ 2)
                    PartPointArray(partcount) = pointcount
                    firstmin = True
                Else
                    mintemp = Sqr((Xcoord - pnt.X) ^ 2 + (Ycoord - pnt.Y) ^ 2)
                    PartPointArray(partcount) = pointcount
                    If (mintemp < min) Then
                        min = mintemp
                    End If
                End If
            Else
                mintemp = Sqr((Xcoord - pnt.X) ^ 2 + (Ycoord - pnt.Y) ^ 2)
                If (mintemp < min) Then
                    min = mintemp
                    PartPointArray(partcount) = pointcount
                End If
            End If
        Next
    Next
    
    For i = 1 To aPolyLine.Count
        Set part = aPolyLine.Item(i)
        pointcount = part.Count
        Select Case PartPointArray(i)
            Case 1
                Set pnt1 = part.Item(1)
                Set pnt2 = part.Item(2)
                twoSegments = False
            Case pointcount
                Set pnt1 = part.Item(partcount)
                Set pnt2 = part.Item(partcount - 1)
                twoSegments = False
            Case Else
                Set pnt1 = part.Item(PartPointArray(i))
                Set pnt2 = part.Item(PartPointArray(i) - 1)
                Set pnt3 = part.Item(PartPointArray(i) + 1)
                twoSegments = True
        End Select
        
        x1 = pnt2.X - pnt1.X 'P->Q = J
        y1 = pnt2.Y - pnt1.Y
        x2 = Xcoord - pnt1.X 'P->A = K
        y2 = Ycoord - pnt1.Y
        magnitude = Sqr(x1 ^ 2 + y1 ^ 2)
        scalarproj = (x1 * x2 + y1 * y2) / magnitude
        If (scalarproj > 0) Then
            x3 = scalarproj * 1 / magnitude * x1
            y3 = scalarproj * 1 / magnitude * y1
            If (Sqr(x3 ^ 2 + y3 ^ 2) < magnitude) Then
                mintemp = Sqr((x2 - x3) ^ 2 + (y2 - y3) ^ 2)
                If (mintemp < min) Then
                    min = mintemp
                End If
            End If
        End If
        If (twoSegments = True) Then
            'check the second line segment
            x1 = pnt3.X - pnt1.X 'P->Q = J
            y1 = pnt3.Y - pnt1.Y
            x2 = Xcoord - pnt1.X 'P->A = K
            y2 = Ycoord - pnt1.Y
            magnitude = Sqr(x1 ^ 2 + y1 ^ 2)
            scalarproj = (x1 * x2 + y1 * y2) / magnitude
            If (scalarproj > 0) Then
                x3 = scalarproj * 1 / magnitude * x1
                y3 = scalarproj * 1 / magnitude * y1
                If (Sqr(x3 ^ 2 + y3 ^ 2) < magnitude) Then
                    mintemp = Sqr((x2 - x3) ^ 2 + (y2 - y3) ^ 2)
                    If (mintemp < min) Then
                        min = mintemp
                    End If
                End If
            End If
        End If
    Next
    DistanceToPolyLine = min
    
End Function

'*****************************************************************************************
'DistanceToPolygon
'Returns the distance to a CPolygon
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function DistanceToPolygon(aPolygon As CPolygon) As Double
    Dim PartPointArray() As Long
    Dim partcount As Long
    Dim pointcount As Long
    Dim part As CPart
    Dim pnt As CPoint
    Dim pnt1 As CPoint
    Dim pnt2 As CPoint
    Dim pnt3 As CPoint
    Dim i As Long
    Dim min As Double
    Dim mintemp As Double
    Dim scalarproj As Double
    Dim x1 As Double
    Dim x2 As Double
    Dim x3 As Double
    Dim y1 As Double
    Dim y2 As Double
    Dim y3 As Double
    Dim firstmin As Boolean
    Dim magnitude As Double
    
    ReDim PartPointArray(1 To aPolygon.Count)
    
    firstmin = False
    partcount = 0
    For Each part In aPolygon ' find the closest point in each part
        partcount = partcount + 1
        pointcount = 0
        For Each pnt In part
            pointcount = pointcount + 1
            If (pointcount = 1) Then
                If (firstmin = False) Then
                    min = Sqr((Xcoord - pnt.X) ^ 2 + (Ycoord - pnt.Y) ^ 2)
                    PartPointArray(partcount) = pointcount
                    firstmin = True
                Else
                    mintemp = Sqr((Xcoord - pnt.X) ^ 2 + (Ycoord - pnt.Y) ^ 2)
                    PartPointArray(partcount) = pointcount
                    If (mintemp < min) Then
                        min = mintemp
                    End If
                End If
            Else
                mintemp = Sqr((Xcoord - pnt.X) ^ 2 + (Ycoord - pnt.Y) ^ 2)
                If (mintemp < min) Then
                    min = mintemp
                    PartPointArray(partcount) = pointcount
                End If
            End If
        Next
    Next
    
    For i = 1 To aPolygon.Count
        Set part = aPolygon.Item(i)
        pointcount = part.Count
        Select Case PartPointArray(i)
            Case 1
                Set pnt1 = part.Item(1)
                Set pnt2 = part.Item(2)
                Set pnt3 = part.Item(partcount - 1)
            Case pointcount
                Set pnt1 = part.Item(partcount)
                Set pnt2 = part.Item(partcount - 1)
                Set pnt3 = part.Item(2)
            Case Else
                Set pnt1 = part.Item(PartPointArray(i))
                Set pnt2 = part.Item(PartPointArray(i) - 1)
                Set pnt3 = part.Item(PartPointArray(i) + 1)
        End Select
        
        'check the first line segment
        x1 = pnt2.X - pnt1.X 'P->Q = J
        y1 = pnt2.Y - pnt1.Y
        x2 = Xcoord - pnt1.X 'P->A = K
        y2 = Ycoord - pnt1.Y
        magnitude = Sqr(x1 ^ 2 + y1 ^ 2)
        scalarproj = (x1 * x2 + y1 * y2) / magnitude
        If (scalarproj > 0) Then
            x3 = scalarproj * 1 / magnitude * x1
            y3 = scalarproj * 1 / magnitude * y1
            If (Sqr(x3 ^ 2 + y3 ^ 2) < magnitude) Then
                mintemp = Sqr((x2 - x3) ^ 2 + (y2 - y3) ^ 2)
                If (mintemp < min) Then
                    min = mintemp
                End If
            End If
        End If

        'check the second line segment
        x1 = pnt3.X - pnt1.X 'P->Q = J
        y1 = pnt3.Y - pnt1.Y
        x2 = Xcoord - pnt1.X 'P->A = K
        y2 = Ycoord - pnt1.Y
        magnitude = Sqr(x1 ^ 2 + y1 ^ 2)
        scalarproj = (x1 * x2 + y1 * y2) / magnitude
        If (scalarproj > 0) Then
            x3 = scalarproj * 1 / magnitude * x1
            y3 = scalarproj * 1 / magnitude * y1
            If (Sqr(x3 ^ 2 + y3 ^ 2) < magnitude) Then
                mintemp = Sqr((x2 - x3) ^ 2 + (y2 - y3) ^ 2)
                If (mintemp < min) Then
                    min = mintemp
                End If
            End If
        End If
    Next
    DistanceToPolygon = min
End Function


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'PRIVATE SUBS
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'*****************************************************************************************
'Class_Initialize
'
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub Class_Initialize()
    NullShape = False
End Sub