VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CShapeFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Class CShapeFile
'Author Kenneth R. McVay
'Date December 24, 1998
'
'This class is used to read and write ESRI Shape files.

'*****************************************************************************************
'enumeration FILESIZES
' used for easy access to the header file sizes
Private Enum FILESIZES
    MainHeaderSize = 100       'in bytes
    IndexRecSize = 8           ' in bytes
    shpRecSize = 8
End Enum
'*****************************************************************************************
'enum used to specify if opening a shapefile or creating a new shapefile
Public Enum OPENCREATE
    OPENIT = 0
    CREATEIT = 1
End Enum
'**********************************************************************************
'The available shape types. The 3D shapes are not yet supported
Public Enum SHAPEFILETYPE
typeNullShape = 0
    typePoint = 1
    typePolyLine = 3
    typePolygon = 5
    typeMultiPoint = 8
    typePointZ = 11
    typePolyLineZ = 13
    typePolygonZ = 15
    typeMultiPointZ = 18
    typePointM = 23
    typePolyLineM = 23
    typePolygonM = 25
    typeMultiPointM = 28
    typeMultiPatch = 31
End Enum


'*****************************************************************************************
'Main file header stucture for both the shape and index files
Private Type T_MainFileHeader
    FileCode As Long        'big
    u1 As Long              'big
    u2 As Long              'big
    u3 As Long              'big
    u4 As Long              'big
    u5 As Long              'big
    FileLength As Long      'big
    version As Long         'Little
    shapeType As Long       'Little
    BndBoxXmin As Double    'Little
    BndBoxYmin As Double    'Little
    BndBoxXmax As Double    'Little
    BndBoxYmax As Double    'Little
    BndBoxZmin As Double    'Little
    BndBoxZmax As Double    'Little
    BndboxMmin As Double    'Little
    BndBoxMmax As Double    'Little
End Type

'*****************************************************************************************
'Shape file record header structure
Private Type T_ShpRecordHeader
    RecordNumber As Long    'big
    ContentLength As Long   'big
End Type

'*****************************************************************************************
'index file record structure
Private Type T_ShxRecordHeader
    offset As Long              'big
    ContentLength As Long       'big
End Type
'**********************************************************************************
'main header data offsets used for easy access when writing some data
Private Enum HEADEROFFSETS
    FileCode = 1
    u1 = 5
    u2 = 9
    u3 = 13
    u4 = 17
    u5 = 21
    FileLength = 25
    version = 29
    ShpType = 33
    Xmin = 37
    Ymin = 45
    Xmax = 53
    Ymax = 61
    zmin = 69
    zmax = 77
    mmin = 85
    mmax = 93
End Enum

'*****************************************************************************************
' The following types are used with the Swap function for swapping the byte
'order of long integers
Private Type LongType
  l As Long
End Type

Private Type FourByteType
  b1 As Byte
  b2 As Byte
  b3 As Byte
  b4 As Byte
End Type

'*****************************************************************************************
'Variables that are public to the class
Private Const shpFileCode = 9994
Private shapeType As Long       'holds the shape type of the open shape file
Private CFileName As CFileName  'object to hold the file spec
Private ShpMainFileHeader As T_MainFileHeader   'to hold the main shapefile header
Private ShxMainFileHeader As T_MainFileHeader   'to hold the main index file header
Private ShpRecordHeader As T_ShpRecordHeader    'to hold the shape record header
Private ShxRecordHeader As T_ShxRecordHeader    'to hold the index record header
Private ShxFileHandle As Long
Private ShpFileHandle As Long
Private RecordCount As Long     'hold the number of records in the shape file
Private ShpIsOpen As Boolean    'flag for shape file open
Private ShxIsOpen As Boolean    'flag for shx file open
Private Extent As CRect     'holds the extent of the shape file

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

'*****************************************************************************************
'Left
'returns the left coord extent
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get Left() As Double
    Left = Extent.Left
End Property

'*****************************************************************************************
'Right
'returns the right coord of extent
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get Right() As Double
    Right = Extent.Right
End Property

'*****************************************************************************************
'Top
'returns the top coord of extent
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get Top() As Double
    Top = Extent.Top
End Property

'*****************************************************************************************
'Bottom
'returns bottom coord of extent
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get Bottom() As Double
    Bottom = Extent.Bottom
End Property

'*****************************************************************************************
'Count
'returns the number of shapes in the shape file
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get Count() As Long
    Count = RecordCount
End Property

'*****************************************************************************************
'FileType
'returns the type of open shape file
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Property Get FileType() As SHAPEFILETYPE
    FileType = shapeType
