Output table as Comma Delimited File

S

spectrolab

Registered User.
Local time
Tomorrow, 04:34
Joined
Feb 9, 2005
Messages
119
Hi,

I am having a few issues with using VBA to output a temporary table to a delimited text file. Someone has done some code for me to output to a variable width file (.SIF), but I need to change it slightly to output a .CSV. Here is the code I have

Code: 
Private Sub cmdMakeJHCSV_Click()


Dim Accuracy As Single
    Dim AllowNeg As Boolean
    Dim FileName As String
    Dim I, J, TBLLoop, intRecs As Integer
    Dim sql, strColName As String
    Dim strResult As String
    Dim rst, rst2 As Recordset
    Dim db As Database
    If IsNull([cboRepSelect]) Then
        MsgBox "Please select a jobnumber", vbExclamation, "No job number selected"
        DoCmd.GoToControl "cboRepSelect"
        Exit Sub
    End If
    
    FileName = "Z:\Jack Hills CSV\" & Me.cboRepSelect & ".CSV"
    
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set A = fs.CreateTextFile(FileName, True)
       


    Set db = CurrentDb
    Set rst = db.OpenRecordset("tmpMMLGCTable")
    rst.MoveLast
    J = rst.recordcount
'Write header lines

    
     
    'Line 1
        
        'Write result type column headings
       
        A.Write (PadRight("Sample", 26))
        Set rst2 = db.OpenRecordset("LU_ColumnHeadingsFull", dbOpenDynaset)
        rst2.MoveLast
        intRecs = rst2.recordcount
        rst2.MoveFirst
        
             For TBLLoop = 1 To intRecs - 1
                strColName = rst2![columnname]
                A.Write PadRight(strColName, 8)
                rst2.MoveNext
             Next TBLLoop
                strColName = rst2![columnname]
                A.WriteLine PadRight(strColName, 8)
 
    'End line 1
    
     'Line 3
        A.Write (PadRight("UNITS", 26)) 'The word UNITS LEFT  Justified
        'Write detection limits
        rst2.MoveFirst

             For TBLLoop = 1 To intRecs - 1
                strColName = rst2![UNITS]
                A.Write PadRight(strColName, 8)
                rst2.MoveNext

             Next TBLLoop
                strColName = rst2![UNITS]
                A.WriteLine PadRight(strColName, 8)
    'End line 3
    
    
    
    'Write results
'******************************************************************************************

    rst.MoveFirst
    For I = 1 To J - 1
        
       
        A.Write PadRight(rst.Fields(0), 26)
        rst2.MoveFirst
        For TBLLoop = 1 To intRecs - 1
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResult(rst.Fields(TBLLoop), Accuracy, AllowNeg)
           A.Write PadRight(strResult, 8)
           rst2.MoveNext
        Next TBLLoop
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResult(rst.Fields(intRecs), Accuracy, AllowNeg)
           A.WriteLine PadRight(strResult, 8)
           rst.MoveNext
   Next I
        A.Write PadRight(rst.Fields(0), 26)
        rst2.MoveFirst
        For TBLLoop = 1 To intRecs - 1
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResult(rst.Fields(TBLLoop), Accuracy, AllowNeg)
           A.Write PadRight(strResult, 8)
           rst2.MoveNext
        Next TBLLoop
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResult(rst.Fields(intRecs), Accuracy, AllowNeg)
           A.WriteLine PadRight(strResult, 8)
   A.Close
    rst.Close
    rst2.Close
    Set db = Nothing
    MsgBox FileName & " created"
Exit_MakeSIF_Click:
    Exit Sub

Err_MakeSIF_Click:
    MsgBox Err.Description
   
End Sub

With the following public functions used

Code: 
Public Function MakeResult(result As Variant, Accuracy As Single, AllowNegs As Boolean) As String
'Function used to display results
    If IsNull(result) Then
        MakeResult = "-"
        Exit Function
    End If
    If result < Accuracy / 2 And AllowNegs = False Then
         MakeResult = "X"
    Else
        Select Case Accuracy
            Case 0.1
                MakeResult = Format(result, "0.0")
            Case 0.01
                MakeResult = Format(result, "0.00")
            Case 0.001
                MakeResult = Format(result, "0.000")
            Case 0.0001
                MakeResult = Format(result, "0.0000")
            Case 0.00001
                MakeResult = Format(result, "0.00000")
        End Select
    End If

End Function

Public Function PadRight(result As String, Length As Integer) As String
Dim diff As Integer 'Difference in length between result and width of string
    diff = Length - Len(result)
    If diff <= 0 Then
        PadRight = result
    Else
        PadRight = result & Space(diff)
    End If
End Function

As you can hopefully see, it isn't as straight forward as just using transferdelimited as the data needs to be manipulated as it is written to the file.

