Exporter listview vers excel

Commenter

Contenu du snippet

Voici un code que j'ai modifié pour exporter une listview apres une recherche vers une feuille excel,
je sais que ca se fait pas d'utiliser une erreur pour arreter le transfert mais bon, je suis débutant...
mais j'ai un probleme, l'export se fait bien, ce sont des nombres qui sont exportés vers excel, grace à ceux-ci je fait un graphique, mais mon graphique ne prend pas en compte les valeurs rentrées grace à mon code, mais si je les retapes une à une le graphique fonctionne...

Donc je vous demande si vous pouvez jetter un oeil sur mon code pour l'ameliorer et me dire pourquoi excel ne prend pas en compte les valeurs exportés (elles sont bien ecrites mais il faut les réécrire à la main pour que le graphique les prennent en compte).

Ne criez pas si le code est fouilli, je suis débutant! ;c)

MERCI!

Source / Exemple : 


'Option Explicit

' * Variables globales *
Dim Con As New Connection       ' Connection au moteur ADO
Dim Cmd As New Command          ' Commande pour le moteur ADO
Dim RS As Recordset             ' Tableau resultat
Dim strQuery As String          ' Chaine de requête
Dim bSelect As Boolean          ' Flag de selection
Dim strKeySelect As String      ' Chaine de la cle selectionner
Dim bTri As Boolean             ' Tri par NOM

Private Sub Command2_Click()

End Sub

Private Sub ExportExcel_Click()
Dim i As Integer
Dim j As Integer
Dim Co As Integer
Dim It As Integer
'Chemin du fichier a modifier à chaque installation
                repertoire = "C:\fichier.xls"
         'Ouverture de l'application
                Set appexcel = New Excel.Application
        'Gestion du fichier et ouverture statique
                appexcel.Workbooks.Open repertoire
         'Visualisation en fond d'ecran la page excel
                appexcel.Visible = True
        'On remplit l'entete de la page excel
        appexcel.Worksheets(1).Cells(1, 1).Value = "Date et Heure:"
        appexcel.Worksheets(1).Cells(1, 2).Value = "Blanc:"
        appexcel.Worksheets(1).Cells(1, 3).Value = "Ciment Blanc:"
        appexcel.Worksheets(1).Cells(1, 4).Value = "Ciment Gris:"
        appexcel.Worksheets(1).Cells(1, 5).Value = "Concasse:"
        appexcel.Worksheets(1).Cells(1, 6).Value = "Filler:"
        appexcel.Worksheets(1).Cells(1, 7).Value = "Mi Casse:"
        appexcel.Worksheets(1).Cells(1, 8).Value = "Roule:"
        appexcel.Worksheets(1).Cells(1, 9).Value = "Silice:"
        appexcel.Worksheets(1).Cells(1, 10).Value = "Silice humide:"
        appexcel.Worksheets(1).Cells(1, 11).Value = "Vasilogrit:"
        
        On Local Error GoTo fin
        Co = 0
        It = 0
        Do
            appexcel.Worksheets(1).Cells(2 + Co, 1).Value = lsvResult.ListItems.Item(1 + It)
        appexcel.Worksheets(1).Cells(2 + Co, 2).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(1)
        appexcel.Worksheets(1).Cells(2 + Co, 3).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(2)
        appexcel.Worksheets(1).Cells(2 + Co, 4).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(3)
        appexcel.Worksheets(1).Cells(2 + Co, 5).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(4)
        appexcel.Worksheets(1).Cells(2 + Co, 6).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(5)
        appexcel.Worksheets(1).Cells(2 + Co, 7).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(6)
        appexcel.Worksheets(1).Cells(2 + Co, 8).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(7)
        appexcel.Worksheets(1).Cells(2 + Co, 9).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(8)
        appexcel.Worksheets(1).Cells(2 + Co, 10).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(9)
        appexcel.Worksheets(1).Cells(2 + Co, 11).Value = lsvResult.ListItems.Item(1 + It).ListSubItems(11)
        
      Co = Co + 1
      It = It + 1
      
        Loop
        Exit Sub
        
    
        For i = 1 To 11
       
                appexcel.Worksheets(1).Cells(1, i).Font.Bold = True
                appexcel.Worksheets(1).Cells(1, i).Font.Size = 8
                appexcel.Worksheets(1).Cells(1, i).HorizontalAlignment = xlCenter
                 appexcel.Worksheets(1).Cells(1, i).VerticalAlignment = xlCenter
        Next i
         For j = 1 To 11
         appexcel.Worksheets(1).Cells(2, j).HorizontalAlignment = xlCenter
        Next j