End Property


'=========================================================================================
'PUBLIC FUNCTIONS
'=========================================================================================
'******************************************************************************************
'Item returns the shape associated with index
' 1<= index < = number of shapes
'Author Kenneth R. McVay
'Date December 24, 1998
'******************************************************************************************
Public Function Item(ByVal index As Long) As Object
    
    On Error GoTo ERROR_ROUTINE
    
    Select Case shapeType
        Case SHAPEFILETYPE.typePoint
            Set Item = ReadPoint(index)
        Case SHAPEFILETYPE.typePolygon
            Set Item = ReadPolygon(index)
        Case SHAPEFILETYPE.typePolyLine
            Set Item = ReadPolyLine(index)
        Case SHAPEFILETYPE.typeMultiPoint
            Set Item = ReadMultiPoint(index)
    End Select
  
    Exit Function
    
ERROR_ROUTINE:
    Err.Source = "CShapeFile::Item"
    Err.Raise Err.Number, Err.Source, Err.Description
End Function


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


'*****************************************************************************************
'SetFileSpec
'used to set the filename of the shapefile to open or create
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Sub SetFileSpec(FileSpec As CFileName, status As OPENCREATE, Optional aShapeType As SHAPEFILETYPE)

Dim shpExist As Boolean
Dim shxExist As Boolean
    
    On Error GoTo ERROR_ROUTINE
    
    shpExist = False
    shpExist = False
    Set CFileName = New CFileName
    CFileName.SetExtension = "shp"
    CFileName.SetFileSpec = FileSpec.GetFileSpec

    If (UCase(Dir(CFileName.GetFileSpec, vbNormal)) = UCase((CFileName.GetBaseName & "." & CFileName.GetExtension))) Then
        shpExist = True
    End If
    If ((shpExist = False) And (status = OPENIT)) Then
        Err.Raise ERRORCODES.FileDoesNotExist, "C_ShapeFile::SetFileSpec", "The specified file " & _
            CFileName.GetFileSpec & " does not exist."
    End If
    If ((shpExist = True) And (status = CREATEIT)) Then
        Kill (CFileName.GetFileSpec)
    End If
    CFileName.SetExtension = "shx"
    If (UCase(Dir(CFileName.GetFileSpec, vbNormal)) = UCase((CFileName.GetBaseName & "." & CFileName.GetExtension))) Then
        shxExist = True
    End If
    If ((shxExist = False) And (status = OPENIT)) Then
        Err.Raise ERRORCODES.FileDoesNotExist, "C_ShapeFile::SetFileSpec", "The specified file " & _
            CFileName.GetFileSpec & " does not exist."
    End If
    If ((shxExist = True) And (status = CREATEIT)) Then
        Kill (CFileName.GetFileSpec)
    End If
    
    CFileName.SetExtension = "shx"
    ShxFileHandle = FreeFile()
    Open CFileName.GetFileSpec For Binary Access Read Write As ShxFileHandle
    
    ShpFileHandle = FreeFile()
    CFileName.SetExtension = "shp"
    Open CFileName.GetFileSpec For Binary Access Read Write As ShpFileHandle
    
    If (status = OPENIT) Then 'open the existing file
            'open the index file
        Get ShxFileHandle, , ShxMainFileHeader
        With ShxMainFileHeader
            .FileCode = Swap_32(.FileCode)
            .FileLength = Swap_32(.FileLength)      'read in the indexfile header
            .u1 = Swap_32(.u1)
            .u2 = Swap_32(.u2)
            .u3 = Swap_32(.u3)
            .u4 = Swap_32(.u4)
            .u5 = Swap_32(.u5)
            If (.FileCode <> shpFileCode) Then
                Close (ShxFileHandle)
                Err.Raise ERRORCODES.InvalidShapeFile, "C_ShapeFile::SetFileSpec", _
                    "The shx file has an invalid shape code in the main header."
            End If
        End With
        
        Get ShpFileHandle, , ShpMainFileHeader
        Extent.Left = ShpMainFileHeader.BndBoxXmin
        Extent.Right = ShpMainFileHeader.BndBoxXmax
        Extent.Top = ShpMainFileHeader.BndBoxYmax
        Extent.Bottom = ShpMainFileHeader.BndBoxYmin
        With ShpMainFileHeader
            .FileCode = Swap_32(.FileCode)
            .FileLength = Swap_32(.FileLength)  'read the header info
            .u1 = Swap_32(.u1)
            .u2 = Swap_32(.u2)
            .u3 = Swap_32(.u3)
            .u4 = Swap_32(.u4)
            .u5 = Swap_32(.u5)
            If (.FileCode <> shpFileCode) Then
                Close (ShpFileHandle)
                Err.Raise ERRORCODES.InvalidShapeFile, "C_ShapeFile::SetFileSpec", _
                    "The shp file has an invalid shape code in the main header."
            End If
        End With
        RecordCount = (ShxMainFileHeader.FileLength - 50) / 4
        shapeType = ShpMainFileHeader.shapeType
        ShpIsOpen = True
        ShxIsOpen = True
        
        
    Else    'create a new shapefile
        If (IsMissing(aShapeType)) Then
            Err.Raise ERRORCODES.ArgNotOptional, "C_ShapeFile::SetFileSpec", _
                "The ShapeType argument is not optional when argument status is CREATEIT"
        End If
        shapeType = aShapeType
        Extent.Left = 0
        Extent.Right = 0
        Extent.Bottom = 0
        Extent.Top = 0
        Call PutMainHeaders
        RecordCount = 0
    End If
    Exit Sub
    
