1

I know this likely sounds simple but this was just dumped on me after an employee left. The current script writes an Excel file and they now want it to be a .csv. I am new to VBS and need some pointers. It would be nice if I could just change the file extension but know this will not give me the proper formatting. This is the current script:

Option Explicit

Dim fsObject, ipControlFile, fcFileCreator, dbAdvPRD, qbQuery

Dim ipList, rsListResults, strText, intResult

Set fsObject = CreateObject(“Scripting.FileSystemObject”)

Set ipControlFile = New cIpostControlFile

Set fcFileCreator = New cFileCreator

Set dbAdvPRD = New cDataBase

Set qbQuery = New cQueryBuilder

Set ipControlFile.AppObject = CreateObject(“Excel.Application”)

ipControlFile.Directory = fsObject.GetAbsolutePathName(“.”)

ipControlFile.ControlFile = “WhatCounts List Counts.xls”

fcFileCreator.Location = fsObject.GetAbsolutePathName(“.”)

fcFileCreator.Folder = "WhatCounts Out " & DatePart(“m”,Now) & “-” & DatePart(“yyyy”,Now)

'Begin Script

MsgBox “Retrieving data. This may take several minutes.”, 64, “Monthly WhatCounts Update”

If Not fsObject.FileExists(ipControlFile.FullPath) Then

strText = “The " & ipControlFile.ControlFile & " file is not available.”

strText = strText & “The file must be located in the same directory as this script.”

MsgBox strText, 16, “Error - ControlFile Not Found”

ExitScript()

End If

If fsObject.FolderExists(fcFileCreator.FullPath) Then

strText = "A folder with this datestamp already exists "

strText = strText & "and contains "

strText = strText & fsObject.GetFolder(fcFileCreator.FullPath).Files.Count & " file(s). "

strText = strText & " Would you like to use a this folder?"

intResult = MsgBox(strText, 35, “WhatCounts Monthly Update - Ouput directory”)

If intResult = 2 Then 'User selects cancel, exit script

ExitScript()

End If

If intResult = 7 Then 'User selects no, use temp folder

strText = "WhatCounts Out Temp " & DatePart(“m”,Now) & “-” & DatePart(“yyyy”,Now)

strText = strText & " " & DatePart(“h”,now) & Datepart(“n”, Now) & DatePart(“s”, Now)

fcFileCreator.Folder = strText

End If

If intResult = 6 Then 'User selects yes, use default folder

strText = “The file(s) in this folder will be overwritten.”

intResult = MsgBox (strText,49,“WhatCounts Monthly Update - Output directory”)

If intResult = 2 Then 'User cancelled afterall

ExitScript()

End If

MsgBox “This options is currently not supported.”,16,“Whatcounts Monthly Update - Ouput directory”

ExitScript()

End If

End If

ipControlFile.Open 'The controlFile exists and should be opened for processing

'Once the file has been processed we can return the request objects

For Each ipList In ipControlFile.ListRequests

If Right(ipList.Pubs,2) <> “–” Then 'Active list requests, not commented out in the controlfile

qbQuery.ProcessRequest ipList

Set rsListResults = dbAdvPRD.ExecuteQuery(qbQuery.SqlText)

ipList.RecordCount = rsListResults.RecordCount

Set ipList.Data = rsListResults 'Add the results to the ipList object’s data property

Set rsListResults = Nothing 'Release the temporary recordset

Else 'Set the inactive request’s count to NULL

ipList.RecordCount = NULL

End If

ipControlFile.WriteCounts ipList.Pubs, ipList.lType, ipList.SubType, ipList.RecordCount 'Write the counts

Next

ipControlFile.DateStampFile 'Datestamp the controlFile

fsObject.CreateFolder fcFileCreator.FullPath 'Create a folder to hold the output files

'If the overwrite option is avialable wrap this in a if exists check

For Each ipList In ipControlFile.ListRequests

'Write the list counts to the controlFile 'Moved to other loop to give realtime feedback

'ipControlFile.WriteCounts ipList.Pubs, ipList.lType, ipList.SubType, ipList.RecordCount

If Right(ipList.Pubs,2) <> “–” Then 'Active lists requests

'Create the file name using the strText variable

strText = Trim(ipList.Pubs) & " " & ipList.lType & " " & ipList.SubType & “.xlsx”

'Write the list object’s data to a new .csv file

fcFileCreator.CreateFileFromData fsObject, strText , ipList.Data

End If

Next

Set ipList = Nothing 'Release the ipList object, if not already done

