Option Explicit
 
' Titre : DS2XLS
' Auteur : MagicBuzz
' Version : 1.0
' Date : 10-05-2006
'
' Script VBS qui génère un document Excel à partir d'un extract "ToXml()" d'un Objet DataSet de .NET
' Ce script est censé fonctionner sur n'importe quelle version de Windows, et n'importe quelle version d'Excel
' Bon, rien n'est garanti non plus hein...
 
' Constantes
' Ces GUID génériques ont l'avantage d'être identiques pour toutes les versions
' Il faut alors faire confiance à Microsoft pour ne pas changer la structure des objets d'une version à l'autre
Const EXCEL_GUID = "Excel.Application"
Const MSXML_GUID = "MSXML.DOMDocument"
 
' Méthodes
Sub Main()
    ' Excel objects
    Dim xls
    Dim wkb
    Dim sht
     
    ' DOM objects
    Dim dom
    Dim declaration
    Dim table
    Dim colonne
    Dim ligne
     
    ' Common variables
    Dim args
    Dim filename
    Dim tabName
    Dim arrColonnes()
     
    ' Compteurs
    Dim i
    Dim j
     
    ' On récupère le nom du fichier XML à traîter
    Set args = WScript.Arguments
     
    If args.Count <> 1 Then
        MsgBox("Nombre d'arguments incorrects : 1 attendu" )
        Exit Sub
    End If
    filename = args(0)
     
    ' Création d'une instance d'Excel
    Set xls = CreateObject(EXCEL_GUID)
 
    ' On ne l'affiche pas
    'xls.Visible = True
     
    ' Ajout d'un espace de travail (par défaut, Excel s'ouvre vide)
    Set wkb = xls.Workbooks.Add()
     
    ' L'espace de travail contient de base 3 sheets. On en vire deux et on renomme la dernière
    ' En effet, un espace de travail doit au moins toujours contenir une feuille...
    For i = wkb.WorkSheets.Count To 2 Step -1
        wkb.WorkSheets(i).Delete
    Next
    wkb.WorkSheets(1).Name = "tmpSheet"
     
    ' Ouverture du document XML contenant les données du dataset à sauvegarder
    Set dom = CreateObject(MSXML_GUID)
    dom.Load filename
     
    ' Recherche du tag de description des DataTables
    Set declaration = dom.DocumentElement.SelectNodes("xs:schema/xs:element/xs:complexType/xs:choice/xs:element" )
     
    ' C'est parti !
    For Each table In declaration
        tabName = GetAttributeByName(table, "name" )
        Set sht = wkb.WorkSheets.Add()
        sht.Name = tabName
 
        ReDim arrColonnes(1)
        i = 0
        For Each colonne In table.SelectNodes("xs:complexType/xs:sequence/xs:element" )
            i = i + 1
            ReDim Preserve arrColonnes(i)
            ' En-tête
            arrColonnes(i) = GetAttributeByName(colonne, "name" )
            sht.Cells(1, i).Value = GetAttributeByName(colonne, "name" )
            sht.Cells(1, i).Interior.ColorIndex = 36
            sht.Cells(1, i).Font.Bold = True
            ' Formattage du type de la colonne
            Select Case GetAttributeByName(colonne, "type" )
                Case "xs:string"
                    sht.Columns(i).NumberFormat = "@"
                Case "xs:decimal"
                    sht.Columns(i).NumberFormat = "0.00"
                Case Else
                    ' Ouais, ben désolé, moi je me sert que de string et decimal...
                    sht.Columns(i).Interior.ColorIndex = 3
                    MsgBox("Type inconnu : " & GetAttributeByName(colonne, "type" ))
            End Select
        Next
         
        ' Maintenant, on parcours l'ensemble des éléments correspondant au datatable en cours de lecture
        j = 1
        For Each ligne In dom.DocumentElement.SelectNodes(tabName)
            j = j + 1
            For i = 1 To UBound(arrColonnes)
                ' On recopie bêtement le contenu du tag portant le nom de la colonne désirée
                sht.Cells(j, i).Value = ligne.SelectSingleNode(arrColonnes(i)).Text
            Next
        Next
         
        ' Ca c'est pour faire joli (si faire se peut)
        sht.Columns.EntireColumn.AutoFit
    Next
     
    ' Vous vous rappelez de la sheet renommée ? Ben on la zigouille maintenant
    wkb.WorkSheets("tmpSheet" ).Delete
     
    ' On indique qu'on ferme l'espace de travail en enregistrant le document (une popup d'enregistrement apparaît)
'    wkb.Close(true)
     
    ' On quitte Excel
'    xls.Quit
    xls.Visible = True
End Sub
 
Function GetAttributeByName(node, attributeName)
    ' Impossible d'utiliser les collections nommées en VBS. Du coup on fait avec les moyens du bords...
    Dim tmpRet
    Dim att
 
    tmpRet = ""
 
    For Each att in node.attributes
        If att.Name = attributeName Then
            tmpRet = att.Value
            Exit For
        End If
    Next
     
    GetAttributeByName = tmpRet
End Function
 
' Démarrage du programme
Call Main()

Public Class Form1
 
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim AppExcel As Excel.Application
 
        AppExcel = New Excel.Application()
        AppExcel.Workbooks.Add()
        AppExcel.Visible = True
        ....
    End Sub
End Class