Solved

Creating Excel File from iterating ado recordset

Posted on 2004-04-29
14
2,136 Views
Last Modified: 2013-11-25
A query populates the ado recordset that I have in my application. That query may execute number of times with different values as the where clause and each time a new recordset is generated with exactly same attributes. The result is dynamic and may contain recordcount from 0 - many.

Is there  a way I can write down all attribute values from this ado recordset to a excel file, as queries execute.
0
Comment
Question by:jupiterz
  • 6
  • 2
  • 2
  • +2
14 Comments
 
LVL 35

Expert Comment

by:[ fanpages ]
Comment Utility
Hi jupiterz,

Please confirm my understanding of your requirements:

You execute a SQL statement from your Visual Basic code a number of times that has a dynamically changing WHERE clause.

Every time a SQL statement is executed you wish to create an entry in an MS-Excel worksheet that states the <...and here's where I'm struggling...> SQL Statement / WHERE clause only / results (delete as applicable).


Thank you for your clarification.


BFN,

fp.
0
 
LVL 18

Expert Comment

by:Sethi
Comment Utility
0
 
LVL 18

Expert Comment

by:Sethi
Comment Utility
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
I have a simple example, but it can get more complicated if you want to format the columns.

First you create your data:

DIm GF as New zGF ' agin access to your function library

RS.Open.....etc I assume you can do this

' convert the recorset RS to a string
' and move the string to Excel
OK=ExcelCreateOK(GF.Expose(RS, True))

'Job Done.


----------------------Exctract from class zGF
Public Function ExcelCreateOK(FromData As String) As Boolean

' Fires Up Excel and pastes data into a new workbook

' See class zExcel for a better version of this

' OK = GF.ExcelCreateOK(sDataToPaste)


On Error Resume Next

Dim ExcelApp
Set ExcelApp = CreateObject("Excel.Application")
Dim WB

ExcelApp.Visible = True
Set WB = ExcelApp.Workbooks.Add
WB.Activate
ExcelApp.Range("A1").Select

Clipper FromData

ExcelApp.ActiveSheet.Paste
Set WB = Nothing
Set ExcelApp = Nothing
If Err.Number = 0 Then
    ExcelCreateOK = True
End If

End Function


Function Expose(RS, Optional ExcelFormat As Boolean = True) As String

' Display the contents of  recordsset

Dim sRow As String
Dim sDocument As String
Dim fc As Long
Dim rc As Long
Dim sDelim As String

If RS Is Nothing Then
    Expose "Recordset Is Nothing"
    Exit Function
End If
If RS.EOF And RS.BOF Then
    Expose "Recordset Empty"
    Exit Function
End If

Dim bm

' you may want to retain bookmark
'On Error Resume Next
'bm = RS.Bookmark


RS.MoveFirst

' create column headings

If ExcelFormat Then
    sRow = ""
    For fc = 0 To RS.Fields.Count - 1
        sRow = sRow + sDelim + RS.Fields(fc).Name
        sDelim = Chr(9)
    Next
    sDocument = sRow
End If



Do While Not RS.EOF
    If ExcelFormat Then
        sRow = ""
        sDelim = ""
        For fc = 0 To RS.Fields.Count - 1
            sRow = sRow + sDelim + GetFieldDisplayFormat(RS(fc))
            sDelim = Chr(9)
        Next fc
        sDocument = sDocument + sRow + vbCrLf
    Else
        sRow = "Row:" + CStr(rc)
        For fc = 0 To RS.Fields.Count - 1
            sRow = sRow + "; " + RS(fc).Name + ": " + GetFieldDisplayFormat(RS(fc))
        Next fc
        sDocument = sDocument + sRow + vbCrLf
    End If
    rc = rc + 1
    RS.MoveNext
Loop

Expose = sDocument
'On Error Resume Next
'RS.Bookmark = bm


End Function

Function GetFieldDisplayFormat(RSField, Optional NullValue = "Null") As String

' Converts a Field into a string


Dim tp$, fmt$

' obtain a simple type for the field
' B=binary, D=Date, N=Numeric, S or M are strings
GetFieldSimpleType RSField.Type, tp, fmt
Dim d$
If IsNull(RSField) Then
    d$ = ""
    Exit Function
End If
Select Case tp
    Case Is = "B"
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d$ = Format(RSField, fmt)
        End If
    Case Is = "D"
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d$ = Format(RSField, fmt)
        End If
    Case Is = "N"
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d$ = Format(RSField, fmt)
        End If
    Case Else
        If IsNull(RSField) Then
            d$ = NullValue
        Else
            d = CStr(RSField)
        End If