ipControlFile.Maximize 'Maximize the control file to review counts

MsgBox “Script execution complete. Be sure to save the counts to the control file.”,64,“WhatCounts - ControlFile”

ExitScript()

'Exit procedure, exit the script and perform any clean-up if not already done so

Sub ExitScript

MsgBox “Exiting Script…” &vbtab &vbtab,“WhatCounts Monthly Update”

Set fsObject = Nothing

Set ipControlFile = Nothing

Set fcFileCreator = Nothing

Set dbAdvPRD = Nothing

Set qbQuery = Nothing

WScript.Quit

End Sub

’
’
’
’

Class cIpostControlFile 'Ipost Specific Control File Class

Private m_AppObject 'as application object, writeonly

Private m_directory 'as string

Private m_file 'as string

Private m_fullpath 'as string, readonly

Private m_listRequest 'as ipList object arraylist, readonly

Public Property Set AppObject(objValue)

Set m_AppObject = objValue

End Property

Public Property Get Directory

Directory = m_directory

End Property

Public Property Let Directory(strValue)

m_directory = strValue

End Property

Public Property Get ControlFile

ControlFile = m_file

End Property

Public Property Let ControlFile(strValue)

m_file = strValue

End Property

Public Property Get FullPath

FullPath = m_directory & "" & m_file

End Property

Public Property Get ListRequests

Set ListRequests = m_listRequest

End Property

Public Sub Class_Initialize

End Sub

Public Sub Class_Terminate

Set m_AppObject = Nothing

Set m_listRequest = Nothing

End Sub

Public Sub Maximize

m_AppObject.windowState = -4143

End Sub

Public Sub Minimize

m_AppObject.windowState = -4140

End Sub

Public Sub Open

'Create an object to hold the controller file

Dim objExcel

Set objExcel = m_AppObject

'Minimize the application window until the script is complete

objExcel.windowState = -4140

'Open the control file and organize the file contents

objExcel.WorkBooks.Open(FullPath)

objExcel.Visible = True

'Begin Processing the control file

ProcessFile(objExcel)

'Release the reference object

Set objExcel = Nothing

End Sub

Private Sub ProcessFile(objValue)

Dim objExcel, intLastRow, intLastColumn, objRow, arrList

Set objExcel = objValue

Set arrList = CreateObject(“System.Collections.ArrayList”)

'Create the named ranges to hold the list details and dateheaders

intLastRow = objExcel.WorkSheets(1).UsedRange.Rows.Count

intLastColumn = objExcel.WorkSheets(1).UsedRange.Columns.Count + 1

objExcel.Range(“A6”, “C” & intLastRow).Name = “RequestedLists”

objExcel.Range(“E4”, objExcel.Cells(4, objExcel.Rows(4).Cells.Count)).Name = “DateRanges”

objExcel.Range(objExcel.Cells(6, intLastColumn), objExcel.Cells(intLastRow,intLastColumn)).Name = “CurrReport”

'Format the named ranges

objExcel.Range(“DateRanges”).Font.Bold = True

objExcel.Range(“DateRanges”).NumberFormat = “mm/yyyy”

objExcel.Range(“CurrReport”).NumberFormat = “#,##0”

'Loop through each list request in the ‘requestedlists’ range

For Each objRow In objExcel.Range(“RequestedLists”).Rows

If Not IsEmpty(objRow.Cells(1).Value) Then

arrList.Add objRow.Cells(1).Value

arrList.Add objRow.Cells(2).Value

arrList.add objRow.Cells(3).Value

End If

Next

'Return the array list

Set m_listRequest = AsIpObject(arrList)

'Clean-up objects

Set objExcel = Nothing

Set arrList = Nothing

End Sub

Private Function AsIpObject(arrValue)

Dim arrTemp, ipTempObject, arrIpObjectList, i

Set arrTemp = arrValue

Set arrIpObjectList = CreateObject(“System.Collections.ArrayList”)

For i = 0 To arrTemp.Count - 1

Set ipTempObject = New cIpostList

ipTempObject.Pubs = arrTemp(i)

ipTempObject.lType = arrTemp(i + 1)

ipTempObject.SubType = arrTemp(i + 2)

arrIpObjectList.Add ipTempObject

i = i + 2

Next

'Return the new list of ipList objects

Set AsIpObject = arrIpObjectList

'Clean-Up objects

Set arrIpObjectList = Nothing

End Function

Public Sub WriteCounts(strPubs,strType,strSubType,intCount)

Dim objExcel

Set objExcel = m_AppObject

