Code:
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
Reply With Quote