ERROR_ROUTINE:
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'******************************************************************************************
'Add
'allows the addition of a shape to the shape file
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Public Sub Add(aShape As Object)
    
    Dim s As IShape
    
    On Error GoTo ERROR_ROUTINE
    
    Set s = aShape
    Select Case TypeName(aShape)
        Case "CPoint"
            If (shapeType <> SHAPEFILETYPE.typePoint) Then
                Err.Raise ERRORCODES.CollectionERROR, "CShapeFile::Add", _
                    "Cannot add type CPoint to a ShapeFile initialized as other type"
            End If
            If (s.IsNull = True) Then
                Call PutNull
            Else
                Call PutPoint(aShape)
            End If
            
        Case "CPolyLine"
            If (shapeType <> SHAPEFILETYPE.typePolyLine) Then
                Err.Raise ERRORCODES.CollectionERROR, "CShapeFile::Add", _
                    "Cannot add type CPolyline to a ShapeFile initialized as other type"
            End If
            If (s.IsNull = True) Then
                Call PutNull
            Else
                Call PutPolyLine(aShape)
            End If
            
        Case "CPolygon"
            If (shapeType <> SHAPEFILETYPE.typePolygon) Then
                Err.Raise ERRORCODES.CollectionERROR, "CShapeFile::Add", _
                    "Cannot add type CPolygon to a ShapeFile initialized as other type"
            End If
            If (s.IsNull = True) Then
                Call PutNull
            Else
                Call PutPolygon(aShape)
            End If
            
        Case "CMultiPoint"
            If (shapeType <> SHAPEFILETYPE.typePoint) Then
                Err.Raise ERRORCODES.CollectionERROR, "CShapeFile::Add", _
                    "Cannot add type CPoint to a ShapeFile initialized as other type"
            End If
            If (s.IsNull = True) Then
                Call PutNull
            Else
                Call PutMultiPoint(aShape)
            End If
            
        Case Else
            Err.Raise ERRORCODES.InvalidShapeType, "CShapeFile::Add", _
            "Invalid shape type"
    End Select

    Exit Sub
ERROR_ROUTINE:
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub




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

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


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


'*****************************************************************************************
'ReadPoint
'Reads the CPoint from the shape file at index
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function ReadPoint(ByVal index As Long) As CPoint

    Dim aPoint As CPoint
    Dim X As Double
    Dim Y As Double
    Dim ShpType As SHAPEFILETYPE
    
    On Error GoTo ERROR_ROUTINE
    
    If FindOffset(index) Then
        GetRecordHeader (ShxRecordHeader.offset * 2 + 1)
        If ShpRecordHeader.RecordNumber = index Then
            Get ShpFileHandle, , ShpType
            If ((ShpType <> shapeType) Or (ShpType = SHAPEFILETYPE.typeNullShape)) Then
                Err.Raise ERRORCODES.ShapeNotMatch, "CShapeFile::ReadPoint", _
                    "A shape type does not match main header type."
            End If
            If (ShpType = SHAPEFILETYPE.typeNullShape) Then
                Set aPoint = New CPoint
                aPoint.SetNull = True
                Set ReadPoint = aPoint
            End If
            Get ShpFileHandle, , X
            Get ShpFileHandle, , Y
            Set aPoint = New CPoint
            aPoint.X = X
            aPoint.Y = Y
            Set ReadPoint = aPoint
        Else
            Err.Raise ERRORCODES.RecordsNotMatch, "CShapeFile::ReadPoint", "Index Record does not match main file Record"
        End If
    End If
    
    Exit Function
    
ERROR_ROUTINE:
        Err.Raise Err.Number, Err.Source, Err.Description
End Function

'*****************************************************************************************
'ReadPolyLine
'Reads a CPolyLine from the shapefile at index
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function ReadPolyLine(ByVal index As Long) As CPolyLine
    Dim aPoly As CPolyLine
    Dim aPart As CPart
    Dim aPoint As CPoint
    
    Dim X As Double
    Dim Y As Double
    Dim ShpType As SHAPEFILETYPE
    Dim numPoints As Long
    Dim numParts As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim theParts() As Long
    
    On Error GoTo ERROR_ROUTINE
    
        If FindOffset(index) Then
            GetRecordHeader (ShxRecordHeader.offset * 2 + 1)
            If ShpRecordHeader.RecordNumber = index Then
                Get ShpFileHandle, , ShpType
                If ((ShpType <> shapeType) Or (ShpType = SHAPEFILETYPE.typeNullShape)) Then
                    Err.Raise ERRORCODES.ShapeNotMatch, "CShapeFile::ReadPolygon", _
                        "A shape type does not match main header type."
                End If
                If (ShpType = SHAPEFILETYPE.typeNullShape) Then
                    Set aPoly = New CPolyLine
                    aPoly.SetNull = True
                    Set ReadPolyLine = aPoly
                End If
                Set aPoly = New CPolyLine
                Get ShpFileHandle, , X
                aPoly.Left = X
                Get ShpFileHandle, , X
                aPoly.Bottom = X
                Get ShpFileHandle, , X
                aPoly.Right = X
                Get ShpFileHandle, , X
                aPoly.Top = X
                Get ShpFileHandle, , numParts
                Get ShpFileHandle, , numPoints
                ReDim theParts(0 To numParts - 1)
                Get ShpFileHandle, , theParts
               
                For j = 0 To numParts - 1
                    Set aPart = New CPart
                    If (j <> numParts - 1) Then
                        For k = theParts(j) To theParts(j + 1) - 1
                            Set aPoint = New CPoint
                            Get ShpFileHandle, , X
                            Get ShpFileHandle, , Y
                            aPoint.X = X
                            aPoint.Y = Y
                            aPart.Add aPoint
                        Next
                    Else
                        For k = theParts(j) To numPoints - 1
                            Set aPoint = New CPoint
                            Get ShpFileHandle, , X
                            Get ShpFileHandle, , Y
                            aPoint.X = X
                            aPoint.Y = Y
                            aPart.Add aPoint
                        Next
                    End If
                    aPoly.Add aPart
                Next
                Set ReadPolyLine = aPoly
            Else
                Err.Raise ERRORCODES.RecordsNotMatch, "CShapeFile::ReadPolyLine", "Index Record does not match main file Record"
            End If
        Else
            Err.Raise ERRORCODES.OffsetPastEOF, "CShapeFile::ReadPolyLine", "The offset read from index file is larger then the mainfile size"
        End If

    Exit Function
ERROR_ROUTINE:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