Dim objRow, i

i = 1

For Each objRow In objExcel.Range(“RequestedLists”).Rows

If Not IsEmpty(objRow.Cells(1).Value) Then

If strPubs = objRow.Cells(1).Value And strType = objRow.Cells(2).Value And strSubType = objRow.Cells(3).Value Then

objExcel.Range(“CurrReport”).Cells(i).Value = intCount

'If the row is highlighted then continue on the new cell

If objExcel.Range(“CurrReport”).Cells(i).OffSet(0,-1).Interior.ColorIndex = 15 Then

objExcel.Range(“CurrReport”).Cells(i).Interior.ColorIndex = 15

End If

End If
End If

i = i + 1

Next

Set objExcel = Nothing

End Sub

Public Sub DateStampFile

Dim objExcel, intLastColumn

Set objExcel = m_AppObject

'Find the used Column

intLastColumn = objExcel.WorkSheets(1).UsedRange.Columns.Count

'Find the first empty cell and insert the current date

objExcel.Range(“DateRanges”).Cells(intLastColumn - 4).Value = Date

Set objExcel = Nothing

End Sub

End Class

Class cIpostList 'Ipost List Class

Private m_pubs 'as string

Private m_type 'as string

Private m_subType 'as String

Private m_count 'as integer

Private m_data 'as recordset

Public Property Get Pubs

Pubs = m_pubs

End Property

Public Property Let Pubs(strValue)

m_pubs = strValue

End Property

Public Property Get lType

lType = m_type

End Property

Public Property Let lType(strValue)

m_type = strValue

End Property

Public Property Get SubType

SubType = m_subType

End Property

Public Property Let SubType(strValue)

m_subType = strValue

End Property

Public Property Get RecordCount

RecordCount = m_count

End Property

Public Property Let RecordCount(intValue)

m_count = intValue

End Property

Public Property Get Data

Set Data = m_data

End Property

Public Property Set Data(rsValue)

Set m_data = rsValue

End Property

Public Sub Class_Initialize

'Set intial record count to 0

m_count = 0

End Sub

Public Sub Class_Terminate

'Release data recordset

Set m_data = Nothing

End Sub

End Class

Class cQueryBuilder 'Query Builder Class

Private m_sql 'as string, readonly

Public Property Get SqlText

SqlText = m_sql

End Property

Public Sub Class_Initialize

End Sub

Public sub Class_Terminate

End Sub

Public Sub ProcessRequest(ipList)

'Empty sql string

m_sql = “”

Select Case UCase(ipList.lType)

Case “SUBSCRIPTIONS”

BuildSubscriptionQuery ipList

Case “PRODUCTS”

BuildCustomerQuery ipList

Case Else

'UI.Message unknow list type
msgbox(“unknown list type”)

End Select

End Sub

Private Sub BuildSubscriptionQuery(ipList)

Dim strPubs, strStatus

strPubs = “'” & Replace(Trim(ipList.Pubs)," “,”,") & “'”

strStatus = “‘w,r,p,e’”

m_sql = "IF OBJECT_ID(‘AdvDbPRD.Ipost.GetSubscriptions’,‘P’) IS NOT NULL " & _
"EXEC Ipost.GetSubscriptions @PUBS = " & strPubs & ", " & _
"@STATUS = " & strStatus

End Sub

Private Sub BuildCustomerQuery(ipList)

Dim arrPubs, strPubs, i

arrPubs = Split(ipList.Pubs)

strPubs = “”

i = 0

For i = 0 to UBound(arrPubs)

Select Case arrPubs(i)

Case “CAP”
strPubs = strPubs & “cp” & " "

Case “FCM”
strPubs = strPubs & “fc” & " "

Case “GEM”
strPubs = strPubs & “ge” & " "

Case “STM”
strPubs = strPubs & “ia” & " "

Case “IMA”
strPubs = strPUbs & “ia” & " "

Case “GRT”
strPubs = strPubs & “gr” & " "

Case “HBC”
strPubs = strPubs & “hc” & " "

Case “MEL”
strPubs = strPUbs & “ml” & " "

Case “HFH”
strPubs = strPUbs & “hf” & " "

Case “MCC”
strPubs = strPubs & “mc” & " "

Case “NHG”
strPubs = strPubs & “nh” & " "

Case “UTR”
strPubs = strPubs & “ut” & " "

Case “MEN”
strPubs = strPubs & “me” & " "

Case “CFR”
strPubs = strPubs & “cf” & " "

Case “HGR”
strPubs = strPubs & “hg” & " "

Case “FER”
strPubs = strPubs & “fr” & " "

Case “CCK”
strPubs = strPubs & “cc” & " "

End Select

Next

strPubs = “'” & Replace(Trim(strPubs)," “,”,") & “'”

m_sql = "IF OBJECT_ID(‘AdvDbPRD.Ipost.GetProducts’,‘P’) IS NOT NULL " & _
"EXEC Ipost.GetProducts @PUBS = " & strPubs

End Sub

End Class

Class cFileCreator 'File Creator Class

Private m_location 'as string

Private m_folder 'as string

Private m_fullpath 'as string, readonly

Public Property Get Location

Location = m_location

End Property

Public Property Let Location(strValue)

m_location = strValue

End Property

Public Property Get Folder

Folder = m_folder

End Property

Public Property Let Folder(strValue)

m_folder = strValue

End Property

Public Property Get FullPath

FullPath = m_location & "" & m_folder

End Property

Public Sub CreateFileFromData(fsObject,strFileName,rsData)

Dim oExcel
Dim oBook
Dim oSheet
Dim fld
Dim i
i = 1
Set oExcel = CreateObject(“Excel.Application”)
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets(1)

With oSheet
For Each fld in rsData.Fields
.Cells(1,i).Value = fld.Name
i = i + 1
Next
End With

oSheet.Range(“A2”).CopyFromRecordset rsData

oBook.SaveAs FullPath & "" & strFileName

oExcel.Quit

Set rsData = Nothing

End Sub

End Class

Class cDataBase 'Database Control Class

Private m_adoConn 'as ado connection, private

Private m_strConn 'as string, private

Private m_connStatus 'as string, readonly

Public Property Get Status

Status = m_connStatus

End Property

Public Sub Class_Initialize

Set m_adoConn = CreateObject(“ADODB.Connection”)

'This line is needed to provide the recordcount, change cursor to static.

m_adoConn.CursorLocation = 3

'This line is needed to tell ado to wait indefinitely for the results.

m_adoConn.CommandTimeOut = 0

'Provide the connection string.

m_strConn = “PROVIDER=sqloledb;”

m_strConn = m_strConn & “DATA SOURCE=OPIDB1;”

m_strConn = m_strConn & “INITIAL CATALOG=AdvDbPRD;”

m_strConn = m_strConn & “USER ID=sa;”

m_strConn = m_strConn & “Password=Opis;”

'Set connection status.

m_connStatus = m_adoConn.State

End Sub

Private Sub OpenConnection

m_adoConn.Open m_strConn

'Set the connection status.

m_connStatus = m_adoConn.State

End sub

Private Sub CloseConnection

m_adoConn.Close

'Set the connection status.

m_connStatus = m_adoConn.State

End Sub

Public Function ExecuteQuery(strSql)

OpenConnection()

Dim rsResults

Set rsResults = m_adoConn.Execute(strSql)

'Test for empty recordset

If Not rsResults.EOF And Not rsResults.BOF Then

rsResults.MoveFirst

End If

'Disconnect the record set from the active connection.

Set rsResults.ActiveConnection = Nothing

'Return the results as a disconnected recordset.

Set ExecuteQuery = rsResults

Set rsResults = Nothing

CloseConnection()

End Function

Public Sub Class_Terminate

Set m_adoConn = Nothing

m_strConn = “”

m_connStatus = “”

End Sub

Public Sub Clean

Set m_adoConn = Nothing

m_strConn = “”

m_connStatus = “”

End Sub

End Class

4 Spice ups
2

CSV files are essentially unformatted. Would you consider reposting with your code inserted into the code button? And, provide a sample of what you would like the output to be?

3 
Option Explicit

Dim fsObject, ipControlFile, fcFileCreator, dbAdvPRD, qbQuery

Dim ipList, rsListResults, strText, intResult

Set fsObject = CreateObject("Scripting.FileSystemObject")

Set ipControlFile = New cIpostControlFile

Set fcFileCreator = New cFileCreator

Set dbAdvPRD = New cDataBase

Set qbQuery = New cQueryBuilder

Set ipControlFile.AppObject = CreateObject("Excel.Application")

ipControlFile.Directory = fsObject.GetAbsolutePathName(".")

ipControlFile.ControlFile = "WhatCounts List Counts.xls"

fcFileCreator.Location = fsObject.GetAbsolutePathName(".")

fcFileCreator.Folder = "WhatCounts Out " & DatePart("m",Now) & "-" & DatePart("yyyy",Now)

'Begin Script

MsgBox "Retrieving data. This may take several minutes.", 64, "Monthly WhatCounts Update"

If Not fsObject.FileExists(ipControlFile.FullPath) Then   

  strText = "The " & ipControlFile.ControlFile & " file is not available."

  strText = strText & "The file must be located in the same directory as this script."

  MsgBox strText, 16, "Error - ControlFile Not Found"

  ExitScript()

End If 

If fsObject.FolderExists(fcFileCreator.FullPath) Then

  strText = "A folder with this datestamp already exists " 

  strText = strText & "and contains " 

  strText = strText & fsObject.GetFolder(fcFileCreator.FullPath).Files.Count & " file(s). "

  strText = strText & " Would you like to use a this folder?"

  
  intResult = MsgBox(strText, 35, "WhatCounts Monthly Update - Ouput directory")

  If intResult = 2 Then   'User selects cancel, exit script

    ExitScript()

  End If

  If intResult = 7 Then   'User selects no, use temp folder

    strText = "WhatCounts Out Temp " & DatePart("m",Now) & "-" & DatePart("yyyy",Now)

    strText = strText & " " & DatePart("h",now) & Datepart("n", Now) & DatePart("s", Now)

    fcFileCreator.Folder = strText

  End If

  If intResult = 6 Then   'User selects yes, use default folder

    strText = "The file(s) in this folder will be overwritten."

    intResult = MsgBox (strText,49,"WhatCounts Monthly Update - Output directory")

    If intResult = 2 Then 'User cancelled afterall

  ExitScript()

    End If

    MsgBox "This options is currently not supported.",16,"Whatcounts Monthly Update - Ouput directory"

    ExitScript()

  End If

End If

ipControlFile.Open 'The controlFile exists and should be opened for processing
      
          'Once the file has been processed we can return the request objects

For Each ipList In ipControlFile.ListRequests

  If Right(ipList.Pubs,2) <> "--" Then   'Active list requests, not commented out in the controlfile

  qbQuery.ProcessRequest ipList     

  Set rsListResults = dbAdvPRD.ExecuteQuery(qbQuery.SqlText)

  ipList.RecordCount = rsListResults.RecordCount

  Set ipList.Data = rsListResults 'Add the results to the ipList object's data property

  Set rsListResults = Nothing   'Release the temporary recordset

  Else           'Set the inactive request's count to NULL

  ipList.RecordCount = NULL

End If

  ipControlFile.WriteCounts ipList.Pubs, ipList.lType, ipList.SubType, ipList.RecordCount 'Write the counts

Next

ipControlFile.DateStampFile   'Datestamp the controlFile

fsObject.CreateFolder fcFileCreator.FullPath   'Create a folder to hold the output files
        
              'If the overwrite option is avialable wrap this in a if exists check

For Each ipList In ipControlFile.ListRequests

'Write the list counts to the controlFile   'Moved to other loop to give realtime feedback

  'ipControlFile.WriteCounts ipList.Pubs, ipList.lType, ipList.SubType, ipList.RecordCount

  If Right(ipList.Pubs,2) <> "--" Then     'Active lists requests

'Create the file name using the strText variable

  strText = Trim(ipList.Pubs) & " " & ipList.lType & " " & ipList.SubType & ".xlsx"

'Write the list object's data to a new .csv file

  fcFileCreator.CreateFileFromData fsObject, strText , ipList.Data

  End If

Next

Set ipList = Nothing   'Release the ipList object, if not already done

ipControlFile.Maximize   'Maximize the control file to review counts

MsgBox "Script execution complete. Be sure to save the counts to the control file.",64,"WhatCounts - ControlFile"

ExitScript()

'Exit procedure, exit the script and perform any clean-up if not already done so

Sub ExitScript

  MsgBox "Exiting Script..." &vbtab &vbtab,,"WhatCounts Monthly Update"

  Set fsObject = Nothing

  Set ipControlFile = Nothing

  Set fcFileCreator = Nothing

  Set dbAdvPRD = Nothing

  Set qbQuery = Nothing

  WScript.Quit

End Sub

'
'
'
'

Class cIpostControlFile       'Ipost Specific Control File Class
                        
  Private m_AppObject   'as application object, writeonly

  Private m_directory     'as string

  Private m_file   'as string

  Private m_fullpath     'as string, readonly

  Private m_listRequest   'as ipList object arraylist, readonly

  Public Property Set AppObject(objValue)

    Set m_AppObject = objValue

  End Property

  Public Property Get Directory

    Directory = m_directory

  End Property

  Public Property Let Directory(strValue)

    m_directory = strValue

  End Property

  Public Property Get ControlFile

    ControlFile = m_file

  End Property

  Public Property Let ControlFile(strValue)

    m_file = strValue

  End Property

  Public Property Get FullPath

    FullPath = m_directory & "\" & m_file

  End Property

  Public Property Get ListRequests

  Set ListRequests = m_listRequest

  End Property

  Public Sub Class_Initialize

  End Sub

  Public Sub Class_Terminate

  Set m_AppObject = Nothing

  Set m_listRequest = Nothing

  End Sub

  Public Sub Maximize

      m_AppObject.windowState = -4143

  End Sub

  
  Public Sub Minimize

  m_AppObject.windowState = -4140

  End Sub

  Public Sub Open

      'Create an object to hold the controller file

  Dim objExcel

  Set objExcel = m_AppObject

      'Minimize the application window until the script is complete
  
  objExcel.windowState = -4140

      'Open the control file and organize the file contents

  objExcel.WorkBooks.Open(FullPath)

  objExcel.Visible = True

      'Begin Processing the control file

  ProcessFile(objExcel)

      'Release the reference object

  Set objExcel = Nothing

  End Sub

  
  Private Sub ProcessFile(objValue)

  Dim objExcel, intLastRow, intLastColumn, objRow, arrList

  Set objExcel = objValue

  Set arrList = CreateObject("System.Collections.ArrayList")

      'Create the named ranges to hold the list details and dateheaders

  intLastRow = objExcel.WorkSheets(1).UsedRange.Rows.Count

  intLastColumn = objExcel.WorkSheets(1).UsedRange.Columns.Count + 1

  objExcel.Range("A6", "C" & intLastRow).Name = "RequestedLists"
  
  objExcel.Range("E4", objExcel.Cells(4, objExcel.Rows(4).Cells.Count)).Name = "DateRanges"

  objExcel.Range(objExcel.Cells(6, intLastColumn), objExcel.Cells(intLastRow,intLastColumn)).Name = "CurrReport"

      'Format the named ranges

  objExcel.Range("DateRanges").Font.Bold = True

  objExcel.Range("DateRanges").NumberFormat = "mm/yyyy"
  
  objExcel.Range("CurrReport").NumberFormat = "#,##0"

      'Loop through each list request in the 'requestedlists' range

  For Each objRow In objExcel.Range("RequestedLists").Rows

  If Not IsEmpty(objRow.Cells(1).Value) Then

    arrList.Add objRow.Cells(1).Value

    arrList.Add objRow.Cells(2).Value

    arrList.add objRow.Cells(3).Value

  End If

  Next

  
      'Return the array list

  Set m_listRequest = AsIpObject(arrList)

      'Clean-up objects

  Set objExcel = Nothing

  Set arrList = Nothing

  End Sub

  Private Function AsIpObject(arrValue)

  Dim arrTemp, ipTempObject, arrIpObjectList, i

  Set arrTemp = arrValue

  Set arrIpObjectList = CreateObject("System.Collections.ArrayList")

    
  For i = 0 To arrTemp.Count - 1

  Set ipTempObject = New cIpostList

  ipTempObject.Pubs = arrTemp(i)

  ipTempObject.lType = arrTemp(i + 1)

  ipTempObject.SubType = arrTemp(i + 2)

  arrIpObjectList.Add ipTempObject

  i = i + 2

  Next

      'Return the new list of ipList objects

  Set AsIpObject = arrIpObjectList

      'Clean-Up objects

  Set arrIpObjectList = Nothing

  End Function

  Public Sub WriteCounts(strPubs,strType,strSubType,intCount)

  Dim objExcel

  Set objExcel = m_AppObject 

  Dim objRow, i

  i = 1

  For Each objRow In objExcel.Range("RequestedLists").Rows

  If Not IsEmpty(objRow.Cells(1).Value) Then

    If strPubs = objRow.Cells(1).Value And strType = objRow.Cells(2).Value And strSubType = objRow.Cells(3).Value Then

      objExcel.Range("CurrReport").Cells(i).Value = intCount

      'If the row is highlighted then continue on the new cell

      If objExcel.Range("CurrReport").Cells(i).OffSet(0,-1).Interior.ColorIndex = 15 Then

    objExcel.Range("CurrReport").Cells(i).Interior.ColorIndex = 15

              End If
            

    End If
  End If
  
  i = i + 1

        Next

  Set objExcel = Nothing

  End Sub

  Public Sub DateStampFile

  Dim objExcel, intLastColumn

  Set objExcel = m_AppObject

      'Find the used Column

  intLastColumn = objExcel.WorkSheets(1).UsedRange.Columns.Count 

        

      'Find the first empty cell and insert the current date

  objExcel.Range("DateRanges").Cells(intLastColumn - 4).Value = Date

  Set objExcel = Nothing

  End Sub

End Class

Class cIpostList       'Ipost List Class     
  
  Private m_pubs   'as string

  Private m_type   'as string

  Private m_subType     'as String

  Private m_count   'as integer

  Private m_data   'as recordset

  Public Property Get Pubs

    Pubs = m_pubs

  End Property

  Public Property Let Pubs(strValue)

    m_pubs = strValue

  End Property

  Public Property Get lType

    lType = m_type

  End Property

  Public Property Let lType(strValue)

    m_type = strValue

  End Property

  Public Property Get SubType

    SubType = m_subType

  End Property

  Public Property Let SubType(strValue)

    m_subType = strValue

  End Property

  Public Property Get RecordCount

    RecordCount = m_count

  End Property

  Public Property Let RecordCount(intValue)

    m_count = intValue

  End Property

  Public Property Get Data

    Set Data = m_data

  End Property

  Public Property Set Data(rsValue)

    Set m_data = rsValue

  End Property

  
  Public Sub Class_Initialize

      'Set intial record count to 0

  m_count = 0

  End Sub

  Public Sub Class_Terminate

      'Release data recordset

  Set m_data = Nothing

  End Sub

End Class

Class cQueryBuilder       'Query Builder Class 

  Private m_sql     'as string, readonly

  Public Property Get SqlText

    SqlText = m_sql

  End Property 

  Public Sub Class_Initialize

  End Sub

  Public sub Class_Terminate

  End Sub

  Public Sub ProcessRequest(ipList)

      'Empty sql string

  m_sql = ""
  

  Select Case UCase(ipList.lType)

  Case "SUBSCRIPTIONS"

    BuildSubscriptionQuery ipList

  Case "PRODUCTS"

    BuildCustomerQuery ipList

          Case Else
  
    'UI.Message unknow list type
                msgbox("unknown list type")

  End Select

  End Sub

  Private Sub BuildSubscriptionQuery(ipList)

  Dim strPubs, strStatus

  strPubs = "'" & Replace(Trim(ipList.Pubs)," ",",") & "'"

  
  strStatus = "'w,r,p,e'"

  m_sql = "IF OBJECT_ID('AdvDbPRD.Ipost.GetSubscriptions','P') IS NOT NULL " & _
    "EXEC Ipost.GetSubscriptions @PUBS = " & strPubs & ", " & _
    "@STATUS = " & strStatus

  End Sub

  Private Sub BuildCustomerQuery(ipList)

  Dim arrPubs, strPubs, i

  arrPubs = Split(ipList.Pubs)

  strPubs = ""

  i = 0

  
  For i = 0 to UBound(arrPubs)

  Select Case arrPubs(i)

    Case "CAP"
          strPubs = strPubs & "cp" & " "

        Case "FCM"
          strPubs = strPubs & "fc" & " "

    Case "GEM"
          strPubs = strPubs & "ge" & " "

        Case "STM"
          strPubs = strPubs & "ia" & " "

    Case "IMA"
      strPubs = strPUbs & "ia" & " "

        Case "GRT"
          strPubs = strPubs & "gr" & " "

        Case "HBC"
          strPubs = strPubs & "hc" & " "

    Case "MEL"
      strPubs = strPUbs & "ml" & " "

    Case "HFH"
      strPubs = strPUbs & "hf" & " "

        Case "MCC"
          strPubs = strPubs & "mc" & " "

        Case "NHG"
          strPubs = strPubs & "nh" & " "

        Case "UTR"
          strPubs = strPubs & "ut" & " "

        Case "MEN"
          strPubs = strPubs & "me" & " "

    Case "CFR"
      strPubs = strPubs & "cf" & " "
    
    Case "HGR"
      strPubs = strPubs & "hg" & " "
    
    Case "FER"
      strPubs = strPubs & "fr" & " "

    Case "CCK"
      strPubs = strPubs & "cc" & " "

    End Select

  Next

  strPubs = "'" & Replace(Trim(strPubs)," ",",") & "'"

  m_sql = "IF OBJECT_ID('AdvDbPRD.Ipost.GetProducts','P') IS NOT NULL " & _
    "EXEC Ipost.GetProducts @PUBS = " & strPubs

  End Sub

