'Simple program to read in rows of a spreadsheet and write them to
'a csv files. In a real app, better error checking is recommended!

Dim csvName, XlSheet, fso, CsvFile, XLObj, Row, Cell1, Cell2, Cell3, Record, XlsName

   XlsName = currentPath & "\Samples\xls2csv.xls" 'Spread to get data from
   XlSheet = 1 'WorkSheet Number
   CsvName = "c:\xls2csv.csv"  'csv file to write to

   Set fso       = CreateObject("Scripting.FileSystemObject")
   Set CsvFile   = fso.CreateTextFile(CsvName, True)

   Set XlObj = CreateObject("Excel.Application")
   XlObj.Workbooks.Open XlsName,0
   XlObj.Sheets(XlSheet).Activate

   'Loop through rows until we find a cell in "A" that is empty
   Row = 1
   Do  until XlObj.Range("A:A").Cells(Row).Text = ""

       'Get data from first 3 cells in the row
       Cell1 = XlObj.Range("A:A").Cells(Row).Text
       Cell2 = XlObj.Range("B:B").Cells(Row).Text
       Cell3 = XlObj.Range("C:C").Cells(Row).Text

       Record = Quote(Cell1) & "," + Quote(Cell2) & "," + Quote(Cell3)
       CsvFile.WriteLine(Record)

       Row = Row + 1
   Loop
   MsgBox "Operation Complete." & vbcrlf &_
    cstr(Row-1) & " rows written to """ & CsvName & """"

   CsvFile.Close()
   XlObj.Quit


   Function Quote(What)
   ' If the cell contains a value that needs quoting then quote it, take care of
   ' any double quotes (get doubled up)
       If  instr(1, What, " ") <> 0 Or instr(1, What, ",") <> 0 Or instr(1,What,"""")  <> 0 Then
           Quote = """" & replace(What, """", """""") & """"
       Else
           Quote = What                   'No need to quote
       End If
   End Function