The code looks up the table LU_ColumnHeadings which has the column names and the accuracy as it is writing the file.

Thanks a lot for any advice/help.
 
Can't you do the data manipulation in a query and then use transferdelimited on the query.
 
Last edited:
Thanks for the reply Neil,

I guess I could do as you suggest and run a query, but, the delimited file needs three header rows and I'm not quite sure how I would do that with a query. Any suggestions would be greatly appreciated.
 
Just in case anyone is interested, here is the working code below, I didn't come up with it, but it works.

Code: 
Private Sub cmdMakeJHCSV_Click()


Dim Accuracy As Single
    Dim AllowNeg As Boolean
    Dim FileName As String
    Dim I, J, TBLLoop, intRecs As Integer
    Dim sql, strColName As String
    Dim strResult As String
    Dim rst, rst2 As Recordset
    Dim db As Database
    If IsNull([cboRepSelect]) Then
        MsgBox "Please select a jobnumber", vbExclamation, "No job number selected"
        DoCmd.GoToControl "cboRepSelect"
        Exit Sub
    End If
    
    FileName = "Z:\Jack Hills CSV\" & Me.cboRepSelect & ".CSV"
    
        Set fs = CreateObject("Scripting.FileSystemObject")
        Set A = fs.CreateTextFile(FileName, True)
       


    Set db = CurrentDb
    Set rst = db.OpenRecordset("tmpMMLGCTable")
    rst.MoveLast
    J = rst.recordcount
'Write header lines

    
     
    'Line 1
        
        'Write result type column headings
       
        A.Write "Sample ,"
        Set rst2 = db.OpenRecordset("LU_ColumnHeadingsFull", dbOpenDynaset)
        rst2.MoveLast
        intRecs = rst2.recordcount
        rst2.MoveFirst
        
             For TBLLoop = 1 To intRecs - 1
                strColName = rst2![columnname]
                A.Write strColName & ","
                rst2.MoveNext
             Next TBLLoop
                strColName = rst2![columnname]
                A.WriteLine strColName
 
    'End line 1
    
     'Line 2
        A.Write "UNITS," 'The word UNITS LEFT  Justified
        'Write detection limits
        rst2.MoveFirst

             For TBLLoop = 1 To intRecs - 1
                strColName = rst2![UNITS]
                A.Write strColName & ","
                rst2.MoveNext

             Next TBLLoop
                strColName = rst2![UNITS]
                A.WriteLine strColName
                
    'End line 2
    
    
    
    'Write results
'******************************************************************************************

    rst.MoveFirst
    For I = 1 To J - 1
        
       
        A.Write rst.Fields(0) & ","
        rst2.MoveFirst
        For TBLLoop = 1 To intRecs - 1
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResultJH(rst.Fields(TBLLoop), Accuracy, AllowNeg)
           A.Write strResult & ","
           rst2.MoveNext
        Next TBLLoop
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResultJH(rst.Fields(intRecs), Accuracy, AllowNeg)
           A.WriteLine strResult & ","
           rst.MoveNext
   Next I
        A.Write rst.Fields(0) & ","
        rst2.MoveFirst
        For TBLLoop = 1 To intRecs - 1
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResultJH(rst.Fields(TBLLoop), Accuracy, AllowNeg)
           A.Write strResult & ","
           rst2.MoveNext
        Next TBLLoop
           Accuracy = rst2!Detection
           AllowNeg = rst2!AllowNegs
           strResult = MakeResultJH(rst.Fields(intRecs), Accuracy, AllowNeg)
           A.WriteLine strResult & ","
   A.Close
    rst.Close
    rst2.Close
    Set db = Nothing
    MsgBox FileName & " created"
Exit_MakeSIF_Click:
    Exit Sub

Err_MakeSIF_Click:
    MsgBox Err.Description
   
End Sub
 
Spectro,

Glad you have it working ... but aren't you missing the LAST record?

You could use --> For TBLLoop = 0 To intRecs - 1
You could use --> For TBLLoop = 1 To intRecs

Code: 
rst2.MoveLast
intRecs = rst2.recordcount
rst2.MoveFirst
        
   For TBLLoop = 1 To intRecs - 1

hth,
Wayne
 
You must log in or register to reply here.

Similar threads

G
How to use a multi value result set
Replies
13
Views
782
theDBguy
theDBguy
S
Getting total in one line of the query
Replies
13
Views
295
silentwolf
S
L
Solved Delete specific rows using vba
Replies
4
Views
1,120
lucky245
L
F
Add query data to existing export function
Replies
1
Views
619
MarkK
MarkK
P
Create seperate PDF Files from a report Base on a query with more than 300 records
Replies
5
Views
980
Uncle Gizmo
Uncle Gizmo

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom