i am reading a ascii file of 90MB and writing data into ms access tables with ado's using command parameter object.It is writing data perfectly but taking lot of time.To writing 15lakhs records taking 24 hours.how can i achieve performance.

Option Explicit
Dim conn As ADODB.Connection
Dim rsAttribute As ADODB.Recordset  'record set for Atrributes Table
Dim cmdPoint As ADODB.Command  'Command object for PointFeatures Table
Dim cmdNodes As ADODB.Command
Dim cmdFeat As ADODB.Command
Dim cmdAttributes As ADODB.Command
Dim cmdNames As ADODB.Command
Dim cmdTempNames As ADODB.Command
Dim cmdProvNames As ADODB.Command
Dim cmdAttributesNames As ADODB.Command

Dim parmVol As ADODB.Parameter
Dim parmDset As ADODB.Parameter
Dim parmSectId As ADODB.Parameter
Dim parmFeat As ADODB.Parameter
Dim parmAttId As ADODB.Parameter

Dim parmNdeItem As ADODB.Parameter
Dim parmXcoord As ADODB.Parameter
Dim parmYcoord As ADODB.Parameter

Dim parmPnt As ADODB.Parameter
Dim parmNrAtt As ADODB.Parameter

Dim parmAttSqNr As ADODB.Parameter
Dim parmAttTyp As ADODB.Parameter
Dim parmAttValue As ADODB.Parameter

Dim str As String
Dim strTab() As String
Dim i As Integer

Private Sub CmProcess_Click()
    lblFileName.Caption = ""
    Call OpenConnection

    Screen.MousePointer = 11
    'ProgressBar1.Value = 0
    Call OpenSchema   'To display to each Table Name from database
    Call CreateProcedure    'To Create Tables

    '*********************Prepared Command Objects ***********************
    Call CreateTempNamesCmd  'temp tables
    Call CreatTempTab
    Call CreatePointCmd
    Call CreateNodesCmd
    Call CreateFeatCmd
    Call CreateAttributesCmd
    Call CmdAttNames

    Call ProvProc                'Reads the Eur_p3.lst file and Writes the data into TempProvince Table
    Call NamesProc                'Reads the Eur_l.lst file and Writes the data into TempNmes Table

    Call WriteToGlobus   'Reads  the VRT File and Writes into different Table

    frmGlobusLine.Show
    Unload frmGlobusLine
    FrmBnaArea.Show
    Unload FrmBnaArea
    Screen.MousePointer = 0

End Sub

Private Sub Command1_Click()
End
End Sub

Private Sub Dir1_Change()
    '    File1.Path = Dir1.Path

End Sub

Private Sub Dir1_Click()
    File1.Refresh
    File1.Path = Dir1.Path
    File1.Pattern = "*.vrt;*.sgm;*.int;*.lst;*.bna"
    Call fileExists

End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive

End Sub

Private Sub File1_Validate(Cancel As Boolean)

''Dim arry() As String
''Dim arr() As String
''
''ReDim arr(File1.ListCount)
''For i = 0 To File1.ListCount - 1
''    arr(i) = UCase(File1.List(i))
''
''    If (arr(i) = "EUR5.VRT") Or (arr(i) = "EUR_C.BNA") Or (arr(i) = "EUR_L.BNA") Or (arr(i) = "EUR_P.BNA") Or (arr(i) = "EUR_W.BNA") Or (arr(i) = "EUR_L.LST") Or (arr(i) = "EUR5.INT") Or (arr(i) = "EUR_P3.LST") Or (arr(i) = "EUR5.SGM") Then
''        CmProcess.Enabled = True
''    Else
''        MsgBox "Some files are Missing"
''        CmProcess.Enabled = False
''
''    End If
''Next
End Sub

Private Sub Form_Initialize()

''    Call CreateAccessDatabase("Globus")  'Creates Globus.mdb Database
''    '*********Setting up the connection With out Creating DSN
''    Set conn = New ADODB.Connection
''    conn.ConnectionString = "provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & App.Path & "\Globus.mdb"
''    conn.CursorLocation = adUseClient
''    conn.Open
End Sub

Private Sub NamesProc()
                        'Reads the Eur_l.lst file and Writes the data into TempNmes Table

    Dim strTemp As String
    Dim strArr() As String
    On Error GoTo errhandler:

    File1.Pattern = "*_l.lst"
    Open Dir1.Path & "\" & File1.FileName For Input As #1
    'Open App.Path & "\" & "Eur_l.lst" For Input As #1   '' Reads a single line from Eur_l.lst File
    While Not EOF(1)
        Line Input #1, strTemp
        strArr = Split(strTemp, ",")              'Splits line with comma separated
        cmdTempNames("ND_ID") = strArr(0)
        cmdTempNames("ND_ABBR") = strArr(1)
        cmdTempNames("ND_NAME") = strArr(2)
        cmdTempNames.Execute

    Wend
    Close #1
Exit Sub

errhandler:
Close #1
MsgBox Err.Number & Err.Description

End Sub
Private Sub ProvProc()
                'Reads the Eur_p3.lst file and Writes the data into TempProvince Table
    Dim strTemp As String
    Dim strArr() As String
    On Error GoTo errhandler:
    File1.Pattern = "*_p3.lst"
    Open Dir1.Path & "\" & File1.FileName For Input As #1
    'Open App.Path & "\" & "Eur_p3.lst" For Input As #1   'Read a single line from Eur_p3.lst File
    While Not EOF(1)
        Line Input #1, strTemp
        strArr = Split(strTemp, ",")            'Splits the line with comma separated
        cmdProvNames("Con_ID") = strArr(0)
        cmdProvNames("Prov_ID") = strArr(1)
        cmdProvNames("Prov_ABBR") = strArr(2)
        cmdProvNames("ND_NAME") = strArr(3)
        cmdProvNames.Execute

    Wend
    Close #1                          'Closes the opened file
Exit Sub
errhandler:
    Close #1
    MsgBox Err.Number & Err.Description
End Sub

Private Sub WriteToGlobus()
                        'Reads the VRT file and Writes into different Tables
    Dim strData() As String
    Dim intStart As Integer
    Dim intcount As Integer
    Dim strNodeType As String
    Dim strTemp As String

    Dim names As ADODB.Recordset
    Dim TempNames As ADODB.Recordset
    Dim strValue As String
    Dim intValue As Integer
    Dim lngRecCounter As Long

    On Error GoTo errhandler:

    File1.Pattern = "*.vrt"
    Open Dir1.Path & "\" & File1.FileName For Input As #1
    lngRecCounter = 0
    While Not EOF(1)

        Line Input #1, strTemp             'Read the line from vrt file
        lngRecCounter = lngRecCounter + 1
        Prgbar.Min = 1
        Prgbar.Max = 1000
        Prgbar.Value = lngRecCounter
        lblFileName.Caption = "Importing Point Features"
        If lngRecCounter = 1000 Then
            Prgbar.Value = 100
            lngRecCounter = 0
        End If
        intcount = 0
        strData = Split(strTemp, ",")           'Splits the line as comma separated

        ' Setting the values for prepared command for FeatureAttributeReferences1 Table
        cmdFeat("VolId") = 1
        cmdFeat("DsetId") = 1
        cmdFeat("SectId") = 1
        cmdFeat("FeatItemId") = strData(0)
        cmdFeat("AttItemId") = strData(0)
        cmdFeat.Execute          'Executing the prepared command for FeatureAttributeReferences1 Table

        For intStart = LBound(strData) To UBound(strData)
