VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsRect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function IntersectRect Lib "user32" (ByRef lpDestRect As RectAPI, ByRef lpSrc1Rect As RectAPI, ByRef lpSrc2Rect As RectAPI) As Long
Private Declare Function InflateRect Lib "user32" (ByRef lpRect As RectAPI, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (ByRef lpRect As RectAPI, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function PtInRect Lib "user32" (ByRef lpRect As RectAPI, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SubtractRect Lib "user32" (ByRef lprcDst As RectAPI, ByRef lprcSrc1 As RectAPI, ByRef lprcSrc2 As RectAPI) As Long
Private Declare Function UnionRect Lib "user32" (ByRef lpDestRect As RectAPI, ByRef lpSrc1Rect As RectAPI, ByRef lpSrc2Rect As RectAPI) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RectAPI, ByVal hBrush As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RectAPI) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RectAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, ByRef lpPoint As PointAPI) As Long
Private Declare Function ClipCursorAPI Lib "user32" Alias "ClipCursor" (ByRef lpRect As Any) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Public Enum enRectHAlign
    rhaLeft = &H0
    rhaCentre = &H1
    rhaRight = &H2
End Enum

Public Enum enRectVAlign
    rvaTop = &H0
    rvaCentre = &H1
    rvaBottom = &H2
End Enum

Public Enum enRectFitMethod
    rfmBestFit = &H0  ' Fits the entire rectangle
    rfmBestSize = &H1 ' Fills the rectangle
    rfmNoScaleDown = &H100
    rfmNoScaleUp = &H200
End Enum

Private Type PointAPI
    X As Long
    Y As Long
End Type

Private Type RectAPI
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private m_Left As Long
Private m_Top As Long
Private m_Right As Long
Private m_Bottom As Long

' Public interface to member varaibles
Public Property Get Left() As Long
    Left = m_Left
End Property
Public Property Let Left(ByVal inNew As Long)
    m_Left = inNew
End Property

Public Property Get Top() As Long
    Top = m_Top
End Property
Public Property Let Top(ByVal inNew As Long)
    m_Top = inNew
End Property

Public Property Get Right() As Long
    Right = m_Right
End Property
Public Property Let Right(ByVal inNew As Long)
    m_Right = inNew
End Property

Public Property Get Bottom() As Long
    Bottom = m_Bottom
End Property
Public Property Let Bottom(ByVal inNew As Long)
    m_Bottom = inNew
End Property

Public Property Get Width() As Long
    Width = m_Right - m_Left
End Property
Public Property Let Width(ByVal inNew As Long)
    m_Right = m_Left + inNew
End Property

Public Property Get Height() As Long
    Height = m_Bottom - m_Top
End Property
Public Property Let Height(ByVal inNew As Long)
    m_Bottom = m_Top + inNew
End Property

Public Property Get Ratio() As Double
    If (Me.Height) Then _
        Ratio = Abs(Me.Width / Me.Height) Else _
        Ratio = 0 ' Invalid size
End Property

' Public methods
Public Sub Create(ByVal inLeft As Long, ByVal inTop As Long, _
    ByVal inRight As Long, ByVal inBottom As Long)
    m_Left = inLeft
    m_Top = inTop
    m_Right = inRight
    m_Bottom = inBottom
End Sub

Public Sub Offset(ByVal inX As Long, ByVal inY As Long)
    m_Top = m_Top + inY
    m_Left = m_Left + inX
    m_Right = m_Right + inX
    m_Bottom = m_Bottom + inY
End Sub

Public Sub MoveToOrigin()
    Call Me.Offset(-m_Left, -m_Top)
End Sub

Public Function Clone() As clsRect
    Set Clone = New clsRect
    Call Clone.Create(m_Left, m_Top, m_Right, m_Bottom)
End Function

Public Function SameRect(ByRef inRect As clsRect) As Boolean
    SameRect = (inRect.Left = m_Left) And (inRect.Top = m_Top) And _
        (inRect.Right = m_Right) And (inRect.Bottom = m_Bottom)
End Function

Public Sub Normalise()
    Dim TempSwap As Long
    
    If (m_Right < m_Left) Then
        TempSwap = m_Right
        m_Right = m_Left
        m_Left = TempSwap
    End If
    
    If (m_Bottom < m_Top) Then
        TempSwap = m_Bottom
        m_Bottom = m_Top
        m_Top = TempSwap
    End If
End Sub

Public Function IsEmpty() As Boolean
    IsEmpty = (m_Left = m_Right) And (m_Top = m_Bottom)
End Function

Public Function IsNormalised() As Boolean
    IsNormalised = (m_Left < m_Right) And (m_Top < m_Bottom)
End Function

Public Function Intersect(ByRef inRect As clsRect) As clsRect
    Dim ResRect As RectAPI
    Call IntersectRect(ResRect, ToUDT(Me), ToUDT(inRect))
    Set Intersect = FromUDT(ResRect)
End Function

Public Function Subtract(ByRef inRect As clsRect) As clsRect
    Dim ResRect As RectAPI
    Call SubtractRect(ResRect, ToUDT(Me), ToUDT(inRect))
    Set Subtract = FromUDT(ResRect)
End Function

Public Function Union(ByRef inRect As clsRect) As clsRect
    Dim ResRect As RectAPI
    Call UnionRect(ResRect, ToUDT(Me), ToUDT(inRect))
    Set Union = FromUDT(ResRect)
End Function

Public Sub Inflate(ByVal inX As Long, ByVal inY As Long)
    Dim ResRect As RectAPI
    
    ResRect = ToUDT(Me)
    Call InflateRect(ResRect, inX, inY)
    
    m_Left = ResRect.Left
    m_Top = ResRect.Top
    m_Right = ResRect.Right
    m_Bottom = ResRect.Bottom
End Sub

Public Sub FromWindow(ByVal inWnd As Long, _
    Optional ByVal inClient As Boolean = False, _
    Optional ByVal inScreenCoordinates As Boolean = True)
    Dim WndRect As RectAPI
    Dim OffsetPt As PointAPI
    
    If (inClient) Then
        ' Get the window's client-area rectangle
        Call GetClientRect(inWnd, WndRect)
        
        ' Offset to screen coordinates
        If (inScreenCoordinates) Then
            OffsetPt = NewPoint(0, 0)
            Call ClientToScreen(inWnd, OffsetPt)
            Call OffsetRect(WndRect, OffsetPt.X, OffsetPt.Y)
        End If
    Else ' Get the window's window-area
        Call GetWindowRect(inWnd, WndRect)
        
        ' Offset from screen coordinates
        If (Not inScreenCoordinates) Then _
            Call OffsetRect(WndRect, -WndRect.Left, -WndRect.Top)
    End If
    
    Call Me.Create(WndRect.Left, WndRect.Top, WndRect.Right, WndRect.Bottom)
End Sub

Public Function ReScale(ByVal inScale As Double, _
    Optional ByVal inMaintainPosition As Boolean = False) As clsRect
    Set ReScale = New clsRect
    
    If (inMaintainPosition) Then
        Call ReScale.Create(0, 0, Me.Width * inScale, Me.Width * inScale)
        Call ReScale.Offset(m_Left, m_Top)
    Else
        Call ReScale.Create(m_Left * inScale, m_Top * inScale, m_Right * inScale, m_Bottom * inScale)
    End If
End Function

Public Function PointInRect(ByVal inX As Long, ByVal inY As Long) As Boolean
    PointInRect = PtInRect(ToUDT(Me), inX, inY) <> 0
End Function

Public Function ToString() As String
    ToString = "(" & m_Left & ", " & m_Top & ")-(" & m_Right & ", " & m_Bottom & ")"
End Function

Public Function Draw(ByVal inDC As Long) As Boolean
    Draw = Rectangle(inDC, m_Left, m_Top, m_Right, m_Bottom) <> 0
End Function

Public Function Fill(ByVal inDC As Long, ByVal inBrush As Long) As Boolean
    Fill = FillRect(inDC, ToUDT(Me), inBrush) <> 0
End Function

Public Sub FromUDTPtr(ByVal inPtr As Long)
    Dim TempRect As RectAPI
    
    Call RtlMoveMemory(TempRect, ByVal inPtr, Len(TempRect))
    
    With TempRect
        Call Me.Create(.Left, .Top, .Right, .Bottom)
    End With
End Sub

Public Sub ToUDTPtr(ByVal outPtr As Long)
    Dim TempRect As RectAPI
    
    TempRect = ToUDT(Me)
    Call RtlMoveMemory(ByVal outPtr, TempRect, Len(TempRect))
End Sub

Public Function FitRect(ByRef inRect As clsRect, _
    Optional ByVal inHAlign As enRectHAlign = rhaCentre, _
    Optional ByVal inVAlign As enRectVAlign = rvaCentre, _
    Optional ByVal inFitMode As enRectFitMethod = rfmBestFit) As clsRect
    Dim XRatio As Single, YRatio As Single
    Dim XOff As Long, YOff As Long
    
    If (inRect Is Nothing) Then Exit Function
    If (Not (Me.IsNormalised() And inRect.IsNormalised())) Then Exit Function
    
    XRatio = Me.Width / inRect.Width
    YRatio = Me.Height / inRect.Height
    
    If (inFitMode And (rfmNoScaleUp Or rfmNoScaleDown)) Then
        XRatio = 1
    Else
        Select Case (inFitMode And &HFF) ' Get picture ratio
            Case rfmBestFit:  If (YRatio < XRatio) Then XRatio = YRatio
            Case rfmBestSize: If (YRatio > XRatio) Then XRatio = YRatio
        End Select
        
        ' Apply any size clamps
        If ((inFitMode And rfmNoScaleDown) And (XRatio < 1)) Then XRatio = 1
        If ((inFitMode And rfmNoScaleUp) And (XRatio > 1)) Then XRatio = 1
    End If
    
    Set FitRect = New clsRect
    Set FitRect = inRect.ReScale(XRatio)
    Call FitRect.MoveToOrigin
    
    If ((inHAlign = rhaLeft) And (inVAlign = rvaTop)) Then
        If (Me.Left Or Me.Top) Then _
            Call FitRect.Offset(Me.Left, Me.Top)
    Else ' Work out any offsets within this rectangle
        Select Case inHAlign
            Case rhaLeft:   XOff = 0
            Case rhaCentre: XOff = (Me.Width - FitRect.Width) \ 2
            Case rhaRight:  XOff = (Me.Width - FitRect.Width)
        End Select
        
        Select Case inVAlign
            Case rvaTop:    YOff = 0
            Case rvaCentre: YOff = (Me.Height - FitRect.Height) \ 2
            Case rvaBottom: YOff = (Me.Height - FitRect.Height)
        End Select
        
        Call FitRect.Offset(XOff + Me.Left, YOff + Me.Top)
    End If
End Function

Public Function ClipCursor(Optional ByVal inRemoveClip As Boolean = False) As Boolean
    If (inRemoveClip) Then _
        ClipCursor = ClipCursorAPI(ByVal 0&) <> 0 Else _
        ClipCursor = ClipCursorAPI(ToUDT(Me)) <> 0
End Function

' Private methods
Private Function NewPoint(ByVal inX As Long, ByVal inY As Long) As PointAPI
    NewPoint.X = inX
    NewPoint.Y = inY
End Function

Private Function ToUDT(ByRef inRect As clsRect) As RectAPI
    With inRect
        ToUDT.Left = .Left
        ToUDT.Top = .Top
        ToUDT.Right = .Right
        ToUDT.Bottom = .Bottom
    End With
End Function

Private Function FromUDT(ByRef inUDT As RectAPI) As clsRect
    Set FromUDT = New clsRect
    
    With FromUDT
        .Left = inUDT.Left
        .Top = inUDT.Top
        .Right = inUDT.Right
        .Bottom = inUDT.Bottom
    End With
End Function