I have two different TransposeToTxt functions, that I can save individually using a FileDialog prompt, they are saved to a specific format. However I need to get them into the same file, so that the second one just follows the first one.
Option Compare Database
Option Explicit
Public Function fnTransposeToTxt()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim fd As DAO.Field
Dim fnum As Integer
Dim path As String
Dim OK As Boolean
Dim var As Variant
' export to this file
path = FilToSave
fnum = FreeFile
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("VBK_Knude", dbOpenSnapshot, dbReadOnly)
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
OK = True
Open path For Output As fnum
End If
Do Until .EOF
For Each fd In .Fields
var = fd.Value
Select Case fd.Name
Case "AFLKOEF"
var = Format$(var, "0.0")
var = Replace(var, ",", ".")
Case "XY", "TEXTXY", "Z_F", "DYBDE", "OB", "PERPEND", "Q", "STATION", "PERPEND", "AFSTRØM"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
Case "DIMENSION"
var = Format$(var, "0.000")
var = Replace(var, ",", ".")
Case "OPLAND"
var = Format$(var, "0.0000")
var = Replace(var, ",", ".")
End Select
Print #fnum, fd.Name & " " & var
Next
.MoveNext
If Not (.EOF) Then
Print #fnum, ""
End If
Loop
.Close
End With
Set rst = Nothing
Set dbs = Nothing
If OK Then
Close #fnum
MsgBox "table imported to " & path
End If
End Function
Second function:
Option Compare Database
Option Explicit
Public Function fnTransposeToTxt()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim fd As DAO.Field
Dim fnum As Integer
Dim path As String
Dim OK As Boolean
Dim var As Variant
Dim foundXY As Boolean
' export to this file
path = FilToSave
fnum = FreeFile
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("VBK_Ledning", dbOpenSnapshot, dbReadOnly)
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
OK = True
Open path For Output As fnum
End If
Do Until .EOF
foundXY = False
For Each fd In .Fields
var = fd.Value
Select Case fd.Name
Case "AFLKOEF", "FALD", "MANNING", "ACCU_Q"
var = Format$(var, "0.0")
var = Replace(var, ",", ".")
Case "XY", "TEXTXY", "FRA_Z", "TIL_Z", "LÆNGDE", "PERPEND", "REDUKTION", "EXTRA_OB", "PERPEND", "AFSTRØM"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
If fd.Name = "XY" Then
foundXY = True
End If
Case "DIMENSION"
var = Format$(var, "0")
var = Replace(var, ",", ".")
Case "XY1"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
If foundXY Then
Print #fnum, "XY " & var
Else
Print #fnum, "XY"
foundXY = True
End If
End Select
If fd.Name <> "XY1" Then
Print #fnum, fd.Name & " " & var
End If
Next
.MoveNext
If Not (.EOF) Then
Print #fnum, ""
End If
Loop
.Close
End With
Set rst = Nothing
Set dbs = Nothing
If OK Then
Close #fnum
MsgBox "table imported to " & path
End If
End Function
I've tried a few different solutions, but keep either getting a File is Open error or BadName error with my tries:
Option Compare Database
Option Explicit
Public Function ExportToTxt()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim fd As DAO.Field
Dim fnum As Integer
Dim path As String
Dim OK As Boolean
Dim var As Variant
Dim foundXY As Boolean
Dim ff As Long
' export to this file
path = FilToSave
fnum = FreeFile
Set dbs = CurrentDb
' open recordset for table VBK_Knude
Set rst = dbs.OpenRecordset("VBK_Knude", dbOpenSnapshot, dbReadOnly)
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
OK = True
Open path For Output As fnum
Do Until .EOF
For Each fd In .Fields
var = fd.Value
Select Case fd.Name
Case "AFLKOEF"
var = Format$(var, "0.0")
var = Replace(var, ",", ".")
Case "XY", "TEXTXY", "Z_F", "DYBDE", "OB", "PERPEND", "Q", "STATION", "AFSTRØM" ' Removed duplicate "PERPEND" case
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
Case "DIMENSION"
var = Format$(var, "0.000")
var = Replace(var, ",", ".")
Case "OPLAND"
var = Format$(var, "0.0000")
var = Replace(var, ",", ".")
End Select
Print #fnum, fd.Name & " " & var
Next
.MoveNext
If Not (.EOF) Then
Print #fnum, ""
End If
Loop
End If
.Close
End With
' open recordset for table VBK_Ledning
Set rst = dbs.OpenRecordset("VBK_Ledning", dbOpenSnapshot, dbReadOnly)
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
OK = True
' check if file is already open
ff = FreeFile
On Error Resume Next
Open path For Append Access Write Lock Write As #ff
If Err.Number = 70 Then ' file is already open
Close #ff
OK = False
MsgBox "File " & path & " is already open. Please close the file and try again."
Exit Function
End If
On Error GoTo 0
' append to file opened earlier
Do Until .EOF
foundXY = False
For Each fd In .Fields
var = fd.Value
Select Case fd.Name
Case "AFLKOEF", "FALD", "MANNING", "ACCU_Q"
var = Format$(var, "0.0")
var = Replace(var, ",", ".")
Case "XY", "TEXTXY", "FRA_Z", "TIL_Z", "LÆNGDE", "PERPEND", "REDUKTION", "EXTRA_OB", "AFSTRØM" ' Removed duplicate "PERPEND" case
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
If fd.Name = "XY" Then
foundXY = True
End If
Case "DIMENSION"
var = Format$(var, "0")
var = Replace(var, ",", ".")
Case "XY1"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
If foundXY Then
Print #fnum, "XY " & var
Else
Print #fnum, "XY"
foundXY = True
End If ' Add this line
End Select
If fd.Name <> "XY1" Then
Print #fnum, fd.Name & " " & var
End If
Next
.MoveNext
If Not (.EOF) Then
Print #fnum, ""
End If
' close the file before opening it again
Close #fnum
Loop
End If
.Close
End With
Set rst = Nothing
Set dbs = Nothing
If OK Then
Close #fnum
MsgBox "table imported to " & path
End If
End Function
How about just excluding the first closure of the file to leave it open, and then continue with the second recordset:
Option Compare Database
Option Explicit
Public Function fnTransposeToTxt()
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim fd As DAO.Field
Dim fnum As Integer
Dim path As String
Dim OK As Boolean
Dim var As Variant
' export to this file
path = FilToSave
fnum = FreeFile
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("VBK_Knude", dbOpenSnapshot, dbReadOnly)
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
OK = True
Open path For Output As fnum
End If
Do Until .EOF
For Each fd In .Fields
var = fd.Value
Select Case fd.Name
Case "AFLKOEF"
var = Format$(var, "0.0")
var = Replace(var, ",", ".")
Case "XY", "TEXTXY", "Z_F", "DYBDE", "OB", "PERPEND", "Q", "STATION", "PERPEND", "AFSTRØM"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
Case "DIMENSION"
var = Format$(var, "0.000")
var = Replace(var, ",", ".")
Case "OPLAND"
var = Format$(var, "0.0000")
var = Replace(var, ",", ".")
End Select
Print #fnum, fd.Name & " " & var
Next
.MoveNext
If Not (.EOF) Then
Print #fnum, ""
End If
Loop
.Close
End With
Set rst = dbs.OpenRecordset("VBK_Ledning", dbOpenSnapshot, dbReadOnly)
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
OK = True
End If
Do Until .EOF
foundXY = False
For Each fd In .Fields
var = fd.Value
Select Case fd.Name
Case "AFLKOEF", "FALD", "MANNING", "ACCU_Q"
var = Format$(var, "0.0")
var = Replace(var, ",", ".")
Case "XY", "TEXTXY", "FRA_Z", "TIL_Z", "LÆNGDE", "PERPEND", "REDUKTION", "EXTRA_OB", "PERPEND", "AFSTRØM"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
If fd.Name = "XY" Then
foundXY = True
End If
Case "DIMENSION"
var = Format$(var, "0")
var = Replace(var, ",", ".")
Case "XY1"
var = Format$(var, "0.00")
var = Replace(var, ",", ".")
If foundXY Then
Print #fnum, "XY " & var
Else
Print #fnum, "XY"
foundXY = True
End If
End Select
If fd.Name <> "XY1" Then
Print #fnum, fd.Name & " " & var
End If
Next
.MoveNext
If Not (.EOF) Then
Print #fnum, ""
End If
Loop
.Close
End With
Set rst = Nothing
Set dbs = Nothing
If OK Then
Close #fnum
MsgBox "table imported to " & path
End If
End Function