Le portail francophone de la géomatique

Option Explicit
Private mLeft As Double
Private mRight As Double
Private mBottom As Double
Private mTop As Double
Private mColor As Long

Public Property Get Color() As Long

    Color = mColor

End Property

Public Property Let Color(ByVal Color As Long)

    mColor = Color

End Property




Public Property Get Left() As Double

    Left = mLeft

End Property

Public Property Let Left(ByVal Left As Double)

mLeft = Left


End Property

Public Property Get Right() As Double


Right = mRight

    

End Property

Public Property Let Right(ByVal Right As Double)

mRight = Right

    

End Property

Public Property Get Bottom() As Double

    Bottom = mBottom

End Property

Public Property Let Bottom(ByVal Bottom As Double)

mBottom = Bottom


End Property

Public Property Get Top() As Double

    Top = mTop

End Property

Public Property Let Top(ByVal Top As Double)

mTop = Top


End Property
Public Function PinRegion(p As Classpoint) As Boolean

If p.x < mLeft Then
PinRegion = False
Exit Function
Else
    If p.x > mRight Then
    PinRegion = False
    Exit Function
    Else
        If p.y < mBottom Then
        PinRegion = False
        Exit Function
        Else
            If p.y > mTop Then
            PinRegion = False
            Exit Function
            Else
            
            PinRegion = True

            End If
        End If
 End If

End If
End Function
Public Function VertexInRegion(p As Vertex) As Boolean

If p.x < mLeft Then
VertexInRegion = False
Exit Function
Else
    If p.x > mRight Then
    VertexInRegion = False
    Exit Function
    Else
        If p.y < mBottom Then
        VertexInRegion = False
        Exit Function
        Else
            If p.y > mTop Then
            VertexInRegion = False
            Exit Function
            Else
            
            VertexInRegion = True

            End If
        End If
 End If

End If
End Function
Public Function rotate(x As Double, y As Double, deltagis As Double)
Dim p(3) As Classpoint
Dim i&
Dim Xmax As Double
Dim Xmin As Double
Dim Ymax As Double
Dim Ymin As Double

For i& = 0 To 3
Set p(i&) = New Classpoint
    Select Case i&
        Case 0
        p(i&).x = mLeft
        p(i&).y = mBottom
        Case 1
        p(i&).x = mLeft
        p(i&).y = mTop
        Case 2
        p(i&).x = mRight
        p(i&).y = mTop
        Case 3
        p(i&).x = mRight
        p(i&).y = mBottom
    End Select
p(i&).rotate x, y, deltagis

Next i&

Xmin = p(0).x
Ymin = p(0).y
Xmax = p(2).x
Ymax = p(2).y

For i& = 0 To 3

    If p(i&).x < Xmin Then
    Xmin = p(i&).x
    End If
    If p(i&).y < Ymin Then
    Ymin = p(i&).y
    End If
    
    If p(i&).x > Xmax Then
    Xmax = p(i&).x
    End If
    If p(i&).y > Ymax Then
    Ymax = p(i&).y
    End If
    
Next i&

mBottom = Ymin
mTop = Ymax
mLeft = Xmin
mRight = Xmax

End Function

Public Function Intersection(r As RealRegion) As RealRegion
Dim Inter As RealRegion
Dim T As Double


Set Inter = New RealRegion



If mLeft < r.Left Then
    If mRight < r.Left Then

        Inter.Bottom = 0
        Inter.Left = 0
        Inter.Right = 0
        Inter.Top = 0
        Set Intersection = Inter
        Set Inter = Nothing
        Exit Function
    Else
        If mRight > r.Right Then
            Inter.Left = r.Left
            Inter.Right = r.Right
        Else
            Inter.Left = r.Left
            Inter.Right = mRight
        End If
    End If
Else

    If mLeft > r.Right Then
        Inter.Bottom = 0
        Inter.Left = 0
        Inter.Right = 0
        Inter.Top = 0
        Set Intersection = Inter
        Set Inter = Nothing
        Exit Function
    Else
        If mRight > r.Right Then
            Inter.Left = mLeft
            Inter.Right = r.Right
        Else
            Inter.Left = mLeft
            Inter.Right = mRight
        End If
    End If
End If

If mBottom < r.Bottom Then
    If mTop < r.Bottom Then
        
        Inter.Bottom = 0
        Inter.Left = 0
        Inter.Right = 0
        Inter.Top = 0
        Set Intersection = Inter
        Set Inter = Nothing
        Exit Function
    Else
        If mTop > r.Top Then
            Inter.Bottom = r.Bottom
            Inter.Top = r.Top
        Else
            Inter.Bottom = r.Bottom
            Inter.Top = mTop
        End If
    End If
Else

    If mBottom > r.Top Then
        Inter.Bottom = 0
        Inter.Left = 0
        Inter.Right = 0
        Inter.Top = 0
        Set Intersection = Inter
        Set Inter = Nothing
        Exit Function
    Else
        If mTop > r.Top Then
            Inter.Bottom = mBottom
            Inter.Top = r.Top
        Else
            Inter.Bottom = mBottom
            Inter.Top = mTop
        End If
    End If
End If
Set Intersection = Inter
Set Inter = Nothing
End Function

Public Function clone(r As RealRegion)

r.Bottom = mBottom
r.Left = mLeft
r.Right = mRight
r.Top = mTop

End Function

Public Function EstVide() As Boolean
If mBottom = mTop And mRight = mLeft Then
EstVide = True
Else
EstVide = False
End If

End Function

Public Sub ordonne()
Dim x1 As Double


If mBottom > mTop Then
x1 = mTop
mTop = mBottom
mBottom = x1
End If

If mLeft > mRight Then
x1 = mRight
mRight = mLeft
mLeft = x1
End If

End Sub

Public Function Union(r As RealRegion) As RealRegion
Dim un As RealRegion

Set un = New RealRegion


If mBottom = mTop And mLeft = mRight Then

Set Union = r

Set un = Nothing
Exit Function
End If

If r.Left < mLeft Then
un.Left = r.Left
Else
un.Left = mLeft
End If


If r.Right > mRight Then
un.Right = r.Right
Else
un.Right = mRight
End If



If r.Bottom < mBottom Then
un.Bottom = r.Bottom
Else
un.Bottom = mBottom
End If

If r.Top > mTop Then
un.Top = r.Top
Else
un.Top = mTop
End If

Set Union = un

Set un = Nothing
End Function

Public Function Egale(r As RealRegion) As Boolean
If r.Bottom = mBottom And r.Top = mTop And r.Left = mLeft And r.Right = mRight Then
Egale = True
Else
Egale = False
End If

End Function

Public Function EnvironEgale(r As RealRegion, precision As Integer) As Boolean
Dim i&

i& = 0

If r.Bottom - mBottom < 10 ^ -precision Then
i& = i& + 1
End If

If r.Top - mTop < 10 ^ -precision Then
i& = i& + 1
End If

If r.Left - mLeft < 10 ^ -precision Then
i& = i& + 1
End If

If r.Right - mRight < 10 ^ -precision Then
i& = i& + 1
End If

If i& >= 3 Then
EnvironEgale = True
Else
EnvironEgale = False
End If

End Function
Public Function Milieu() As Classpoint
Dim p As Classpoint
Set p = New Classpoint

p.x = (mRight - mLeft) / 2 + mLeft
p.y = (mTop - mBottom) / 2 + mBottom

Set Milieu = p
Set p = Nothing

End Function

Public Function largeur() As Double
largeur = mRight - mLeft
End Function
Public Function hauteur() As Double
hauteur = mTop - mBottom
End Function
Public Sub Dessine(mdc As metricDC)
mdc.CadreReal mLeft, mBottom, mRight, mTop, RGB(0, 0, 255)
End Sub