fin:
End Sub

' *******************************
' * Chargement de la feuille    *
' *******************************
Private Sub Form_Load()

    ' Definition de la chaine de connection
    ' c'est ici qu'il faut modifier le chemin à la base de donnée : Data Source=
    Con.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=CAB.mdb;Persist Security Info=False"
    
    ' Connection à la base de donnée
    Con.Open
    
    ' Affectation des commandes à la connection active
    Cmd.ActiveConnection = Con
   
    ' Affectation des collones list view
    lsvResult.ColumnHeaders.Add 1, , "Date", 110
    lsvResult.ColumnHeaders.Add 2, , "Blanc", 50
    lsvResult.ColumnHeaders.Add 3, , "Ciment Blanc", 80
    lsvResult.ColumnHeaders.Add 4, , "Ciment Gris", 80
    lsvResult.ColumnHeaders.Add 5, , "Concasse", 60
    lsvResult.ColumnHeaders.Add 6, , "Filler", 50
    lsvResult.ColumnHeaders.Add 7, , "Mi Casse", 60
    lsvResult.ColumnHeaders.Add 8, , "Roule", 50
    lsvResult.ColumnHeaders.Add 9, , "Silice", 50
    lsvResult.ColumnHeaders.Add 10, , "Silice Humide", 80
    lsvResult.ColumnHeaders.Add 11, , "Vasilogrit", 60
    lsvResult.ColumnHeaders.Add 11, , "N°", 0
    lsvResult.View = lvwReport
    
    ' Init du trie
    bTri = False
    stbInfo.Panels("info").Text = "Recherche par Date"
          
End Sub

' *******************************
' * Dechargement de la feuille  *
' *******************************
Private Sub Form_Unload(Cancel As Integer)
    ' Fermeture de la connection
    Con.Close
End Sub

' *******************************
' * Selection d'une item        *
' *******************************
Private Sub lsvResult_ItemClick(ByVal Item As MSComctlLib.ListItem)
    ' * variables locales *
    Dim strKey As String            ' chaine de la cle
    
    ' Gestionnaire d'erreur
    On Local Error GoTo Err
 
    
    ' Info selection
    'stbInfo.Panels("info").Text = "Selection : " & UCase(Trim(txtNom.Text)) & " " & UCase(Trim(txtPrenom.Text))
        
    ' test si deja selectionner
    If (strKeySelect = Item.Key) Then Exit Sub
    
    ' Mémorisation de la cle
    strKeySelect = Item.Key
     
    ' Sortie de la routine
    Exit Sub
    
MyErr:
    ' Desaffectation de la gestion erreur
    On Local Error GoTo 0
    
    ' Libération des ressources
    Set RS = Nothing
        
     Exit Sub
    
Err:
    ' Desaffectation de la gestion erreur
    On Local Error GoTo 0
        
    ' Libération des ressources
    Set RS = Nothing
    
End Sub

' ***************************
' * Procédure de quitter    *
' ***************************
Private Sub mnuQuitter_Click()
    Unload Me
End Sub