End Select

       
GetFieldDisplayFormat = d$

End Function

Sub GetFieldSimpleType(TypeCode, tp As String, fmt As String)

' returns a simplefied data type from an ad?? Type code
' also sets up a default format

' Need to add reference to ADOX
' MS ADO Ext for DLL & Security

Select Case TypeCode
        Case Is = ADOX.DataTypeEnum.adBoolean
            tp = "B": fmt = "Yes/No"
        Case Is = ADOX.DataTypeEnum.adDate
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adDBDate
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adDBTime
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adDBTimeStamp
            tp = "D": fmt = DateFormat
        Case Is = ADOX.DataTypeEnum.adVarChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adVarWChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adWChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adChar
            tp = "T"
        Case Is = ADOX.DataTypeEnum.adLongVarChar
            tp = "M"
        Case Is = ADOX.DataTypeEnum.adLongVarWChar
            tp = "M"
        Case Is = ADOX.DataTypeEnum.adCurrency
            tp = "N": fmt = CurrrencyFormat
        Case Else
            tp = "N"
            'sz = .NumericScale
            'If sz > 0 Then
            '    fmt = "0." + String(sz, "0")
            'Else
                fmt = "0"
            'End If
    End Select
End Sub

0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
For the above you need to add to your function lib.
Const CurrrencyFormat As String = "0.00" ' change as required
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
Handy tip.......

If you declare your function library in a module like "Global GF as New zGF" then when you are debugging your program you can get see what is in you recordset using the immediate window:

?GF.Expose(RS)

Or to place the contents of the RS into the clipboard for paste into notepad:

GF.Clipper GF.Expose(RS)

Or to show in Excel

ExcelCreateOK GF.Expose(RS, True)
0
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 
LVL 17

Expert Comment

by:inthedark
Comment Utility
PS the fastest way to get data into excel is via the clipboard using Paste.  You can create a sheet cell by cell but it is very slow.

It is quicker to load your data in a paste and then adjust column sizes as require usign code like this:

Set EA = CreateObject("Excel.Application")

EA.Visible = False
Set WB = EA.Workbooks.Add
WB.Activate

' define font
EA.cells.Select
With EA.selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .superScript = False
    .subScript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = zxlUnderlineStyleNone
    .ColorIndex = zxlAutomatic
End With
EA.selection.Font.Bold = False

Dim lc As Long


lc = 0
Do While lc <= mlColumns
   
    EA.Columns(mvColdata(lc).Name + ":" + mvColdata(lc).Name).Select
    With EA.selection
        .VerticalAlignment = &HFFFFEFF5 'Excel.Constants.xlBottom
        .WrapText = False
        .Orientation = 0
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
        If Len(mvColdata(lc).FormatSpec) > 0 Then
            On Error Resume Next
            .NumberFormat = mvColdata(lc).FormatSpec
            On Error GoTo 0
        End If
        If mvColdata(lc).Characters > 0 Then
            .ColumnWidth = mvColdata(lc).Characters
        End If
       
        Select Case mvColdata(lc).align
            Case Is = zExAlignment.zexLeft
                '.HorizontalAlignment = Excel.Constants.xlLeft
                .HorizontalAlignment = &HFFFFEFDD  'left
            Case Is = zExAlignment.zexright
                 .HorizontalAlignment = &HFFFFEFC8  'right
            Case Else
                .HorizontalAlignment = &HFFFFEFF4   'center
        End Select
       
    End With
   
    lc = lc + 1
Loop

EA.Range("A1").Select


If Len(DataToPaste) > 0 Then
    Clipboard.Clear
    Clipboard.SetText DataToPaste
    EA.ActiveSheet.Paste 'paste into excel
    Clipboard.Clear
End If
0
 
LVL 53

Expert Comment

by:Dhaest
Comment Utility
A little example:

Private Sub PrintPartij()
'## The sub PrintPrintOverzicht will print (to excell), the paknumbers where is a mistake in the name of the list
On Error GoTo PrintPartijError
    Dim xSql As String
    Dim OldSql As String
    Dim Grafiek As String
  dim adoCN as ADODB.Connection
  dim adoRS as ADODB.Recordset    

    xSql = "SELECT* from YourTable WHERE ...    "    Set adoCn = New ADODB.Connection
    adoCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=YourDatabase.mdb"
    Set adoRs = New ADODB.Recordset
    adoRs.Open xSql, adoCn, adOpenKeyset
   
    Dim ExcelApp As Object
    Dim ExcelWorkBook As Object
    Dim i As Integer
   
    Set ExcelApp = CreateObject("excel.application")
    ExcelApp.Visible = False
   
    Set ExcelWorkBook = ExcelApp.Workbooks.Add
    With adoRs ' recordset
        ' Printing the fields into excell !
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 1) = "Field1"
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 2) = "Field2"
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 3) = "Field3"
        ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition, 4) = "Field4"
        Do Until .EOF
            For i = 0 To adoRs.Fields.Count - 1
                ExcelWorkBook.sheets(1).cells(adoRs.AbsolutePosition + 1, i + 1) = Trim(adoRs.Fields(i))
            Next i
            .MoveNext
        Loop
    End With
    ExcelApp.Visible = True
   
    adoRs.Close
    adoCn.Close
   
    Set ExcelWorkBook = Nothing
    Set ExcelApp = Nothing
    Set adoRs = Nothing
    Set adoCn = Nothing
   
    Check2(6).Value = 0
    Exit Sub
