Soyez le premier à donner votre avis sur cette source.
Snippet vu 10 228 fois - Téléchargée 38 fois
Option Compare Database Option Explicit Public Monjeuenreg As String Public Sub Recherche_Click() 'construction d'une requête SQL ' Crée une clause WHERE en utilisant le critère recherche entré ' par l'utilisateur et définit la propriété Source (RecordSource) ' du sous-formulaire affichage Dim Monsql As String, MonCritère As String Dim NbrArg As Integer Dim Tmp As Variant ' Initialise le compteur d'argument. NbrArg = 0 ' Initialise l'instruction SELECT. Monsql = "SELECT * FROM R_Recherche WHERE" MonCritère = "" ' Utilise les valeurs entrées dans les zones de texte de l'en-tête de fomrulaire ' pour créer les critères de la clause WHERE. entre " " le nom du champ AjouteràWhere [Groupe_tx], "[e_Groupe]", MonCritère, NbrArg AjouteràWhere [Espece_tx], "[o_Espece]", MonCritère, NbrArg ' Si aucun critère n'est spécifié, renvoie tous les enregistrements. If MonCritère = "" Then MonCritère = "True" End If ' Crée l'instruction SELECT. Monjeuenreg = Monsql & MonCritère ' Défini la propriété RecordSource du sous-formulaire recherche. Me![Sousform_affichage].Form.RecordSource = Monjeuenreg ' Si aucun enregistrement ne correspond aux critères, affiche un message. ' Active le bouton Effacer. If Me![Sousform_affichage].Form.RecordsetClone.RecordCount = 0 Then MsgBox "Aucun enregistrement ne correspond aux critères introduits.", 48, "Aucun enregistrements trouvés" Me!SupprimerRecherche.SetFocus Else ' Active le contrôle dans la section détail. Tmp = ActiveContrôles("Detail", True) ' Place le point d'insertion dans le sous-formulaire. Me![Sousform_affichage].SetFocus End If End Sub Private Sub AjouteràWhere(ValeurChamp As Variant, NomChamp As String, MonCritère As String, NbrArg As Integer) Dim opérateur As String, ponctue As String, cote As String ' Crée le critère pour la clause WHERE. opérateur = " like " ponctue = "*" cote = "'" If ValeurChamp <> "" Then ' Ajoute "et" si aucun critère existe. If NbrArg > 0 Then MonCritère = MonCritère & " And " End If If ValeurChamp <> "" And NomChamp = "[e_Groupe 44]" Then opérateur = " like " ponctue = "" cote = "'" End If ' Ajoute le critère aux critères existants MonCritère = (MonCritère & NomChamp & opérateur & cote & ValeurChamp & ponctue & cote) ' Augmente le compteur d'argument. NbrArg = NbrArg + 1 End If End Sub Private Sub SupprimerRecherche_Click() ' remettre les champs à null Dim Monsql As String Monsql = "SELECT * FROM R_Recherche WHERE False" Me![Groupe_tx] = Null Me![Espece_tx] = Null ' Réinitialise la propriété RecordSource du sous-formualire pour retirer les enregistrements. Me![Sousform_affichage].Form.RecordSource = Monsql ' Place le point d'insertion dans la première zone de texte Recherche. Me![Espece_tx].SetFocus End Sub Option Compare Database Option Explicit Function ActiveContrôles(QuelleSection As String, Etat As Integer) As Integer Dim MonFormulaire As Form Dim MonContrôle As Control Dim i As Integer, SectionChoisie As Integer On Error Resume Next Set MonFormulaire = Screen.ActiveForm If Err Then ActiveContrôles = False On Error GoTo 0 Exit Function End If Select Case UCase$(QuelleSection) Case "FORM HEADER" SectionChoisie = 1 Case "PAGE HEADER" SectionChoisie = 3 Case "DETAIL" SectionChoisie = 0 Case "PAGE FOOTER" SectionChoisie = 4 Case "FORM FOOTER" SectionChoisie = 2 Case Else MsgBox "Argument invalide", , "ActiveContrôles" ActiveContrôles = False Exit Function End Select For i = 0 To MonFormulaire.Count - 1 Set MonContrôle = MonFormulaire(i) If MonContrôle.Section = SectionChoisie Then On Error Resume Next MonContrôle.Enabled = Etat On Error GoTo 0 End If Next i ActiveContrôles = True End Function
10 août 2004 à 00:57
espérant que cela t'aide ... du moins t'inspire !!
Private Sub mnuExportExcel_Click()
Dim Prenom, Nom, Telephone, Cellulaire, Padget, Adresse, Email, Commentaires As String
Dim Colonne, Rangee As String
Dim Row As Integer
Dim ReturnVal
Row = 2
adoCarnet.Recordset.MoveFirst
If (txtPrenom.LinkMode vbnone And txtNom.LinkMode vbnone) Then
'execution d'excel
ReturnVal = Shell("D:\Program Files\Microsoft Office\Office11\Excel.exe", 3)
If ReturnVal Then
txtPrenom.LinkTopic = "Excel|Book1" ' Définit la rubrique de liaison.
txtPrenom.LinkItem = "R1C1" ' Définit l'élément de liaison.
txtPrenom.LinkMode = vbLinkManual ' Définit le mode de liaison.
txtNom.LinkTopic = "Excel|Book1" ' Définit la rubrique de liaison.
txtNom.LinkItem = "R1C2" ' Définit l'élément de liaison.
txtNom.LinkMode = vbLinkManual ' Définit le mode de liaison.
txtTelephone.LinkTopic = "Excel|Book1"
txtTelephone.LinkItem = "R1C3"
txtTelephone.LinkMode = vbLinkManual
txtPadget.LinkTopic = "Excel|Book1"
txtPadget.LinkItem = "R1C4"
txtPadget.LinkMode = vbLinkManual
txtCellulaire.LinkTopic = "Excel|Book1"
txtCellulaire.LinkItem = "R1C5"
txtCellulaire.LinkMode = vbLinkManual
txtCommentaire.LinkTopic = "Excel|Book1"
txtCommentaire.LinkItem = "R1C6"
txtCommentaire.LinkMode = vbLinkManual
End If
End If
Do While Not adoCarnet.Recordset.EOF
Row = Row + 1 ' Définit le numéro de ligne.
txtPrenom.LinkItem = "R" & Row & "C1" ' Défint l'élément de liaison.
txtPrenom.LinkPoke ' Force le transfert de la valeur dans la cellule.
txtNom.LinkItem = "R" & Row & "C2" ' Définit l'élément de liaison.
txtNom.LinkPoke ' Force le transfert de la valeur dans la cellule.
txtTelephone.LinkItem = "R" & Row & "C3" ' Définit l'élément de liaison.
txtTelephone.LinkPoke ' Force le transfert de la valeur dans la cellule.
txtPadget.LinkItem = "R" & Row & "C4" ' Définit l'élément de liaison.
txtPadget.LinkPoke ' Force le transfert de la valeur dans la cellule.
txtCellulaire.LinkItem = "R" & Row & "C5" ' Définit l'élément de liaison.
txtCellulaire.LinkPoke ' Force le transfert de la valeur dans la cellule.
txtCommentaire.LinkItem = "R" & Row & "C6" ' Définit l'élément de liaison.
txtCommentaire.LinkPoke ' Force le transfert de la valeur dans la cellule.
adoCarnet.Recordset.MoveNext
Loop
End Sub
8 août 2004 à 11:44
et ecrire un truc du genre :
Dim cnSrc As New ADODB.Connection
Dim monsql As String
Dim moncritere as String
Screen.MousePointer = vbHourglass
DoEvents
cnSrc.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=(ma base de données access.mdb);Persist Security Info=False"
'select * from matable into [Excel 8.0; Database=test.xls]
cnSrc.Execute Monsqll & "INTO [Excel 8.0;" & _
"Database="Nom du fichier excel "]" & Mon critere, num_copied
cnSrc.Close
Screen.MousePointer = vbDefault
MsgBox "Copiés " & num_copied & " lignes."
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.