''            If intStart = 1 Then
''                dblXcoord = strData(intStart)
''                dblXcoord = dblXcoord * 60 * 60 * 1000
''
''            ElseIf intStart = 2 Then
''                dblYcoord = strData(intStart)
''                dblYcoord = (dblYcoord) * 60 * 60 * 1000
            If intStart > 3 And strData(intStart) <> "" Then
                intcount = intcount + 1
                              ' Setting the values for prepared command for Atributes Table
                cmdAttributes("VolId") = 1
                cmdAttributes("DsetId") = 1
                cmdAttributes("SectId") = 1
                cmdAttributes("attitemid") = strData(0)
                cmdAttributes("AttSqNr") = intcount
                strNodeType = nodetype(intStart)
                cmdAttributes("AttTyp") = strNodeType
                cmdAttributes("AttValue") = strData(intStart)
                cmdAttributes.Execute   'Executing the prepared command

                If intStart = 4 And strData(intStart) <> "" Then    'Nation Code

                    Set TempNames = New ADODB.Recordset
                    TempNames.Open "select ND_ABBR,ND_NAME FROM TempNames where ND_ID= " & strData(intStart) & " ", conn, adOpenDynamic, adLockOptimistic
                    Set names = New ADODB.Recordset
                    names.Open "select VolId,DsetId,SectId,NameItemId,Name,LanCd,SubSeqNr from names1 where NameItemId= " & strData(intStart) & "", conn, adOpenDynamic, adLockOptimistic

                    If TempNames.RecordCount > 0 And names.RecordCount = 0 Then
                        names.AddNew
                        names("VolId") = 1
                        names("DsetId") = 1
                        names("SectId") = 1
                        names("NameItemId") = strData(intStart)
                        names("LanCd") = CStr(TempNames("ND_ABBR"))
                        names("name") = CStr(TempNames("ND_NAME"))
                        names("SubSeqNr") = 1
                        names.Update

                                        ' Setting the values for prepared command for AttributeNames Table
                        cmdAttributesNames("VolId") = 1
                        cmdAttributesNames("DsetId") = 1
                        cmdAttributesNames("SectId") = 1
                        cmdAttributesNames("AttItemId") = strData(0)
                        cmdAttributesNames("AttSqNr") = intcount
                        cmdAttributesNames("NameItemId") = strData(intStart)
                        cmdAttributesNames("SubSeqNr") = 1
                        cmdAttributesNames.Execute   'Executing the prepared command

                    End If
                    TempNames.Close
                    names.Close
                    Set TempNames = Nothing
                    Set names = Nothing

                End If
                If intStart = 13 And strData(intStart) <> "" Then           'Province Code

                    Set TempNames = New ADODB.Recordset
                    TempNames.Open "select ND_NAME,Prov_ABBR FROM TempProvince where Con_ID= " & strData(4) & " and  Prov_ID=" & strData(intStart) & " ", conn, adOpenDynamic, adLockOptimistic
                    Set names = New ADODB.Recordset
                    names.Open "select VolId,DsetId,SectId,NameItemId,Name,Lancd,SubSeqNr from names1 where NameItemId= " & strData(intStart) & "", conn, adOpenDynamic, adLockOptimistic

                    If TempNames.RecordCount > 0 And names.RecordCount = 0 Then
                        names.AddNew
                        names("VolId") = 1
                        names("DsetId") = 1
                        names("SectId") = 1
                        names("NameItemId") = strData(intStart)
                        names("LanCd") = CStr(TempNames("Prov_ABBR"))
                        names("name") = CStr(TempNames("ND_NAME"))
                        names("SubSeqNr") = 1
                        names.Update
                                    ' Setting the values for prepared command for AttributeNames Table
                        cmdAttributesNames("VolId") = 1
                        cmdAttributesNames("DsetId") = 1
                        cmdAttributesNames("SectId") = 1
                        cmdAttributesNames("AttItemId") = strData(0)
                        cmdAttributesNames("AttSqNr") = intcount
                        cmdAttributesNames("NameItemId") = strData(intStart)
                        cmdAttributesNames("SubSeqNr") = 1
                        cmdAttributesNames.Execute    'Executing the prepared command
                    End If
                    TempNames.Close
                    names.Close
                    Set TempNames = Nothing
                    Set names = Nothing

                End If
            End If
        Next

                                ' Setting the values for prepared command for Nodes Table
        cmdNodes("VolId") = 1
        cmdNodes("DsetId") = 1
        cmdNodes("SectId") = 1
        cmdNodes("NdeItemId") = strData(0)
        cmdNodes("XCoord") = strData(1) * 60 * 60 * 1000
        cmdNodes("YCoord") = strData(2) * 60 * 60 * 1000
        cmdNodes.Execute                 'Executing the prepared command

                    ' Setting the values for prepared command for PointFeatures Table
        cmdPoint("VolId") = 1
        cmdPoint("DsetId") = 1
        cmdPoint("SectId") = 1
        cmdPoint("PntItemId") = strData(0)
        cmdPoint("NdeItemId") = strData(0)
        cmdPoint("FeatClass") = strData(3)
        cmdPoint("NrAttSets") = intcount
        cmdPoint.Execute   'Executing the prepared command
Wend
lngRecCounter = 0
lblFileName.Caption = ""
Prgbar.Value = 1
Close #1
conn.Close
Set conn = Nothing

Exit Sub
errhandler:
    'Resume Next
    'conn.RollbackTrans
    Close #1
    MsgBox Err.Number & Err.Description
    Exit Sub
End Sub