'*****************************************************************************************
'ReadPolygon
'Reads a CPolygon from the shapefile at index
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function ReadPolygon(ByVal index As Long) As CPolygon
    Dim aPoly As CPolygon
    Dim aPart As CPart
    Dim aPoint As CPoint
    
    Dim X As Double
    Dim Y As Double
    Dim ShpType As SHAPEFILETYPE
    Dim numPoints As Long
    Dim numParts As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim theParts() As Long
    
    On Error GoTo ERROR_ROUTINE
    
        If FindOffset(index) Then
            GetRecordHeader (ShxRecordHeader.offset * 2 + 1)
            If ShpRecordHeader.RecordNumber = index Then
                Get ShpFileHandle, , ShpType
                If ((ShpType <> shapeType) Or (ShpType = SHAPEFILETYPE.typeNullShape)) Then
                    Err.Raise ERRORCODES.ShapeNotMatch, "CShapeFile::ReadPolygon", _
                        "A shape type does not match main header type."
                End If
                If (ShpType = SHAPEFILETYPE.typeNullShape) Then
                    Set aPoly = New CPolygon
                    aPoly.SetNull = True
                    Set ReadPolygon = aPoly
                End If
                Set aPoly = New CPolygon
                Get ShpFileHandle, , X
                aPoly.Left = X
                Get ShpFileHandle, , X
                aPoly.Bottom = X
                Get ShpFileHandle, , X
                aPoly.Right = X
                Get ShpFileHandle, , X
                aPoly.Top = X
                Get ShpFileHandle, , numParts
                Get ShpFileHandle, , numPoints
                ReDim theParts(0 To numParts - 1)
                Get ShpFileHandle, , theParts
               
                For j = 0 To numParts - 1
                    Set aPart = New CPart
                    If (j <> numParts - 1) Then
                        For k = theParts(j) To theParts(j + 1) - 1
                            Set aPoint = New CPoint
                            Get ShpFileHandle, , X
                            Get ShpFileHandle, , Y
                            aPoint.X = X
                            aPoint.Y = Y
                            aPart.Add aPoint
                        Next
                    Else
                        For k = theParts(j) To numPoints - 1
                            Set aPoint = New CPoint
                            Get ShpFileHandle, , X
                            Get ShpFileHandle, , Y
                            aPoint.X = X
                            aPoint.Y = Y
                            aPart.Add aPoint
                        Next
                    End If
                    aPoly.Add aPart
                Next
                Set ReadPolygon = aPoly
            Else
                Err.Raise ERRORCODES.RecordsNotMatch, "CShapeFile::ReadPolygon", "Index Record does not match main file Record"
            End If
        Else
            Err.Raise ERRORCODES.OffsetPastEOF, "CShapeFile::ReadPolygon", "The offset read from index file is larger then the mainfile size"
        End If

    Exit Function
ERROR_ROUTINE:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

'*****************************************************************************************
'ReadMultiPoint
'Reads a CMultiPoint form the shapefile at index
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Function ReadMultiPoint(ByVal index As Long) As CMultiPoint
    Dim aMulti As CMultiPoint
    Dim aPoint As CPoint
    Dim X As Double
    Dim Y As Double
    Dim ShpType As SHAPEFILETYPE
    Dim numPoints As Long
    Dim i As Long
    Dim j As Long

    On Error GoTo ERROR_ROUTINE
    
        If FindOffset(i) Then
            GetRecordHeader (ShxRecordHeader.offset * 2 + 1)
            If ShpRecordHeader.RecordNumber = i Then
                Get ShpFileHandle, , ShpType
                If ((ShpType <> shapeType) Or (ShpType = SHAPEFILETYPE.typeNullShape)) Then
                    Err.Raise ERRORCODES.ShapeNotMatch, "C_ShapeFile::ReadPolys", _
                        "A shape type does not match main header type."
                End If
                If (ShpType = SHAPEFILETYPE.typeNullShape) Then
                    Set aMulti = New CMultiPoint
                    aMulti.SetNull = True
                    Set ReadMultiPoint = aMulti
                End If
                Set aMulti = New CMultiPoint
                Get ShpFileHandle, , X
                aMulti.Left = X
                Get ShpFileHandle, , X
                aMulti.Bottom = X
                Get ShpFileHandle, , X
                aMulti.Right = X
                Get ShpFileHandle, , X
                aMulti.Top = X
                Get ShpFileHandle, , numPoints
                For j = 0 To numPoints - 1
                    Set aPoint = New CPoint
                    Get ShpFileHandle, , X
                    Get ShpFileHandle, , Y
                    aPoint.X = X
                    aPoint.Y = Y
                    aMulti.Add aPoint
                Next
                Set ReadMultiPoint = aMulti
            Else
                Err.Raise ERRORCODES.RecordsNotMatch, "CShape_IO::ReadMultiPoint", "Index Record does not match main file Record"
            End If
        Else
            Err.Raise ERRORCODES.OffsetPastEOF, "C_ShapeFile::ReadMultiPoint", "The offset read from index file is larger then the mainfile size"
        End If
        
    Exit Function
ERROR_ROUTINE:
    Err.Raise Err.Number, Err.Source, Err.Description
End Function


'********************************************************************************
'Function FindOffset
' given a valid record number, returns the offset to the record
'offset is gotten from the index file
'Author Kenneth R. McVay
'Date December 24, 1998
'********************************************************************************
Private Function FindOffset(ByVal RecordNumber As Long) As Boolean
    Dim ByteOffset As Long
    
    On Error GoTo ERROR_ROUTINE
    If RecordNumber = 1 Then
        ByteOffset = FILESIZES.MainHeaderSize + 1
    Else
        ByteOffset = FILESIZES.MainHeaderSize + ((RecordNumber - 1) * 8) + 1
    End If
    If ByteOffset > ShxMainFileHeader.FileLength * 2 - (FILESIZES.IndexRecSize - 1) Then
        FindOffset = False      'offset is greater then the length of the main file
    Else
        Get ShxFileHandle, ByteOffset, ShxRecordHeader
        With ShxRecordHeader
            .ContentLength = Swap_32(.ContentLength)
            .offset = Swap_32(.offset)
        End With
        FindOffset = True
    End If
    Exit Function