End Class

Class cFileCreator       'File Creator Class
  
  Private m_location   'as string

  Private m_folder   'as string

  Private m_fullpath   'as string, readonly

  
  Public Property Get Location

    Location = m_location

  End Property

  Public Property Let Location(strValue)

    m_location = strValue

  End Property

  Public Property Get Folder

    Folder = m_folder

  End Property

  Public Property Let Folder(strValue)

    m_folder = strValue

  End Property

  Public Property Get FullPath

    FullPath = m_location & "\" & m_folder

  End Property

  Public Sub CreateFileFromData(fsObject,strFileName,rsData)

  Dim oExcel
  Dim oBook
  Dim oSheet
  Dim fld
  Dim i
  i = 1
  Set oExcel = CreateObject("Excel.Application")
  Set oBook = oExcel.Workbooks.Add
  Set oSheet = oBook.Worksheets(1)

  With oSheet
      For Each fld in rsData.Fields
    .Cells(1,i).Value = fld.Name
    i = i + 1
      Next 
  End With

  oSheet.Range("A2").CopyFromRecordset rsData

  oBook.SaveAs FullPath & "\" & strFileName

  oExcel.Quit

  Set rsData = Nothing

  End Sub

End Class

Class cDataBase         'Database Control Class

  Private m_adoConn   'as ado connection, private

  Private m_strConn   'as string, private

  Private m_connStatus   'as string, readonly

  Public Property Get Status

    Status = m_connStatus

  End Property

  Public Sub Class_Initialize
  
      Set m_adoConn = CreateObject("ADODB.Connection")

      'This line is needed to provide the recordcount, change cursor to static.

      m_adoConn.CursorLocation = 3

      'This line is needed to tell ado to wait indefinitely for the results. 

      m_adoConn.CommandTimeOut = 0

      'Provide the connection string.

      m_strConn = "PROVIDER=sqloledb;"

      m_strConn = m_strConn & "DATA SOURCE=OPIDB1;"

      m_strConn = m_strConn & "INITIAL CATALOG=AdvDbPRD;"

      m_strConn = m_strConn & "USER ID=sa;"

      m_strConn = m_strConn & "Password=Opis;"

      'Set connection status.

      m_connStatus = m_adoConn.State

  End Sub

  Private Sub OpenConnection
  
      m_adoConn.Open m_strConn

      'Set the connection status.

      m_connStatus = m_adoConn.State

  End sub

  Private Sub CloseConnection

      m_adoConn.Close

      'Set the connection status.

      m_connStatus = m_adoConn.State

  End Sub

  Public Function ExecuteQuery(strSql)

      OpenConnection()

      Dim rsResults

      Set rsResults = m_adoConn.Execute(strSql)

      'Test for empty recordset

        If Not rsResults.EOF And Not rsResults.BOF Then

      rsResults.MoveFirst

  End If

      'Disconnect the record set from the active connection.

      Set rsResults.ActiveConnection = Nothing 

  
      'Return the results as a disconnected recordset.

      Set ExecuteQuery = rsResults

      Set rsResults = Nothing

      CloseConnection()

  End Function

  Public Sub Class_Terminate

      Set m_adoConn = Nothing

      m_strConn = ""

      m_connStatus = ""

  End Sub

  Public Sub Clean

      Set m_adoConn = Nothing

      m_strConn = ""

      m_connStatus = ""

  End Sub
    
End Class

I need the output to be named as follows:

CFRSUBSCRIPTIONS.csv with the following fields:

customer,13,c

fname,80,c

lname,80,c

city, 35,c

state,3,c

zip,10,c

email,50,c

update date, 10,c

circ status, 6,c

pub,3,c

sub ref, 12, c

start date, 10,c

expire,10,c

4

When I created .csv files with .vbs, I would have a loop where I iterate through the data set, then inside each loop instance I built an output string and write it to the file

For Each objFile in colFiles
	'write results for each file
	objFileWrite.WriteLine objFile.Path & "," & objFile.DateLastModified
Next

Simplified example, but I think you can see my approach. I would manually build the comma delimited string and write it to the file.

5

It would be very helpful if you’d edit your original post and place your code inside the box that appears when you click </>. This will present it like you’d see it in a program editor. Looking at it, I can see a section that appears to write everything out using Excel commands. It may be easiest to let your code do this, but then initiate a File | Save As (csv) in Excel rather than attempting to rewrite the code to create a CSV file directly.