Export Table Records One at a time to Text File 3

[tristap]

Need some help please!....

Previous developer wrote the below code which now does not work as we have upgraded to XP and now have MS Access 2003. Basically the routine outputs one record at a time to a text file with fixed field lengths, while also formatting the table fields. I also have to incorporate two carriage return lines in between each record in the text file.

Bit of a novice at VBA and would appreciate and help to rewrite to function in MS Access 2003.


Private Sub Form_Load()
On Error Resume Next

'DoCmd.Hourglass True
Dim sFileName As String
Dim db As Database
Dim RS As Recordset
Dim fs As Scripting.FileSystemObject
Dim f As Scripting.TextStream
Dim newcnt As Integer
Set db = CurrentDb

cnt = 0

sqlstr = "SELECT id, sContact, sContactNo, sRCN, " & _
"sProdFolder , sAccount, sStmtEnd, sStmtNo, " & _
"dCreated, dSent, dComplete, dFailed, " & _
"sPostal1, sPostal2, sAddr1, sAddr2, " & _
"sSuburb, sState, sPostCode, sCustFax, " & _
"sFaxName, iFee, sWaiverInd, sStmtStart, " & _
"sReasonCode, sDebitAccount FROM dbo_dOnDemand WHERE dSent is Null ORDER BY sProdFolder;"

Set fs = New FileSystemObject
sFileName = "TJPORD" & Format(Date, "DDMMYYYY") & ".txt"

Set f = fs.CreateTextFile("\\server\ftp\" & sFileName, True)
Set RS = db.OpenRecordset(sqlstr, dbOpenDynaset, dbSeeChanges)

' Write the header data
s = s & "A"
s = s & Format(Date, "DDMMYYYY")
s = s & AddSpace("EFORM", 8)
s = s & "TJP"
s = s & AddSpace("My File", 60)
s = s & Space(221)
f.WriteLine (s)

Do While Not RS.EOF
cnt = cnt + 1

s = "R"
s = s & "TJP" & AddSpace(RS("sProdFolder").Value, 3)
s = s & AddSpace(RS("sAccount").Value, 16)
Dim sEnd
sEnd = RS("sStmtEnd").Value
s = s & AddSpace(sEnd, 8)
s = s & AddSpace(RS("sStmtNo").Value, 4)
s = s & "P"
If RS("sAddr1").Value <> "" Then
s = s & "N"
Else
s = s & "Y"
End If
s = s & AddSpace(UCase(RS("sPostal1").Value), 40)
s = s & AddSpace(UCase(RS("sPostal2").Value), 40)
s = s & AddSpace(UCase(RS("sAddr1").Value), 40)
s = s & AddSpace(UCase(RS("sAddr2").Value), 40)
Dim myAdd
myAdd = UCase(RS("sSuburb").Value) & " " & UCase(RS("sState").Value) & " " & RS("sPostCode").Value
s = s & AddSpace(myAdd, 40)
s = s & AddSpace(RS("sContactNo").Value, 10)
s = s & AddSpace(Left(RS("sContact").Value, 17), 17) & AddSpace(RS("sDebitAccount").Value, 16)
Dim sStart
sStart = RS("sStmtStart").Value
s = s & AddSpace(sStart, 8)
s = s & AddSpace(RS("sWaiverInd").Value, 1)
If UCase(RS("sWaiverInd").Value) = "N" Then
s = s & Space(2)
Else
s = s & AddSpace(RS("sReasonCode").Value, 2)
End If
s = s & AddSpace(RS("sRCN").Value, 7)
s = s & Space(3)

RS.Edit
RS![dSent] = Now()
RS.Update

f.WriteLine s
RS.MoveNext
Loop

'Write the trailer data
s = "T"
s = s & Format(Date, "DDMMYYYY")
s = s & AddSpace("FORM", 8)
s = s & "CBA"
s = s & AddSpace("My File", 60)
s = s & AddSpace(cnt, 7) '& record count = 7
s = s & Space(214)
f.WriteLine s

f.Close
Set f = Nothing
Set fs = Nothing
DoCmd.Hourglass False

DoCmd.Quit acQuitSaveNone
End Sub


Function AddSpace(sField, sLen) As String

If Len(sField) >= sLen Then
AddSpace = Left(sField, sLen)
Else
If IsNull(Len(sField)) Then
AddSpace = Space(sLen)
Else
AddSpace = sField & Space(sLen - Len(sField))
End If
End If

End Function

 

[mp9]

With regard to appending two carriage returns, append & vbCrLf & vbCrLf to the last bit of the string-building, i.e. s = s & "blah blah" & vbCrLf & vbCrLf

With regard to the code not working, at what point does it fall over? And with what error message?

http://www22.brinkster.com/accessory/

 

[tristap]

It falls over at at:

Dim fs As Scripting.FileSystemObject

Error message is displayed:
Compile Error: User-Defined type not defined

 

[JerryKlmns]

Check in the Tools-->References if there is a MISSING word infront of Microsoft Scripting Runtime. If true unselect it. Close and open the references form and select it again.

 

[tristap]

Checked in Tools-->References and no missing word but Microsoft Runtime was not checked, I have now checked this box and I get no error message now, however when I run it I just get the hourglass ie. seems to be endlessly looping.

There is only 184 records in the table so should not take an excessive amount of time.

When I debug the code , the string-building section, i.e. s = s & etc is coming up as null ie. "" and the RS variable says it equals "Nothing".

Any suggestions on what is now wrong?

 

[RoyVidar]

Never use On Error Resume Next in production code without checking errors per each line that can trigger an error.

Try implementing some minimum errorhandling in stead. In the mean time, remove the on error resume next line, to make it stop at the line providing the error.

One quess are the declarations

[tt] Dim db As dao.Database
Dim RS As dao.Recordset[/tt]

Roy-Vidar

 

[tristap]

Took out "On Error Resume Next" and set declarations as suggested with dao but getting the below error message on the "Set RS = db.OpenRecordset(sqlstr, dbOpenDynaset, dbSeeChanges)" line:

Run-time error '3061':
Too few parameters. Expected 2.

Please advise!

 

[RoyVidar]

Says it's probably something wrong with your SQL statement. Do a debug.print sqlstr after you've assigned it. Then study it from the immediate pane ctrl+g and see if you can find any errors. You should also be able to copy it to the sql view of the QBE, and it should run.

For the open statement, try without any options first, i e

[tt]...db.OpenRecordset(sqlstr)[/tt]

Roy-Vidar

 

[JerryKlmns]

You could rewritte the function as

Function AddSpace(sField, sLen) As String

AddSpace = Left(sField & Space(sLen), sLen)

End Function

but if you run this on a live production enviroment and you start the process, until you get to .EOF if there is a new entry the .eof goes +1 record away. Then a new entry and so forth... When is this supposed to stop?
Is it supposed to work as a log file of a day? If so, keep the records on a table and run this code when db is closed.

I would recomend to open the recordset as dbOpenSnapshot, dbReadOnly.

 

[tristap]

Success! It now works!

To: mp9, RoyVidar & JerryKlms
All 3 of you have contributed to the resolution of my issue - many many thanks! It is very much appreciated and has saved me tones of heartache.

I have given you all a star!

Kindest Regards
Tristap

 

[JerryKlmns]

tristap,

since your are now happy, would you post where & what was the problem? Maybe someone else bumps into the same one!

Thanx for the star.