ERROR_ROUTINE:
    Err.Source = "C_ShapeFile::FindOffset"
    Err.Raise Err.Number, Err.Source, Err.Description
End Function

'*****************************************************************************************
'Swap_32
'swaps the byte order of longs
'Author Mark Gray
'December 24, 1998
'*****************************************************************************************
Private Function Swap_32(n As Long) As Long
  Dim TempLong As LongType
  Dim OrigBytes As FourByteType
  Dim NewBytes As FourByteType
  
  On Error GoTo ERROR_ROUTINE
  
  TempLong.l = n
  LSet OrigBytes = TempLong
  NewBytes.b1 = OrigBytes.b4
  NewBytes.b2 = OrigBytes.b3
  NewBytes.b3 = OrigBytes.b2
  NewBytes.b4 = OrigBytes.b1
  LSet TempLong = NewBytes
  Swap_32 = TempLong.l
  Exit Function
  
ERROR_ROUTINE:
  Err.Raise Err.Number, Err.Source, Err.Description
End Function


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

'*****************************************************************************************
'PutMainHeaders
'writes the main headers of the shp and shx files
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutMainHeaders()

    On Error GoTo ERROR_ROUTINE
    
    With ShxMainFileHeader
        .FileCode = Swap_32(shpFileCode)
        .version = 1000
        .shapeType = shapeType
        .u1 = 0
        .u2 = 0
        .u3 = 0
        .u4 = 0
        .u5 = 0
        .BndBoxXmax = Extent.Right
        .BndBoxXmin = Extent.Left
        .BndBoxYmax = Extent.Top
        .BndBoxYmin = Extent.Bottom
        .BndBoxMmax = 0#
        .BndboxMmin = 0#
        .BndBoxZmax = 0#
        .BndBoxZmin = 0#
    End With
    With ShpMainFileHeader
        .FileCode = Swap_32(shpFileCode)
        .version = 1000
        .shapeType = shapeType
        .u1 = 0
        .u2 = 0
        .u3 = 0
        .u4 = 0
        .u5 = 0
        .BndBoxXmax = Extent.Right
        .BndBoxXmin = Extent.Left
        .BndBoxYmax = Extent.Top
        .BndBoxYmin = Extent.Bottom
        .BndBoxMmax = 0#
        .BndboxMmin = 0#
        .BndBoxZmax = 0#
        .BndBoxZmin = 0#
    End With
    Put ShpFileHandle, , ShpMainFileHeader
    Put ShxFileHandle, , ShxMainFileHeader
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "CShapeFile::PutMainHeaders"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub



'*****************************************************************************************
'PutNull
'writes a null shape to the open file
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutNull()
    On Error GoTo ERROR_ROUTINE
    
    Put ShxFileHandle, LOF(ShxFileHandle) + 1, Swap_32(LOF(ShpFileHandle) / 2)
    Put ShxFileHandle, , Swap_32(2)
    Put ShpFileHandle, LOF(ShpFileHandle) + 1, Swap_32(RecordCount + 1)
    Put ShpFileHandle, , Swap_32(2)
    Put ShpFileHandle, , 0
    RecordCount = RecordCount + 1
    
    Exit Sub
ERROR_ROUTINE:
    Err.Source = "CShapeFile::PutNull"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'*****************************************************************************************
'PutPoint
'writes a CPoint to the shapefile
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutPoint(aPoint As CPoint)

    On Error GoTo ERROR_ROUTINE

        Put ShxFileHandle, LOF(ShxFileHandle) + 1, Swap_32(LOF(ShpFileHandle) / 2)
        Put ShxFileHandle, , Swap_32(10)
        Put ShpFileHandle, LOF(ShpFileHandle) + 1, Swap_32(RecordCount + 1)
        Put ShpFileHandle, , Swap_32(10)
        Put ShpFileHandle, , shapeType
        Put ShpFileHandle, , aPoint.X
        Put ShpFileHandle, , aPoint.Y
        Put ShpFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShpFileHandle) / 2)
        Put ShxFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShxFileHandle) / 2)
        RecordCount = RecordCount + 1
        Call PutExtent(aPoint)
        
        Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "C_ShapeFile::PutPoints"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'*****************************************************************************************