Function nodetype(intIndex As Integer) As String
            'Returns Field Type
   Dim strNdtype As String
   On Error GoTo errhandler:
    Select Case intIndex
        Case 3
            strNdtype = "ND_TYPE"
        Case 4
            strNdtype = "ND_NATION"
        Case 5
            strNdtype = "FC"
        Case 6
            strNdtype = "ND_DELETED"
        Case 7
            strNdtype = "ND_ZIP"
        Case 8
            strNdtype = "ND_NAME"
        Case 9
            strNdtype = "ND_NAME_PREFIX"
        Case 10
            strNdtype = "ND_NAME_SUFFIX"
        Case 11
            strNdtype = "ND_NAME_COMP"
        Case 12
            strNdtype = "ND_CODE"
        Case 13
            strNdtype = "ND_PROV"
        Case 14
            strNdtype = "ND_UN_PROV"
        Case 15
            strNdtype = "ND_UN_CITY"
        Case 16
            strNdtype = "ND_UN_CITY_PREFIX"
        Case 17
            strNdtype = "ND_UN_CITY_SUFFIX"
        Case 18
            strNdtype = "ND_UN_CITY_PROV"
        Case 19
            strNdtype = "ND_UN_CITY_COMP"
        Case 20
            strNdtype = "ND_CONURB"
        Case 21
            strNdtype = "ND_CONURB_PREFIX"
        Case 22
            strNdtype = "ND_CONURB_SUFFIX"
        Case 23
            strNdtype = "ND_CONURB_UN_PROV"
        Case 24
            strNdtype = "ND_ID_PERMANENT"
        Case 25
            strNdtype = "ND_DBLINK"
        Case 26
            strNdtype = "ND_KM"
        Case 27
            strNdtype = "ND_TMC"
        Case 28
            strNdtype = "ND_OTHER"

   End Select
       nodetype = strNdtype
   Exit Function
errhandler:
    MsgBox Err.Number & Err.Description
End Function
Function AttValue(intIndex As Integer) As String
                'Returns Node Type
    Dim strattype As String
    On Error GoTo errhandler:
    Select Case intIndex
        Case 0
            strattype = "Standard node"
        Case 1
            strattype = "Junction (exit)"
        Case 2
            strattype = "Intersection"
        Case 3
            strattype = "border node"
        Case 4
            strattype = "ND_ZIP"
        Case 5
            strattype = "toll booth"
        Case 9
            strattype = "ND_NAME_PREFIX"
        Case 11
            strattype = "large city > 500,000"
        Case 12
            strattype = "Medium city > 100,000"
        Case 13
            strattype = "small city > 50,000"
        Case 14
            strattype = "town > 20,000"
        Case 15
            strattype = "village > 5,000"
        Case 16
            strattype = "small village > 1,000"
        Case 17
            strattype = "tiny village < 1,000"
        Case 19
            strattype = "postal code point"

        Case 20
            strattype = "postal code area"
        Case 21
            strattype = "Numbered town district "
        Case 22
            strattype = "town district > 100,000"
        Case 23
            strattype = "town district > 50,000"
        Case 24
            strattype = "town district > 20,000"
        Case 25
            strattype = "town district > 5,000"
        Case 26
            strattype = "town district > 1,000"
        Case 27
            strattype = "ND_KM"
        Case 30
            strattype = "railway station"
        Case 36
            strattype = "car/train terminal"
        Case 40
            strattype = "airport; no information available"
        Case 41
            strattype = "big international airport (>10,000 flights per year)"
        Case 42
            strattype = "Medium international airport (400-10,000 flights per year)"
        Case 43
            strattype = "small international airport (<400 flights per year)"
        Case 46
            strattype = "big national airport (>10,000 flights per year)"
        Case 47
            strattype = "Medium national airport (400 - 10,000 flights per year)"
        Case 48
            strattype = "small national airport (<400 flights per year)"
        Case 80
            strattype = "car/train terminal"
        Case 81
            strattype = "rest area with parking only"
        Case 82
            strattype = "rest area with parking and petrol station"
        Case 83
            strattype = "rest area with parking, petrol station and restaurant"
        Case 84
            strattype = "rest area with parking, petrol station, restaurant and hotel"
        Case 85
            strattype = "rest area with parking, restaurant and hotel"
   End Select
       AttValue = strattype
    Exit Function
errhandler:
    MsgBox Err.Number & Err.Description

End Function

Public Sub OpenSchema()   ''To Get each Table Name from database

    Dim strTabType As String
    Dim rstSchema As ADODB.Recordset
    Dim intcount As Integer

    Set rstSchema = conn.OpenSchema(adSchemaTables)
    ReDim Preserve strTab(rstSchema.RecordCount)

    For intcount = 0 To rstSchema.RecordCount - 1
        strTabType = rstSchema!TABLE_TYPE
        If strTabType = "TABLE" Then
            strTab(intcount) = rstSchema!TABLE_NAME
        End If
        rstSchema.MoveNext

    Next

    rstSchema.Close
    Set rstSchema = Nothing
End Sub

            'To check whethere the table already exists in the database
