S
Scott Burke
I have 3 computers. This program works fine on two computer but NOT on one.
computer1 = does not work
computer2 = works
computer3 = works
I wont to start by saying that the code (below) worked perfectly untill we
hit XP. Then I had to start using the FreeFile command. Now things just
don't seem to work.
The Big problem:
The code generates a file on disk.
When computer 1 generates the file it looks like this:
Record1
Record2
Record3
When computers 2 & 3 generates the file it looks llike this:
Record1
Record2
Record3
It is the same code!!!!!!!! Why am I getting two different outputs!
The code below is the code in question:
Rem This function will save the tables to SDF format on the A: drive.
Function save_all(thename As String, thetotal As Long, TheDate As Date, _
thefile As String, DateType As String)
On Error GoTo save_all_error
Dim Db As DAO.Database
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim work1 As String
Dim disknum As Double
Dim i As Long
Dim strMsg As String
Dim progMeter As Variant
Dim rec_count As Long
Dim disk_count As Long
Dim intRecCount As Integer
Dim Response
Dim IntFile As Integer
DoCmd.Hourglass True
Set Db = CurrentDb()
Set rs = Db.OpenRecordset(thename)
Rem Set up working varibles.
work1 = Space(1)
disknum = 0
disk_count = 1
Rem Move to top of recordset
rs.MoveLast
rs.MoveFirst
Rem Setup the program meter!
rec_count = 1
progMeter = SysCmd(acSysCmdInitMeter, "Creating Disk ", rs.RecordCount)
Rem Close any thing that maybe open in channel #1
'Close #1
Rem Give the user the information they will need.
intRecCount = DCount("*", thename)
disknum = intRecCount / thetotal
If Not disknum = Int(disknum) Then
disknum = Int(disknum) + 1
End If
DoCmd.Hourglass False
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Creating Agent Disk " & Trim(thefile) & Chr(13) &
Chr(10)
strMsg = strMsg & Chr(13) & Chr(10)
strMsg = strMsg & "Total Records: " & intRecCount & Chr(13) & Chr(10)
strMsg = strMsg & Chr(13) & Chr(10)
strMsg = strMsg & "You will need ( " & Trim(Str(disknum)) & " ) disks
for creating "
strMsg = strMsg & "this disk."
strMsg = strMsg & Chr(13) & Chr(10)
Response = MsgBox(strMsg, vbOKCancel, "Clearance Message")
DoCmd.Hourglass True
If Response = vbCancel Then
rs.Close
Set rs = Nothing
Db.Close
Set Db = Nothing
Exit Function
End If
Do While Not rs.EOF And Response <> vbCancel
Rem Open the work file in channel #1
If disk_count = 1 Then
work1 = Trim(thefile)
Else
work1 = Mid(thefile, 1, Len(thefile) - 4) &
Trim(Str(disk_count)) + _
Right(thefile, 4)
End If
disk_count = disk_count + 1
Rem XP does not like to use #1
Rem That is why YOU dont use it.
IntFile = FreeFile()
Close IntFile
Open work1 For Output As IntFile
'Open work1 For Output As #1
For i = 1 To thetotal
Rem Check for EOF
If Not rs.EOF Then
Rem lets do it!!!
work1 = Space(0)
For Each fld In rs.Fields
Rem To be 100% correct... You must check for all
Rem field types. However, My export files use
Rem TEXT and Date field types only.
If IsNull(fld.Value) Then
work1 = work1 & sizestr(fld.Value, fld.Size)
Else
If fld.Type = dbDate Then
work1 = work1 & sizedate(fld.Value, DateType)
Else
work1 = work1 & sizestr(fld.Value, fld.Size)
End If
End If
Next fld
work1 = Mid(work1, 1, Len(work1) - 2)
'Print #1, work1
Print #IntFile, work1
rs.MoveNext
work1 = ""
Else
Rem If EOF is reached then end the loop.
i = thetotal
End If
Rem Update the program meter.
rec_count = rec_count + 1
'progMeter = SysCmd(acSysCmdUpdateMeter, rec_count)
Next
If Not rs.EOF Then
'Close #1
Close IntFile
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Please put another Disk in Drive A:\."
strMsg = strMsg & Chr(13) & Chr(10)
Response = MsgBox(strMsg, vbOKCancel, "Save File")
End If
If rs.EOF Then
'Close #1
Close IntFile
End If
Loop
Rem Clear the program meter.
progMeter = SysCmd(acSysCmdClearStatus)
DoCmd.Hourglass False
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Files are done copying."
strMsg = strMsg & Chr(13) & Chr(10)
MsgBox strMsg, vbOKOnly, "Finished"
rs.Close
Set rs = Nothing
Db.Close
Set Db = Nothing
Rem exit function to avoid running the error code:
Exit Function
save_all_error:
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "There was an error. "
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Try again and use an other disk."
strMsg = strMsg & Chr(13) & Chr(10)
MsgBox strMsg, vbOKOnly, "Error"
DoCmd.Hourglass False
End Function
computer1 = does not work
computer2 = works
computer3 = works
I wont to start by saying that the code (below) worked perfectly untill we
hit XP. Then I had to start using the FreeFile command. Now things just
don't seem to work.
The Big problem:
The code generates a file on disk.
When computer 1 generates the file it looks like this:
Record1
Record2
Record3
When computers 2 & 3 generates the file it looks llike this:
Record1
Record2
Record3
It is the same code!!!!!!!! Why am I getting two different outputs!
The code below is the code in question:
Rem This function will save the tables to SDF format on the A: drive.
Function save_all(thename As String, thetotal As Long, TheDate As Date, _
thefile As String, DateType As String)
On Error GoTo save_all_error
Dim Db As DAO.Database
Dim rs As DAO.Recordset
Dim fld As DAO.Field
Dim work1 As String
Dim disknum As Double
Dim i As Long
Dim strMsg As String
Dim progMeter As Variant
Dim rec_count As Long
Dim disk_count As Long
Dim intRecCount As Integer
Dim Response
Dim IntFile As Integer
DoCmd.Hourglass True
Set Db = CurrentDb()
Set rs = Db.OpenRecordset(thename)
Rem Set up working varibles.
work1 = Space(1)
disknum = 0
disk_count = 1
Rem Move to top of recordset
rs.MoveLast
rs.MoveFirst
Rem Setup the program meter!
rec_count = 1
progMeter = SysCmd(acSysCmdInitMeter, "Creating Disk ", rs.RecordCount)
Rem Close any thing that maybe open in channel #1
'Close #1
Rem Give the user the information they will need.
intRecCount = DCount("*", thename)
disknum = intRecCount / thetotal
If Not disknum = Int(disknum) Then
disknum = Int(disknum) + 1
End If
DoCmd.Hourglass False
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Creating Agent Disk " & Trim(thefile) & Chr(13) &
Chr(10)
strMsg = strMsg & Chr(13) & Chr(10)
strMsg = strMsg & "Total Records: " & intRecCount & Chr(13) & Chr(10)
strMsg = strMsg & Chr(13) & Chr(10)
strMsg = strMsg & "You will need ( " & Trim(Str(disknum)) & " ) disks
for creating "
strMsg = strMsg & "this disk."
strMsg = strMsg & Chr(13) & Chr(10)
Response = MsgBox(strMsg, vbOKCancel, "Clearance Message")
DoCmd.Hourglass True
If Response = vbCancel Then
rs.Close
Set rs = Nothing
Db.Close
Set Db = Nothing
Exit Function
End If
Do While Not rs.EOF And Response <> vbCancel
Rem Open the work file in channel #1
If disk_count = 1 Then
work1 = Trim(thefile)
Else
work1 = Mid(thefile, 1, Len(thefile) - 4) &
Trim(Str(disk_count)) + _
Right(thefile, 4)
End If
disk_count = disk_count + 1
Rem XP does not like to use #1
Rem That is why YOU dont use it.
IntFile = FreeFile()
Close IntFile
Open work1 For Output As IntFile
'Open work1 For Output As #1
For i = 1 To thetotal
Rem Check for EOF
If Not rs.EOF Then
Rem lets do it!!!
work1 = Space(0)
For Each fld In rs.Fields
Rem To be 100% correct... You must check for all
Rem field types. However, My export files use
Rem TEXT and Date field types only.
If IsNull(fld.Value) Then
work1 = work1 & sizestr(fld.Value, fld.Size)
Else
If fld.Type = dbDate Then
work1 = work1 & sizedate(fld.Value, DateType)
Else
work1 = work1 & sizestr(fld.Value, fld.Size)
End If
End If
Next fld
work1 = Mid(work1, 1, Len(work1) - 2)
'Print #1, work1
Print #IntFile, work1
rs.MoveNext
work1 = ""
Else
Rem If EOF is reached then end the loop.
i = thetotal
End If
Rem Update the program meter.
rec_count = rec_count + 1
'progMeter = SysCmd(acSysCmdUpdateMeter, rec_count)
Next
If Not rs.EOF Then
'Close #1
Close IntFile
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Please put another Disk in Drive A:\."
strMsg = strMsg & Chr(13) & Chr(10)
Response = MsgBox(strMsg, vbOKCancel, "Save File")
End If
If rs.EOF Then
'Close #1
Close IntFile
End If
Loop
Rem Clear the program meter.
progMeter = SysCmd(acSysCmdClearStatus)
DoCmd.Hourglass False
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Files are done copying."
strMsg = strMsg & Chr(13) & Chr(10)
MsgBox strMsg, vbOKOnly, "Finished"
rs.Close
Set rs = Nothing
Db.Close
Set Db = Nothing
Rem exit function to avoid running the error code:
Exit Function
save_all_error:
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "There was an error. "
strMsg = Chr(13) & Chr(10)
strMsg = strMsg & "Try again and use an other disk."
strMsg = strMsg & Chr(13) & Chr(10)
MsgBox strMsg, vbOKOnly, "Error"
DoCmd.Hourglass False
End Function