'PutPolyLine
'writes a polyline to the shapefile
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutPolyLine(aShape As CPolyLine)
Dim aPart As CPart
Dim apnt As CPoint
Dim s As IShape

Dim numPoints As Long
Dim numParts As Long
Dim counter As Long
Dim contentlen As Long
Dim PartsArray() As Long

    
    On Error GoTo ERROR_ROUTINE
    
        Set s = aShape
        
        numParts = aShape.Count
        numPoints = 0
        ReDim PartsArray(0 To numParts - 1)
        counter = 0
        For Each aPart In aShape
            numPoints = numPoints + aPart.Count
            If (counter = 0) Then
                PartsArray(counter) = 0
            Else
                PartsArray(counter) = numPoints - aPart.Count
            End If
            counter = counter + 1
        Next
        contentlen = (numParts * 4 + numPoints * 16 + 44) 'in bytes
        Put ShxFileHandle, LOF(ShxFileHandle) + 1, Swap_32(LOF(ShpFileHandle) / 2)
        Put ShxFileHandle, , Swap_32(contentlen / 2)
        Put ShpFileHandle, LOF(ShpFileHandle) + 1, Swap_32(RecordCount + 1)
        Put ShpFileHandle, , Swap_32(contentlen / 2)
        Put ShpFileHandle, , shapeType
        Put ShpFileHandle, , s.Left
        Put ShpFileHandle, , s.Bottom
        Put ShpFileHandle, , s.Right
        Put ShpFileHandle, , s.Top
        Put ShpFileHandle, , numParts
        Put ShpFileHandle, , numPoints
        Put ShpFileHandle, , PartsArray
        For Each aPart In aShape
            For Each apnt In aPart
                Put ShpFileHandle, , apnt.X
                Put ShpFileHandle, , apnt.Y
            Next
        Next
        
    Put ShpFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShpFileHandle) / 2)
    Put ShxFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShxFileHandle) / 2)
    
    RecordCount = RecordCount + 1
    Call PutExtent(aShape)
    
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "CShapeFile::PutPolyLine"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'*****************************************************************************************
'PutPolygon
'writes a CPolygon to the shape file
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutPolygon(aShape As CPolygon)
Dim aPart As CPart
Dim apnt As CPoint
Dim s As IShape

Dim numPoints As Long
Dim numParts As Long
Dim counter As Long
Dim contentlen As Long
Dim PartsArray() As Long

    
    On Error GoTo ERROR_ROUTINE
    
        Set s = aShape
        
        numParts = aShape.Count
        numPoints = 0
        ReDim PartsArray(0 To numParts - 1)
        counter = 0
        For Each aPart In aShape
            numPoints = numPoints + aPart.Count
            If (counter = 0) Then
                PartsArray(counter) = 0
            Else
                PartsArray(counter) = numPoints - aPart.Count
            End If
            counter = counter + 1
        Next
        contentlen = (numParts * 4 + numPoints * 16 + 44) 'in bytes
        Put ShxFileHandle, LOF(ShxFileHandle) + 1, Swap_32(LOF(ShpFileHandle) / 2)
        Put ShxFileHandle, , Swap_32(contentlen / 2)
        Put ShpFileHandle, LOF(ShpFileHandle) + 1, Swap_32(RecordCount + 1)
        Put ShpFileHandle, , Swap_32(contentlen / 2)
        Put ShpFileHandle, , shapeType
        Put ShpFileHandle, , s.Left
        Put ShpFileHandle, , s.Bottom
        Put ShpFileHandle, , s.Right
        Put ShpFileHandle, , s.Top
        Put ShpFileHandle, , numParts
        Put ShpFileHandle, , numPoints
        Put ShpFileHandle, , PartsArray
        For Each aPart In aShape
            For Each apnt In aPart
                Put ShpFileHandle, , apnt.X
                Put ShpFileHandle, , apnt.Y
            Next
        Next
        
    Put ShpFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShpFileHandle) / 2)
    Put ShxFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShxFileHandle) / 2)
    
    RecordCount = RecordCount + 1
    Call PutExtent(aShape)
    
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "CShapeFile::PutPolygon"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'*****************************************************************************************
'PutMultiPoint
'writes a CMultiPoint to the shapefile
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutMultiPoint(aShape As CMultiPoint)

Dim apnt As CPoint
Dim s As IShape

