runtime error 3021

[birtcher]

I am trying to run the following code without writing to the end of the file. I have tried several different ways of recoding the section where it still creates a file with substituted part numbers. Unfortunately I have not had any success in figuring this out and thought that I would ask others who are more experienced.

 On Error GoTo ErrorTrap
     
   Dim cn As ADODB.Connection
   Dim r As ADODB.Recordset
   Dim rNRC As ADODB.Recordset
   Dim strIn As String
   Dim strTemp As String
   Dim lRecords As Long
   Dim lDups As Long
   Dim lSubs As Long
   Dim strFilename As String
   Dim lEveryRec As Long
   Dim strSubFile As String
   Dim strPrimaryCorePartNbr As String
   Dim fPRT As String
   Dim iCores As Long
   Dim bNew As Boolean
   Dim strNew As String
   Dim strLastPartNbr As String
   Dim strCore As String
   Dim iThis As Long
   Dim strCores() As String
   Dim fPartNbr As String
   Dim strReman As String
   Dim strHoldNew As String
   Dim strHoldReman As String
   Dim fPK As Integer
   
   lEveryRec = Val(GetSetting("PBC", "Options", "Records", "100"))

   Set cn = New ADODB.Connection
   cn.Open Connection_Pricebook
   Set r = New ADODB.Recordset
   r.Open "PriceBook" & gstrCode, cn, adOpenDynamic, adLockOptimistic, adCmdTableDirect
   r.Index = "PrimaryKey"

 lRecords = 0
   lDups = 0
   lSubs = 0

strSubFile = gstrImportPath & "\subs.txt"
   Open strSubFile For Output As #2
   
   strFilename = Dir(gstrVendorTextFile)
   Do While strFilename <> ""
      frmConvert.Caption = "Importing " & strFilename
      gstrVendorTextFile = gstrImportPath & "\" & strFilename
      Open gstrVendorTextFile For Input As #1
      
      ' skip first line
      Line Input #1, strIn
      
      Do While Not EOF(1) And Not gbCancel
         Line Input #1, strIn
         If Len(strIn) Then
            If Trim(Mid(strIn, 116, 25)) <> "" Then