PrintPartijError:
    LogError "Socver-PrintPartij", Err.Number, Err.Description
    Resume Next
End Sub
0
 

Author Comment

by:jupiterz
Comment Utility
Hi all,

Thanks for your answers. I really do not know if all your answers satisfy my need.
My requirement is here again:

For i = 1 to 10
     adoRS = executeQuery
     For j = 1 to adoRS.RecordCount
          WriteRsToExcel
     Next j
next i    

My question how can I keep writing to the same excel file if the same query executes 10 times, with different results. The criteria changes in the whereclause (executeQuery) each time it loops resulting in a adoRS with different RecordCount but same attributes.
0
 
LVL 17

Accepted Solution

by:
inthedark earned 500 total points
Comment Utility
Sorry I forgot to give you the Sub Clipper which was used by one of my posts above, it is a simple sub that puts data on the clipboard.

For multiple saves you need some code like CreateUnusedFileName. In that way you get a different file each time it fires:


' Generate an unused file name in the form like:
' C:\MyFolder\MyQueries.xls
' C:\MyFolder\MyQueriesV1.xls
' C:\MyFolder\MyQueriesV2.xls
' etc.

After you pasted the data into Excel (see above example)

sFileName = GF.CreateUnusedFileName("C:\MyFolder\", "MyQueries", "xls")


Const zxlNormal As Long = 0
If Len(sFileName) <> 0 Then
    ExcelApp.ActiveWorkbook.SaveAs FileName:=sFileName, FileFormat:=zxlNormal, Password:="", _
        WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End If


-------------Part of class zGF.cls
Option Explicit
Public Enum SlashOptions
    RemoveSlash = 0
    KeepSlash = 1
End Enum
Public Function CreateUnusedFileName(psFolder As String, psDocument As String, psExtension As String) As String

' returns a file anme that has not been used

Dim sFolder As String
Dim lTry As Long
Dim sVersion  As String

sFolder = psFolder

' Make sure folder has a back slash at the end
CheckSlash sFolder

Do
    If lTry > 0 Then
        sVersion = "V" + CStr(lTry)
    Else
        sVersion = ""
    End If
   
    sVersion = psDocument + sVersion + "." + psExtension
    If Len(Dir(psFolder + sVersion)) = 0 Then
        CreateUnusedFileName = sVersion
        Exit Function
    End If
    lTry = lTry + 1
Loop

End Function

Public Sub CheckSlash(FolderName, Optional KeepSlash As SlashOptions = SlashOptions.KeepSlash)

' Removes/puts a slash at the end of a folder path
' GF.CheckSlash sFolderName ' make sure has a slash
' GF.CheckSlash sFolderName, SlashOptions.RemoveSlash ' remove slash if present

If KeepSlash = SlashOptions.KeepSlash Then

    If Right(FolderName, 1) <> "\" Then
        FolderName = FolderName + "\"
    End If
Else
    If Right(FolderName, 1) = "\" Then
        FolderName = Left(FolderName, Len(FolderName) - 1)
    End If
End If

End Sub

Public Sub Clipper(TextToSave As String)

' Place some text on the clipboard
' GF.Clipper MyHolder.Expose

Clipboard.Clear
Clipboard.SetText TextToSave

End Sub
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
Warning RecordCount is not always accurate.  See the Sub Expose for a better way of looping a recordset. Keep going until adoRS.EOF.  This also solves the problem that the code won't crash if the recorset was empty.

For i = 1 to 10
     adoRS = executeQuery
     Do While Not adoRS.EOF ' better way
          WriteRsToExcel
     Loop
next i    
0
 
LVL 35

Expert Comment

by:[ fanpages ]
Comment Utility
I respectfully suggest the question be closed & points awarded accordingly; probably to "inthedark" as [s]he spent so much time replying!

Thank you.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now