Function IsTableExists(str As String) As Boolean
    Dim blnFlag As Boolean
    Dim intTabCount As Integer
    For intTabCount = LBound(strTab) To UBound(strTab)
        If (str = strTab(intTabCount)) Then
            blnFlag = True
            IsTableExists = True
            Exit Function
        Else
            blnFlag = False
            IsTableExists = False
        End If
    Next
End Function
'To create tables if they doesn't exists
Private Sub CreateProcedure()

    Dim blnFlag As Boolean
    'To Create PointFeatures Table
    blnFlag = IsTableExists("PointFeatures")  ''To check whethere the PointFeaturestable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = "Create Table PointFeatures(VolId Number,DsetId Number, SectId Number, PntItemId Number,FeatClass Number," & _
        " NdeItemId   Number PRIMARY KEY, NrAttSets Number, DummyFeat Number,MapId Number,WindowLeft Number,WindowBottom Number," & _
        "WindowRight Number,WindowTop Number)"
        conn.Execute str
    End If

    'To Create Nodes Table
    blnFlag = IsTableExists("Nodes")  ''To check whethere the NodesTable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table Nodes(VolId Number,DsetId Number,SectId Number,NdeItemId   Number PRIMARY KEY," & _
        "XCoord Number,YCoord Number,ZCoord Number,FacItemId Number,BrdrStats Number)"
        conn.Execute str
    End If

     'To Create FeatureAttributeReferences1 Table
    blnFlag = IsTableExists("FeatureAttributeReferences1")  ''To check whethere the FeatureAttributeReferences1Table already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table FeatureAttributeReferences1(VolId Number, DsetId Number,SectId Number," & _
        "FeatItemId Number,AttItemId Number,CONSTRAINT FeatItemIdConstraint PRIMARY KEY(FeatItemId,AttItemId))"
        conn.Execute str
    End If

        'To Create Attributes Table
    blnFlag = IsTableExists("Attributes") ''To check whethere the AttributesTable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table Attributes(VolId Number, DsetId Number,SectId Number," & _
        "AttItemId   Number , AttSqNr  Number,AttTyp Text(100),AttValue  Text(200),CONSTRAINT ItemSqConstraint PRIMARY KEY(AttItemId,AttSqNr))"
        conn.Execute str
    End If
    'To Create Names Table
    blnFlag = IsTableExists("Names1")  ''To check whethere the NamesTable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table Names1(VolId Number,DsetId Number,SectId Number," & _
        "NameItemId   Number PRIMARY KEY,SubSeqNr  Number,LanCd Text(100),Name  Text(100))"
        conn.Execute str
    End If

    'To create Attributes Names
    blnFlag = IsTableExists("AttributeNames")  ''To check whethere the AttributeNamesTable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table AttributeNames(VolId Number,DsetId Number,SectId Number," & _
        "AttItemId   Number,AttSqNr Number,NameItemId Number,SubSeqNr  Number," & _
        "PRIMARY KEY(AttItemId,AttSqNr,SubSeqNr))"
        conn.Execute str
    End If

    'To Create TempNames Table
    blnFlag = IsTableExists("TempNames")  ''To check whethere the NamesTable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table TempNames(ND_ID Number PRIMARY KEY,ND_ABBR Text(10),ND_NAME  Text(100))"
        conn.Execute str
    End If
    'To Create TempNames Table
    blnFlag = IsTableExists("TempProvince")  ''To check whethere the NamesTable already exists if it doesn't exists create the Table
    If blnFlag = False Then
        str = " Create Table TempProvince(Con_ID Number,Prov_ID number,Prov_ABBR Text(10),ND_NAME  Text(100),PRIMARY KEY(Con_ID,Prov_ID))"
        conn.Execute str
    End If

    str = "CREATE INDEX idxnodes on attributes (attitemid)"
    conn.Execute str

End Sub
Private Sub CreatePointCmd()

                '***** Prepared command  For FeatureAttributeReferences3 Table

    Set cmdPoint = New ADODB.Command

    cmdPoint.CommandText = "insert into PointFeatures(VolId ,DsetId , SectId , PntItemId ,FeatClass ," & _
        " NdeItemId , NrAttSets) values(?,?,?,?,?,?,?) "
    cmdPoint.CommandType = adCmdText
    cmdPoint.Prepared = True

    Set parmVol = cmdPoint.CreateParameter("VolId", adInteger, adParamInput)
    Set parmDset = cmdPoint.CreateParameter("DsetId", adInteger, adParamInput)
    Set parmSectId = cmdPoint.CreateParameter("SectId", adInteger, adParamInput)
    Set parmPnt = cmdPoint.CreateParameter("PntItemId", adDouble, adParamInput)
    Set parmFeat = cmdPoint.CreateParameter("FeatClass", adInteger, adParamInput)
    Set parmNdeItem = cmdPoint.CreateParameter("NdeItemId", adDouble, adParamInput)
    Set parmNrAtt = cmdPoint.CreateParameter("NrAttSets", adInteger, adParamInput)

    cmdPoint.Parameters.Append parmVol
    cmdPoint.Parameters.Append parmDset
    cmdPoint.Parameters.Append parmSectId
    cmdPoint.Parameters.Append parmPnt
    cmdPoint.Parameters.Append parmFeat
    cmdPoint.Parameters.Append parmNdeItem
    cmdPoint.Parameters.Append parmNrAtt

    cmdPoint.ActiveConnection = conn

End Sub
Private Sub CreateNodesCmd()

                     'Prepared command for Nodes Table
    Set cmdNodes = New ADODB.Command

    cmdNodes.CommandText = "insert into Nodes(VolId ,DsetId , SectId , NdeItemId ,XCoord , YCoord) values(?,?,?,?,?,?) "
    cmdNodes.Prepared = True

    'cmdNodes.Properties("Jet OLEDB:ODBC Pass-Through Statement") = True
    'cmdNodes.Properties("Jet OLEDB:Pass Through Query Connect String") = conn

    cmdNodes.CommandType = adCmdText

    Set parmVol = cmdNodes.CreateParameter("VolId", adInteger, adParamInput)
    Set parmDset = cmdNodes.CreateParameter("DsetId", adInteger, adParamInput)
    Set parmSectId = cmdNodes.CreateParameter("SectId", adInteger, adParamInput)
    Set parmNdeItem = cmdNodes.CreateParameter("NdeItemId", adDouble, adParamInput)
    Set parmXcoord = cmdNodes.CreateParameter("XCoord", adDouble, adParamInput)
    Set parmYcoord = cmdNodes.CreateParameter("YCoord", adDouble, adParamInput)

    cmdNodes.Parameters.Append parmVol
    cmdNodes.Parameters.Append parmDset
    cmdNodes.Parameters.Append parmSectId
    cmdNodes.Parameters.Append parmNdeItem
    cmdNodes.Parameters.Append parmXcoord
    cmdNodes.Parameters.Append parmYcoord

    cmdNodes.ActiveConnection = conn

End Sub

Private Sub CreateFeatCmd()

                    'Prepared command for FeatureAttributeReferences1 Table
    Set cmdFeat = New ADODB.Command

    cmdFeat.CommandText = "insert into FeatureAttributeReferences1(VolId ,DsetId , SectId , FeatItemId ,AttItemId) values(?,?,?,?,?) "
    cmdFeat.CommandType = adCmdText
    cmdFeat.Prepared = True

    Set parmVol = cmdFeat.CreateParameter("VolId", adInteger, adParamInput)
    Set parmDset = cmdFeat.CreateParameter("DsetId", adInteger, adParamInput)
    Set parmSectId = cmdFeat.CreateParameter("SectId", adInteger, adParamInput)
    Set parmFeat = cmdFeat.CreateParameter("FeatItemId", adDouble, adParamInput)
    Set parmAttId = cmdFeat.CreateParameter("AttItemId", adDouble, adParamInput)

    cmdFeat.Parameters.Append parmVol
    cmdFeat.Parameters.Append parmDset
    cmdFeat.Parameters.Append parmSectId
    cmdFeat.Parameters.Append parmFeat
    cmdFeat.Parameters.Append parmAttId

    cmdFeat.ActiveConnection = conn

End Sub

Private Sub CreateAttributesCmd()
        '***** Creating Parameterised Query For Attributes Table

    Set cmdAttributes = New ADODB.Command  ' Create and define command
    'Set cmdAttributes.ActiveConnection = conn

    cmdAttributes.CommandText = "INSERT INTO Attributes(VolId,DsetId,SectId,AttItemId,AttSqNr,AttTyp,AttValue) values(?,?,?,?,?,?,?) "
    cmdAttributes.CommandType = adCmdText
    cmdAttributes.Prepared = True

    Set parmVol = cmdAttributes.CreateParameter("VolId", adInteger, adParamInput)
    Set parmDset = cmdAttributes.CreateParameter("DsetId", adInteger, adParamInput)
    Set parmSectId = cmdAttributes.CreateParameter("SectId", adInteger, adParamInput)
    Set parmAttId = cmdAttributes.CreateParameter("AttItemId", adDouble, adParamInput)
    Set parmAttSqNr = cmdAttributes.CreateParameter("AttSqNr", adInteger, adParamInput)
    Set parmAttTyp = cmdAttributes.CreateParameter("AttTyp", adChar, adParamInput, 129)
    Set parmAttValue = cmdAttributes.CreateParameter("AttValue", adChar, adParamInput, 200)

    cmdAttributes.Parameters.Append parmVol
    cmdAttributes.Parameters.Append parmDset
    cmdAttributes.Parameters.Append parmSectId
    cmdAttributes.Parameters.Append parmAttId
    cmdAttributes.Parameters.Append parmAttSqNr
    cmdAttributes.Parameters.Append parmAttTyp
    cmdAttributes.Parameters.Append parmAttValue

    cmdAttributes.ActiveConnection = conn

End Sub
Private Sub CreateNamesCmd()
    Dim parmVolId As Parameter
    Dim parmDsetId As Parameter
    Dim parmSectId As Parameter
    Dim parmNamItId As Parameter
    Dim parmName As Parameter

                '***** Creating Parameterised Query For names1 Table

    Set cmdNames = New ADODB.Command

    cmdNames.CommandText = "insert into Names1(VolId,DsetId,SectId," & _
   "NameItemId,Name) values(?,?,?,?,?)"
    cmdNames.CommandType = adCmdText
    cmdNames.Prepared = True

    Set parmVolId = cmdNames.CreateParameter("VolId", adInteger, adParamInput)
    Set parmDsetId = cmdNames.CreateParameter("DsetId", adInteger, adParamInput)
    Set parmSectId = cmdNames.CreateParameter("SectId", adInteger, adParamInput)
    Set parmNamItId = cmdNames.CreateParameter("NameItemId", adInteger, adParamInput)
    Set parmName = cmdNames.CreateParameter("Name", adVarChar, adParamInput, 129)

    cmdNames.Parameters.Append parmVolId
    cmdNames.Parameters.Append parmDsetId
    cmdNames.Parameters.Append parmSectId
    cmdNames.Parameters.Append parmNamItId
    cmdNames.Parameters.Append parmName

    cmdNames.ActiveConnection = conn

End Sub

Private Sub CreateTempNamesCmd()
    Dim parmNdId As ADODB.Parameter
    Dim parmNdAbbr As Parameter
    Dim parmNdName As Parameter

                    'Prepared command for TempNames Table
    Set cmdTempNames = New ADODB.Command

    cmdTempNames.CommandText = "insert into TempNames(ND_ID,ND_ABBR,ND_NAME) values(?,?,?)"
    cmdTempNames.CommandType = adCmdText
    cmdTempNames.Prepared = True

    Set parmNdId = cmdTempNames.CreateParameter("ND_ID", adInteger, adParamInput)
    Set parmNdAbbr = cmdTempNames.CreateParameter("ND_ABBR", adVarChar, adParamInput, 129)
    Set parmNdName = cmdTempNames.CreateParameter("ND_NAME", adVarChar, adParamInput, 129)

    cmdTempNames.Parameters.Append parmNdId
    cmdTempNames.Parameters.Append parmNdAbbr
    cmdTempNames.Parameters.Append parmNdName

    cmdTempNames.ActiveConnection = conn

End Sub
Private Sub CreatTempTab()

    Dim parmCounID As Parameter
    Dim parmPrId As Parameter
    Dim parmPrAbbr As Parameter
    Dim parmPrName As Parameter

                'prepared command for TempProvince Table
    Set cmdProvNames = New ADODB.Command

    cmdProvNames.CommandText = "insert into TempProvince(Con_ID,Prov_ID,Prov_ABBR,ND_NAME) values(?,?,?,?)"
    cmdProvNames.CommandType = adCmdText
    cmdProvNames.Prepared = True

    Set parmCounID = cmdProvNames.CreateParameter("Con_ID", adInteger, adParamInput)
    Set parmPrId = cmdProvNames.CreateParameter("Prov_ID", adVarChar, adParamInput, 129)
    Set parmPrAbbr = cmdProvNames.CreateParameter("Prov_ABBR", adVarChar, adParamInput, 129)
    Set parmPrName = cmdProvNames.CreateParameter("ND_NAME", adVarChar, adParamInput, 129)

    cmdProvNames.Parameters.Append parmCounID
    cmdProvNames.Parameters.Append parmPrId
    cmdProvNames.Parameters.Append parmPrAbbr
    cmdProvNames.Parameters.Append parmPrName
    cmdProvNames.ActiveConnection = conn
End Sub

Function ndLevel(level As Integer) As String

    Dim strLevel As String

    Select Case level
        Case 0
            strLevel = "all E-roads in Europe (not seamless)"
        Case 1
            strLevel = "E-roads and important national roads in such a way that all type 10 to 13 locations are connected.  scale ~ 1 : 2,000,000"
        Case 2
            strLevel = "all main roads (on maps usually motor ways and red roads) with secondary roads in such a way that all type 10 to 14 locations are connected. Scale ~ 1 : 1,250,000"
        Case 3
            strLevel = "all through roads in such a way that all type 10 to 15 locations are connected.Scale ~ 1 : 750,000"
        Case 4
            strLevel = "all through and local roads in such a way that all type 10 to 16 and 20 to 26 locations are connected. Every postal code occurs at least once on this level.    Scale ~ 1 : 400,000"
        Case 5
            strLevel = "all roads   Scale > 1 : 400,000"

    End Select
        ndLevel = strLevel
End Function
Private Sub CmdAttNames()
            '***** Creating Prepared command object For AttributeNames Table

    Set cmdAttributesNames = New ADODB.Command  ' Create and define command

    cmdAttributesNames.CommandText = "INSERT INTO AttributeNames(VolId,DsetId,SectId,AttItemId,AttSqNr,NameItemId,SubSeqNr) values(?,?,?,?,?,?,?) "
    cmdAttributesNames.CommandType = adCmdText
    cmdAttributesNames.Prepared = True

    Set parmVol = cmdAttributesNames.CreateParameter("VolId", adInteger, adParamInput)
    Set parmDset = cmdAttributesNames.CreateParameter("DsetId", adInteger, adParamInput)
    Set parmSectId = cmdAttributesNames.CreateParameter("SectId", adInteger, adParamInput)
    Set parmAttId = cmdAttributesNames.CreateParameter("AttItemId", adInteger, adParamInput)
    Set parmAttSqNr = cmdAttributesNames.CreateParameter("AttSqNr", adInteger, adParamInput)
    Set parmAttTyp = cmdAttributesNames.CreateParameter("NameItemId", adInteger, adParamInput)
    Set parmAttValue = cmdAttributesNames.CreateParameter("SubSeqNr", adInteger, adParamInput)

    cmdAttributesNames.Parameters.Append parmVol
    cmdAttributesNames.Parameters.Append parmDset
    cmdAttributesNames.Parameters.Append parmSectId
    cmdAttributesNames.Parameters.Append parmAttId
    cmdAttributesNames.Parameters.Append parmAttSqNr
    cmdAttributesNames.Parameters.Append parmAttTyp
    cmdAttributesNames.Parameters.Append parmAttValue

    cmdAttributesNames.ActiveConnection = conn

End Sub

Sub CreateAccessDatabase(strDBPath As String)
   Dim catNewDB As ADOX.Catalog
   Set catNewDB = New ADOX.Catalog

    catNewDB.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
         "Data Source=" & Dir1.Path & "\" & strDBPath & ".mdb"

   Set catNewDB = Nothing
End Sub

 Private Sub fileExists()
    Dim inti As Integer
    Dim arry() As String
    Dim arr() As String

    ReDim arr(File1.ListCount)
If File1.ListCount = 0 Then
    CmProcess.Enabled = False
    MsgBox "There are no related Files"
    Exit Sub
End If
For inti = 0 To File1.ListCount - 1
    arr(inti) = UCase(File1.List(inti))

    If (arr(inti) = "EUR5.VRT") Or (arr(inti) = "EUR_C.BNA") Or (arr(inti) = "EUR_L.BNA") Or (arr(inti) = "EUR_P.BNA") Or (arr(inti) = "EUR_W.BNA") Or (arr(inti) = "EUR_L.LST") Or (arr(inti) = "EUR5.INT") Or (arr(inti) = "EUR_P3.LST") Or (arr(inti) = "EUR5.SGM") Then
        CmProcess.Enabled = True
    Else
        MsgBox "Some files are Missing"
        CmProcess.Enabled = False

    End If
Next

 End Sub
Private Sub OpenConnection()
    Call CreateAccessDatabase("Globus")  'Creates Globus.mdb Database
    '*********Setting up the connection With out Creating DSN
    Set conn = New ADODB.Connection
    'conn.ConnectionString = "provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & App.Path & "\Globus.mdb"
    conn.ConnectionString = "provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & Dir1.Path & "\Globus.mdb"
    conn.CursorLocation = adUseClient
    conn.Open
End Sub

*** Sent via Developersdex http://www.*-*-*.com/ ***
Don't just participate in USENET...get rewarded for it!