In my coding of ESRI Shape files I read the pdf document available and i tried the coding of my own but I was unable to get even any one of the shape file while i'm checking the output.I tried my level best but really unable to get the output.So readers I'll be very thankfull if u could correct my error and provide me the correct source code please.Thanks in advance

Form Module:

Dim cn As New ADODB.Connectio
Dim rs As New ADODB.Recordse
Dim i As Intege

Private Sub Command2_Click(
Dim SHPFile As New ESRIShapeV2.ShapeFile   ' ESRIShapeV2.Shap
Dim shpPOLYGON As CPolygo
Dim shpPOLYLINE As CPolyLin
Dim shpPOINT As CPoin
Dim shpPART As CPar
Dim sfilepath As Strin
Dim pt As CPoint, pt1 As CPoin

sfilepath = App.pat
  If Right(sfilepath, 1) = "\" The
     sfilepath = Mid(sfilepath, 1, Len(sfilepath) - 1
  End I

On Error Resume Nex
    For Each Var In Array("dbf", "shp", "shx"
     If Len(Dir(sfilepath & "\Polygon." & Var, vbNormal)) <> 0 The
        Kill sfilepath & "\Polygon." & Va
        Kill sfilepath & "\Polyline." & Va
        Kill sfilepath & "\MultiPoint." & Va
     End I
  Next Va
 
                Set SHPFile = New ESRIShapeV2.ShapeFil
                SHPFile.FileName sfilepath & "\Polygon.SHP", CREATEIT, SHAPEFILETYPE.typePolygo

If SHPFile.FileType = Polygon The

           Set shpPOLYGON = New CPolygo
           Set shpPART = New CPar
           Set shpPOINT = New CPoin
           Set pt = New CPoin
           Set pt1 = New CPoin
           i =
           rs.MoveFirs

           For i = 0 To rs.RecordCoun
              pt.X = rs.Fields("easting").Value   'x
              pt.Y = rs.Fields("northing").Value  'y

              rs.MoveNex
              pt1.X = rs.Fields("easting").Value   'x
              pt1.Y = rs.Fields("northing").Value   'y
               shpPART.Add shpPOIN
               shpPOLYGON.Add shpPAR
               SHPFile.Add shpPOLYGO
           Nex

              If SHPFile.Count > 0 The
                 SHPFile.Sav
              End I
           Set SHPFile = Nothin
      End I
      Set SHPFile = New ESRIShapeV2.ShapeFil
              SHPFile.FileName sfilepath & "\Polyline.SHP", CREATEIT, SHAPEFILETYPE.typePolyLin

       If SHPFile.FileType = PolyLine The
           Set shpPOLYLINE = New CPolyLin
           Set shpPART = New CPar
           Set shpPOINT = New CPoin
           Set pt = New CPoin
           Set pt1 = New CPoin
           For i = 0 To rs.RecordCoun
              pt.X = rs.Fields("easting").Value   'x
              pt.Y = rs.Fields("northing").Value  'y
              rs.MoveNex
              pt1.X = rs.Fields("easting").Value   'x
              pt1.Y = rs.Fields("northing").Value   'y
              shpPART.Add shpPOIN
              shpPOLYLINE.Add shpPAR
              SHPFile.Add shpPOLYLIN

           Nex

              If SHPFile.Count > 0 The
                 SHPFile.Sav
              End I
           Set SHPFile = Nothin
        End I
           Set SHPFile = New ESRIShapeV2.ShapeFil
              SHPFile.FileName sfilepath & "\point.SHP", CREATEIT, SHAPEFILETYPE.typeMultiPoin
         
      'If SHPFile.FileType = Point The
           Set shpPOINT = New CPoin
              Set pt = New CPoin
              Set pt1 = New CPoin
           For i = 0 To rs.RecordCoun
              pt.X = rs.Fields("easting").Value   'x
              pt.Y = rs.Fields("northing").Value  'y
              rs.MoveNex
              pt1.X = rs.Fields("easting").Value   'x
              pt1.Y = rs.Fields("northing").Value   'y
             
            Nex
              shpPART.Add shpPOIN
              SHPFile.Add shpPOIN
         
              If SHPFile.Count > 0 The
                 SHPFile.Sav
              End I
           Set SHPFile = Nothin
       'End I
         
         
    'End Selec
     
End Su

Private Sub Form_Load(
Set cn = New ADODB.Connectio
strSQL = "select  Node_1.Easting,Node_1.Northing,Node_1.SurveyID,BDY.Order from (Node_1 inner join BDY on Node_1.NodeID=BDY.NodeID)inner join Survey_1 on BDY.ID=Survey_1.ID  where node_1.Surveyid = 5 or node_1.Surveyid = 14 order by Node_1.SurveyID,BDY.Order
cn.ConnectionString = " Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\" & "sample2.mdb;Persist Security Info=False"
cn.Open
Set rs = New ADODB.Recordset
rs.Open strSQL, cn, adOpenKeyset, adLockPessimistic
End Sub

Module:-
Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection
Public Sub Make(ByVal originpoint As CPoint, ByVal sizePoint As CPoint)
Dim pt As CPoint, pt1 As CPoint
Set originpoint = New CPoint
Set pt = New CPoint
Set pt1 = New CPoint

Call main


     originpoint.X = rs.Fields("easting").Value
     originpoint.Y = rs.Fields("northing").Value
     rs.MoveNext
     sizePoint.X = rs.Fields("easting").Value  'x2
     sizePoint.Y = rs.Fields("northing").Value '500   y2
   pt.X = originpoint.X
   pt.X = originpoint.X
   pt.Y = originpoint.Y
   pt1.X = sizePoint.X
   pt1.Y = sizePoint.Y

   
End Sub
Public Sub MakeEmpty()
strSQL = "select  Node_1.Easting,Node_1.Northing,Node_1.SurveyID,BDY.Order from (Node_1 inner join BDY on Node_1.NodeID=BDY.NodeID)inner join Survey_1 on BDY.ID=Survey_1.ID  where node_1.Surveyid = 5 or node_1.Surveyid = 14 order by Node_1.SurveyID,BDY.Order"
'cn.ConnectionString = " Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\" & "sample2.mdb;Persist Security Info=False"
'cn.Open
Set rs = New ADODB.Recordset
rs.Open strSQL, cn, adOpenKeyset, adLockPessimistic
Dim pt As CPoint, pt1 As CPoint
Set pt = New CPoint
   pt.X = rs.Fields("easting").Value
   pt.Y = rs.Fields("northing").Value
   rs.MoveNext
   pt1.X = rs.Fields("easting").Value
   pt1.Y = rs.Fields("northing").Value
End Sub

Public Sub main()
cn.ConnectionString = " Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\" & "sample2.mdb;Persist Security Info=False"
cn.Open
strSQL = "select  Node_1.Easting,Node_1.Northing,Node_1.SurveyID,BDY.Order from (Node_1 inner join BDY on Node_1.NodeID=BDY.NodeID)inner join Survey_1 on BDY.ID=Survey_1.ID  where node_1.Surveyid = 5 or node_1.Surveyid = 14 order by Node_1.SurveyID,BDY.Order"
Set rs = New ADODB.Recordset
rs.Open strSQL, cn, adOpenKeyset, adLockPessimistic

End Sub

Class Module:-
CPart:-

'Class CPart
'Implements shape parts for polygons and polylines

Option Explicit

Private part As Collection
Private Extent As CRect
Public Property Get Left() As Double
   Left = Extent.Left
End Property

Public Property Let Left(aValue As Double)
   Extent.Left = aValue
End Property

Public Property Get Right() As Double
   Right = Extent.Right
End Property

Public Property Let Right(aValue As Double)
   Extent.Right = aValue
End Property

Public Property Get Top() As Double
   Top = Extent.Top
End Property

Public Property Let Top(aValue As Double)
   Extent.Top = aValue
End Property

Public Property Get Bottom() As Double
   Bottom = Extent.Bottom
End Property

Public Property Let Bottom(aValue As Double)
   Extent.Bottom = aValue
End Property

Public Property Get Count() As Long
   Count = part.Count
End Property

Public Function Item(ByVal index As Long) As CPoint
   On Error GoTo ERROR_ROUTINE
       Set Item = part.Item(index)
   Exit Function
ERROR_ROUTINE:
   Err.Raise Err.Number, Err.Source, Err.Description
End Function

Public Function NewEnum() As IUnknown
Set NewEnum = part.[_NewEnum]
End Function

Public Sub Remove(ByVal index As Long)
   Dim apnt As CPoint
   Dim cnt As Long
   
   On Error GoTo ERROR_ROUTINE
   part.Remove index
   cnt = 1
   For Each apnt In part
       If (cnt = 1) Then
           Extent.Left = apnt.X
           Extent.Right = apnt.X
           Extent.Bottom = apnt.Y
           Extent.Top = apnt.Y
       Else
           If (apnt.X < Extent.Left) Then
               Extent.Left = apnt.X
           ElseIf (apnt.X > Extent.Right) Then
               Extent.Right = apnt.X
           End If
           If (apnt.Y < Extent.Bottom) Then
               Extent.Bottom = apnt.Y
           ElseIf (apnt.Y > Extent.Top) Then
               Extent.Top = apnt.Y
           End If
       End If
   Next
   Exit Sub
ERROR_ROUTINE:
   Err.Source = "CPart::Remove"
   Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Public Sub Add(ByVal aPoint As CPoint)

   On Error GoTo ERROR_ROUTINE
Dim part As New CPart
   If (TypeName(aPoint) <> "CPoint") Then
       Err.Raise ERRORCODES.InvalidObject, "CPart::Add", _
           "CPart can only accept objects of type CPoint"
   End If
   
   If (part.Count = 0) Then
      Call Make(aPoint, aPoint)
   Else
       If (aPoint.X < Extent.Left) Then
           Extent.Left = aPoint.X
       ElseIf (aPoint.X > Extent.Right) Then
           Extent.Right = aPoint.X
       End If
       If (aPoint.Y < Extent.Bottom) Then
           Extent.Bottom = aPoint.Y
       ElseIf (aPoint.Y > Extent.Top) Then
           Extent.Top = aPoint.Y
       End If
   End If
   part.Add aPoint
   Exit Sub
ERROR_ROUTINE:
   Err.Raise Err.Number, Err.Source, Err.Description
End Sub

Private Sub Class_Initialize()
   Set part = New Collection
   Set Extent = New CRect
End Sub

CRect:-
Option Explicit
'Class CRect
'Used as a rectangle object for extents etc...

Implements IShape

Private pt As CPoint ' CPoint to hold upper left coord of rect
Private pt1 As CPoint ' CPoint to hold lower right coord of rect
Private NullShape As Boolean
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i As Integer

Public Property Get Top() As Double
   Top = pt.Y
End Property

Public Property Get Left() As Double
   Left = pt.X
End Property

Public Property Get Bottom() As Double
   Bottom = pt1.Y
End Property

Public Property Get Right() As Double
   Right = pt1.X
End Property

Public Property Let Top(ByVal aValue As Double)
   pt.Y = aValue
End Property

Public Property Let Bottom(ByVal aValue As Double)
   pt1.Y = aValue
End Property

Public Property Let Left(ByVal aValue As Double)
   pt.X = aValue
End Property

Public Property Let Right(ByVal aValue As Double)
   pt1.X = aValue
End Property

Public Sub MakeXY(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double)
   pt.X = 100 'x1
   pt.Y = 100 'y1
   pt1.X = 500 'x2
   pt1.Y = 500 'y2
End Sub

Friend Property Let SetNull(aNull As Boolean)
   NullShape = aNull
End Property

Private Property Get IShape_Bottom() As Double
   IShape_Bottom = pt1.Y
End Property
Private Property Get IShape_IsNull() As Boolean
   IShape_IsNull = NullShape
End Property

Private Property Get IShape_Left() As Double
   IShape_Left = pt.X
End Property

Private Property Let IShape_MakeNull(RHS As Boolean)
   NullShape = RHS
End Property

Private Property Get IShape_Right() As Double
   IShape_Right = pt1.X
End Property

Private Property Get IShape_Top() As Double
   IShape_Top = pt.Y
End Property

Private Function IShape_Distance(aShape As Object) As Double
   MsgBox "NOT IMPLEMENTED"
   IShape_Distance = 0
End Function