Dim numPoints As Long
Dim counter As Long
Dim contentlen As Long

    
    On Error GoTo ERROR_ROUTINE
            
        Set s = aShape
        
        numPoints = aShape.Count
        contentlen = (numPoints * 16 + 40)
        Put ShxFileHandle, LOF(ShxFileHandle) + 1, Swap_32(LOF(ShpFileHandle) / 2)
        Put ShxFileHandle, , Swap_32(contentlen / 2)
        Put ShpFileHandle, LOF(ShpFileHandle) + 1, Swap_32(RecordCount + 1)
        Put ShpFileHandle, , Swap_32(contentlen / 2)
        Put ShpFileHandle, , shapeType
        Put ShpFileHandle, , s.Left
        Put ShpFileHandle, , s.Bottom
        Put ShpFileHandle, , s.Right
        Put ShpFileHandle, , s.Top
        Put ShpFileHandle, , numPoints
        For Each apnt In aShape
            Put ShpFileHandle, , apnt.X
            Put ShpFileHandle, , apnt.Y
        Next
    
    
    Put ShpFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShpFileHandle) / 2)
    Put ShxFileHandle, HEADEROFFSETS.FileLength, Swap_32(LOF(ShxFileHandle) / 2)
    
    RecordCount = RecordCount + 1
    Call PutExtent(aShape)
    
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "CShapeFile::PutMultiPoints"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'*****************************************************************************************
'PutExtent
'writes the bounding box of all shapes to the main headers
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub PutExtent(aShape As Object)
    
    Dim s As IShape
    Dim ExtentChange As Boolean
    
    On Error GoTo ERROR_ROUTINE
    
    Set s = aShape
    ExtentChange = False
    
        If (RecordCount = 1) Then
            Extent.Left = s.Left
            Extent.Right = s.Right
            Extent.Top = s.Top
            Extent.Bottom = s.Bottom
            ExtentChange = True
        Else
            If (s.Left < Extent.Left) Then
                Extent.Left = s.Left
                ExtentChange = True
            End If
            If (s.Right > Extent.Right) Then
                Extent.Right = s.Right
                ExtentChange = True
            End If
            If (s.Top > Extent.Top) Then
                Extent.Top = s.Top
                ExtentChange = True
            End If
            If (s.Bottom < Extent.Bottom) Then
                Extent.Bottom = s.Bottom
                ExtentChange = True
            End If
        End If
        If (ExtentChange = True) Then
            Put ShpFileHandle, HEADEROFFSETS.Xmax, Extent.Right
            Put ShpFileHandle, HEADEROFFSETS.Xmin, Extent.Left
            Put ShpFileHandle, HEADEROFFSETS.Ymax, Extent.Top
            Put ShpFileHandle, HEADEROFFSETS.Ymin, Extent.Bottom
            Put ShxFileHandle, HEADEROFFSETS.Xmax, Extent.Right
            Put ShxFileHandle, HEADEROFFSETS.Xmin, Extent.Left
            Put ShxFileHandle, HEADEROFFSETS.Ymax, Extent.Top
            Put ShxFileHandle, HEADEROFFSETS.Ymin, Extent.Bottom
        End If
        
        
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "CShapeFile::PutExtent"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub



'*****************************************************************************************
'GetRecordHeader
'reads the shape header of the shape as offset
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub GetRecordHeader(offset As Long)

    On Error GoTo ERROR_ROUTINE
    
    Get ShpFileHandle, offset, ShpRecordHeader
    With ShpRecordHeader
        .ContentLength = Swap_32(.ContentLength)
        .RecordNumber = Swap_32(.RecordNumber)
    End With
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "C_ShapeFile::GetRecordHeader"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub


'*****************************************************************************************
'Class_Initialize
'initializes the object
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub Class_Initialize()

    On Error GoTo ERROR_ROUTINE
    
    ShpIsOpen = False
    ShxIsOpen = False
    Set Extent = New CRect
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "C_ShapeFile::Class_Initialize"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub

'*****************************************************************************************
'Class_Terminate
'closes files and deletes the extent object
'Author Kenneth R. McVay
'Date December 24, 1998
'*****************************************************************************************
Private Sub Class_Terminate()

    On Error GoTo ERROR_ROUTINE
    
    
    
    Close ShpFileHandle
    ShpIsOpen = False
    Close ShxFileHandle
    ShxIsOpen = False
    Set Extent = Nothing
    
    Exit Sub
    
ERROR_ROUTINE:
    Err.Source = "C_ShapeFile::Class_Terminate"
    Err.Raise Err.Number, Err.Source, Err.Description
End Sub