Print #2, Mid(strIn, 116, 25) & Mid(strIn, 1, 25)
            End If
            If Left(strIn, 25) = bNoMoreLines Then
            If bNoMoreLines Then
               fPartNbr = "last part"
            Else
               fPartNbr = RTrim(Mid(strIn, 1, 25))
            End If
            If strLastPartNbr <> fPartNbr Then
               If strLastPartNbr <> "" Then
                   'Update records
                  If fPK < 1 Then fPK = 1
  With r
               .AddNew
                 ' new format on 6/27/05 effective date
               ' longer field lengths
               .Fields!RTYPE = "1"
               .Fields!PartNbr = RTrim(Mid(strIn, 1, 20))
               If .Fields!PartNbr = RTrim(Mid(strIn, 1, 25)) Then
               .Fields!PRT = "N"
               End If
               If .Fields!PRT = "N" Then
               fPRT = "N"
               End If
               If Val(Mid(strIn, 85, 8)) = 0 Then
               .Fields!PartNbr = RTrim(Mid(strIn, 1, 25))
               Else
               .Fields!PartNbr = RTrim(Mid(strIn, 1, 25))
               End If
               If .Fields!PartNbr = RTrim(Mid(strIn, 1, 25)) & "N" Then
               .Fields!PRT = "N"
               End If
               .Fields!AltPartNbr = CAStr(.Fields!PartNbr)
               .Fields!PartNbrA = AStr(.Fields!PartNbr)
               .Fields!Replacement = ""
               .Fields!Description = RTrim(Mid(strIn, 33, 12))
               .Fields!PK = Val(Mid(strIn, 111, 5))
               If .Fields!PK < 1 Then .Fields!PK = 1
               .Fields!Price = (Val(Mid(strIn, 53, 8)) / 100) * .Fields!PK
               .Fields!Cost = (Val(Mid(strIn, 77, 8)) / 100) * .Fields!PK
               .Fields!CostEach = Val(Mid(strIn, 77, 8)) / 100
              ' .Fields!Misc = Trim(Mid(strIn, 131, 1))
              ' If .Fields!Misc = "" Then
               If Val(Mid(strIn, 85, 8)) = 0 Then
               .Fields!Misc = "N"
            Else
               .Fields!Misc = "R"
               .Fields!PRT = "R"
             '  End If
                End If
               If gstrCode = "NV1" Then
                  .Fields!CostEach = (Val(Mid(strIn, 77, 8)) / 100) * 1.1
                  .Fields!Cost = .Fields!CostEach
                .Fields!RCODE = Mid(strIn, 100, 1)
               .Fields!r = Mid(strIn, 100, 1)
               .Fields!C = Trim(UCase(Mid(strIn, 93, 7)))
               .Fields!C = Replace(.Fields!C, " ", "-", , , vbBinaryCompare)
               
               '.Fields!M = Trim(UCase(Mid(strIn, 91, 3)))
               ' no equivalent found on new format
               ' but using DCN code which has chars
               .Fields!M = RTrim(Mid(strIn, 101, 3))
               
              ' strTemp = Replace(Trim(Mid(strIn, 85, 8)), "0", "", , , vbBinaryCompare)
              ' If strTemp <> "" Then
              '    .Fields!P = "ALERT:CORE=" & Val(Mid(strIn, 85, 8))
             '  End If
               
               .Fields!Weight = Round(Val(Mid(strIn, 164, 8)) / 1000, 2)  ' new starting 6/27/05
               .Update
               End If
            End With
        
          
        With r
          .Seek Array(RTrim(Left(strIn, 25)), ""), adSeekFirstEQ
        If Val(Mid(strIn, 85, 8)) > 0 Then
          .AddNew
          .Fields!RTYPE = "1"
          .Fields!PRT = fPRT
          .Fields!PartNbr = RTrim(Mid(strIn, 1, 25)) & "CR"
          .Fields!AltPartNbr = CAStr(.Fields!PartNbr)
          .Fields!PartNbrA = AStr(.Fields!PartNbr)
          .Fields!Replacement = ""
          .Fields!Description = RTrim(Mid(strIn, 33, 12)) & " (CORE)"
          .Fields!Misc = RTrim(Mid(strIn, 131, 1))
          'If RTrim(Mid(strIn, 132, 2)) = "" Then
          .Fields!Misc = "C"
          .Fields!Price = (Val(Mid(strIn, 85, 8)) / 100)
          .Fields!Cost = (Val(Mid(strIn, 85, 8)) / 100)
          .Fields!CostEach = (Val(Mid(strIn, 85, 8)) / 100)
          .Fields!PK = Val(Mid(strIn, 111, 5))
               If .Fields!PK < 1 Then .Fields!PK = 1
          .Fields!P = "ALERT:CORE=" & Val(Mid(strIn, 85, 8))
          If .Fields!P = "ALERT:CORE=" & Val(Mid(strIn, 85, 8)) Then
             .Fields!PRT = "C"
         End If
         If .Fields!PRT = "C" Then
         fPRT = "C"
         End If
          .Update
          ' End If
            End If
            End With
         
        
        lRecords = lRecords + 1
         If (lRecords Mod lEveryRec) = 0 Then
            frmConvert.lblPart.Caption = Format(lRecords)
            frmConvert.lblPart.Refresh
            DoEvents  ' check for cancel button
            Sleep gSleep
         End If
          
      Loop
      
      Close #1
      strFilename = Dir
   Loop
   
   frmConvert.Caption = "Processing Subs..."   THIS IS WHERE I GET THE ERROR
   Close #2
   Open strSubFile For Input As #2
   Do While Not EOF(2) And Not gbCancel
      Line Input #2, strIn
      If Len(strIn) Then
         
         lSubs = lSubs + 1
         If (lSubs Mod lEveryRec) = 0 Then
            frmConvert.lblPart.Caption = Format(lSubs)
            frmConvert.lblPart.Refresh
            DoEvents  ' check for cancel button
            Sleep gSleep
         End If
          
         With r
            .Seek Array(RTrim(Left(strIn, 25)), ""), adSeekFirstEQ
            If .EOF = False Then 'try If bNew Then here for NRC Type coding'''''''
               .Fields!RTYPE = "2"
               .Fields!Replacement = RTrim(Mid(strIn, 26, 25))
               .Fields!QtyReplaced = 1
               .Fields!Description = "Replaced"
               .Update
            Else
               .AddNew
               .Fields!RTYPE = "1"
               .Fields!PartNbr = RTrim(Left(strIn, 25))
               .Fields!AltPartNbr = CAStr(.Fields!PartNbr)
               .Fields!PartNbrA = AStr(.Fields!PartNbr)
               .Fields!Replacement = RTrim(Mid(strIn, 26, 25))
               .Fields!Description = "Added"
               .Fields!Misc = "N"
               .Fields!PRT = "N"
               .Fields!QtyReplaced = 1
               .Fields!Cost = 0
               .Fields!CostEach = 0
               .Fields!Price = 0
               .Fields!PK = 1
               .Update
            End If
         End With
      End If

    
      
   Loop
   Close #2
    
   r.Close
   cn.Close
   Set r = Nothing
   Set cn = Nothing
   
   
  
   
   frmConvert.lblPart.Caption = Format(lRecords)
   frmConvert.cmdCancel.Caption = "Close"
   
   Exit Sub

[Hack]

I don't even need to look this error up. A 3021 is an "Either BOF or EOF is True" error, and I know that because I've gotten this error about a zillion times.

However, I have never seen this error generated by nothing more than attempting to set a forms caption. I would challenge this

frmConvert.Caption = "Processing Subs..."   THIS IS WHERE I GET THE ERROR

There is no file involved in setting a caption, so this error has to be coming from somewhere else.

[birtcher]

I have 2 files that I import into a database. While it importing these files it looks for part numbers that are replaced by another part number and it gets all these replaced part numbers are put into another file and then it gets that file and imports where it processes the replace part numbers into the database the error comes up.

[Hack]

So, stop the code just before it goes into the database, and look inside the file that it is supposed to be importing. Are there any records?

[birtcher]

I looked into the sub file that it creates and it does list all the parts that have parts that are substituted. Then I looked into the database for these replaced parts and it shows up in the database as a replaced part number.