Soyez le premier à donner votre avis sur cette source.
Snippet vu 11 497 fois - Téléchargée 44 fois
'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
7 mars 2010 à 19:01
je veux un code simple associé a un boutton qui permet d'exporter les donnée de liste view vers excel
merci infiniment
13 juil. 2003 à 19:28
Cela dis, c'est propre, et ouai, y a bien une trace de la source depimousse75, je confirme, je m'en suis inspiré aussi.
12 oct. 2002 à 11:41
24 sept. 2002 à 22:57
mais sur l'axe des ordonnées les valeurs n'etaient pas prise en compte...
Je suis en format standard pour les colones saisie pour le graphique sous excel mais ca ne marche pas, même si je change de format....
24 sept. 2002 à 22:43
d'ailleur je te remercie.
Mais comment faire pour formater les colonnes?
Je sais pas comment faire, peux-tu m'aider?
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.