' ***************************************************
' * Changement du contenu de la zone de recherche   *
' ***************************************************
Private Sub txtSearch_Change()
    
    ' * Variable locales *
    Dim strSearch As String             ' Zone texte de recherche
    Dim liItem As ListItem              ' Variable pour l'affichage du résultat
    Dim Cpt As Integer                  ' Compteur affichage
    
    ' Lecture de la valeur saisie
    strSearch = Trim(txtSearch.Text)
    strSearch = UCase(strSearch)
    
    ' Efface la zone résultat
    ExportExcel.Enabled = False
    lsvResult.ListItems.Clear
    
    bSelect = False
  
    
       
    ' Test de la cohérence de la saisie
    If (txtSearch.Text = "") Then Exit Sub
    
    ' Définition de la requête
    If (Not bTri) Then
        strQuery = "SELECT * from Ajout WHERE Date LIKE '$' ORDER BY Date ASC"
   End If
    
    ' Remplace les etoiles par %
    strSearch = Replace(strSearch, "*", "%", 1, , vbTextCompare)
    
    ' Test si existence d'un %
    If (InStr(1, strSearch, "%", vbTextCompare) = 0) Then
        strSearch = strSearch & "%"
    End If
    
    ' Construction de la requête
    strQuery = Replace(strQuery, "$", strSearch, 1, , vbTextCompare)
    
    ' Préparation de la commande
    Cmd.CommandText = strQuery
    
    ' Execution de la commande
    Set RS = Cmd.Execute
    
    ' Init compteur
    Cpt = 0
    
    ' Test si résultat
    If (Not RS.EOF) Then
        ' Il y a donc un résultat => Boucle d'affichage
        While (Not RS.EOF)
        ExportExcel.Enabled = True
            ' Affichage résultat
            If (Not bTri) Then
                Set liItem = lsvResult.ListItems.Add(, "K" & CStr(RS!N°), RS!Heure)
                
                liItem.SubItems(1) = RS!Blanc
                liItem.SubItems(2) = RS!Ciment_Blanc
                liItem.SubItems(3) = RS!Ciment_Gris
                liItem.SubItems(4) = RS!Concasse
                liItem.SubItems(5) = RS!Filler
                liItem.SubItems(6) = RS!MI_Casse
                liItem.SubItems(7) = RS!Roule
                liItem.SubItems(8) = RS!Silice
                liItem.SubItems(9) = RS!silice_H
                
                liItem.SubItems(11) = RS!Vasilogrit
           
            End If
    
            ' Incrémente le compteur
            Cpt = Cpt + 1
            
            ' Passe à l'élément suivant
            RS.MoveNext
            
            ' Autorise les evenements
            'DoEvents
        Wend
    End If
    
    ' Affichage du résultat
    stbInfo.Panels("info").Text = Cpt & " Date(s) trouvée(s)"
    
    ' Libération des ressources
    Set RS = Nothing

End Sub

' * Procédure recherchant si l'acteur existe
Public Function IsActeurExist(Name As String, Surname As String) As Boolean

    ' Retour par defaut
    IsActeurExist = False
    
    ' Initialisation de la requête
    strQuery = "SELECT * from Ajout WHERE Date='%' AND PRENOM='$'"
    
    ' Finition de la requête
    strQuery = Replace(strQuery, "%", UCase(Trim(Name)), 1, , vbTextCompare)
    strQuery = Replace(strQuery, "$", UCase(Trim(Surname)), 1, , vbTextCompare)
    
    ' Préparation de la requête
    Cmd.CommandText = strQuery
    
    ' Execution de la requête
    Set RS = Cmd.Execute
    
    ' Test si existance
    If (RS.EOF) Then
        ' Libération des ressources
        Set RS = Nothing
        Exit Function
    End If
    
    ' Retour OK
    IsActeurExist = True
    
    ' Libération des ressources
    Set RS = Nothing
    
End Function

Conclusion :


La form comporte les elements suivant:

-un textbox nommé txtSearch
-un timer nommé timer1
-un commandbutton nommé ExportExcel
-une listview nommé lsvResult
-un commandbutton nommé mnuQuitter
-une statusbar nommé stbInfo

MERCI ENCORE!!!

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.