EXPORTER LISTVIEW VERS EXCEL

'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