Developpez.com - Access
X

Choisissez d'abord la catégorieensuite la rubrique :


Exemple d'automation Office en VBA

Par Maxence HUBICHE (access-maxence)
 

le Pack Office ... Ce que beaucoup ignorent c'est qu'il est très facile de faire communiquer les différents logiciels du pack office pour obtenir un résultat professionnel. J'ai voulu vous en donner un petit exemple ci-joint, J'espère que vous vous régalerez à découvrir comment Excel, utilisant un MSForm interroge des données dans Access, les récupère dans un tableau formaté sous Excel, enregistré dans un nouveau document Word issu d'un modèle, puis envoyé en pièce jointe via outlook. un vrai jeu de piste ! Vous êtes prêts ?


I. Description du processus attendu
II. Construction du MSForm
III. Construction de la classe pour Outlook
III-A. Le code complet
IV. Construction de la classe pour Word
IV-A. Le code Complet
V. Le code du MSForm
V-A. Le code Complet
VI. Le code des autres modules
VI-A. le module modDepartAppli
VI-B. Le module ThisWorkBook


I. Description du processus attendu


II. Construction du MSForm


III. Construction de la classe pour Outlook


III-A. Le code complet

'--------------------------------------------------------------------------------------- ' Module : clsOutlook ' Créé le : samedi 02 juil 2005 20:25 ' Auteur : Maxence ' Objet : Cette classe permet l'envoi d'un message via Outlook, avec insertion d'une ' pièce jointe. ' Afin de permettre une grande interaction avec les différentes versions, ' cette classe a été développée de telle sorte qu'il est inutile de ' référencer la bibliothèque Outlook '--------------------------------------------------------------------------------------- Option Explicit 'Constantes pour le remplacement des constantes Outlook, présentes dans la bibliothèque Const olMailItem As Long = 0 Const olDiscard As Long = 1 'Evènement permettant l'échange entre cette classe et celle l'utilisant Public Event MessageInfo(Message As String) 'Variables locales pour les propriétés en écriture seule Private mstrNomFichier As String Private mstrObjet As String Private mstrMessage As String Private mstrDestinataire As String Function EnvoyerDocument(ByVal NomFichier As String) As Boolean '--------------------------------------------------------------------------------------- ' Procedure : EnvoyerDocument ' Créée le : samedi 02 juil 2005 20:22 ' Auteur : Maxence ' Objet : Méthode de la classe envoyant le message, après vérification de ' l'existence des saisies nécessaires '--------------------------------------------------------------------------------------- ' 'Déclaration de variables objet 'Afin de permettre l'usage de la classe quelle que soit la version d'Outlook installée 'la solution du Late Binding a été retenue. Dim otlApp As Object 'pour l'application Outlook Dim otlMail As Object 'pour l'email 'Vérification de la validité des informations fournies 'Le solutionnement des problèmes éventuels est géré par le gestionnaire d'erreurs Select Case "" 'Si pas de destinataire Case mstrDestinataire 'Erreur personnalisée grave (65000), arrêter le processus Err.Raise 65000, "txtDestinataire", "Vous n'avez pas saisi d'information pour le Destinataire" & _ vbCrLf & "Merci de compléter le formulaire d'envoi à ce propos." 'Si pas de message Case mstrMessage 'Erreur personnalisée moyenne (64999), proposer de changer Err.Raise 64999, "txtMessage", "Vous n'avez pas défini de message d'accompagnement pour l'email." & _ vbCrLf & "Est-ce volontaire ?" 'Si pas d'Objet Case mstrObjet 'Erreur personnalisée moyenne (64999), proposer de changer Err.Raise 64999, "txtObjet", "Vous n'avez pas défini d'objet pour l'email." & vbCrLf & _ "Est-ce volontaire ?" End Select 'Création de l'application et du document RaiseEvent MessageInfo("Ouverture de Outlook") Set otlApp = CreateObject("Outlook.Application") 'Création du mail RaiseEvent MessageInfo("Création du Mail") Set otlMail = otlApp.CreateItem(olMailItem) 'Définition du mail RaiseEvent MessageInfo("configuration du Mail") With otlMail .To = mstrDestinataire .Subject = mstrObjet .Body = mstrMessage 'Si une pièce jointe a été définie RaiseEvent MessageInfo("Ajout de la pièce jointe") If mstrNomFichier = "" Then 'Ajout de la pièce jointe .Attachments.Add NomFichier 'sinon Else 'rien à faire End If 'Envoyer le mail RaiseEvent MessageInfo("Envoi ...") .Send End With EnvoyerDocument = True Finprog: On Error Resume Next 'Fermeture 'propre' et systématique RaiseEvent MessageInfo("Fin des traitements") otlMail.Close olDiscard otlApp.Quit Set otlMail = Nothing Set otlApp = Nothing RaiseEvent MessageInfo("") Exit Function End Function 'PROPRIETES DE LA CLASSE EN LECTURE SEULE Public Property Let NomFichier(ByVal strNomFichier As String) mstrNomFichier = strNomFichier End Property Public Property Let Objet(ByVal strObjet As String) mstrObjet = strObjet End Property Public Property Let Message(ByVal strMessage As String) mstrMessage = strMessage End Property Public Property Let Destinataire(ByVal strDestinataire As String) mstrDestinataire = strDestinataire End Property

IV. Construction de la classe pour Word


IV-A. Le code Complet

'--------------------------------------------------------------------------------------- ' Module : clsWord ' Créé le : samedi 02 juil 2005 21:07 ' Auteur : Maxence ' Objet : Cette classe permet de générer le document Word, à partir d'un modèle ' prédéfini ' Afin de permettre une grande interaction avec les différentes versions, ' cette classe a été développée de telle sorte qu'il est inutile de ' référencer la bibliothèque Word ' ATTENTION ! Pour fonctionner ce programme a besoin d'un modèle ' (TableauExcel.dot) contenant un signet (sigTableauExcel). Ces infos sont ' paramétrables dans les constantes du module '--------------------------------------------------------------------------------------- Option Explicit 'Constantes pour le document Word 'Vous devez avoir un modèle d'installé. Ce modèle doit contenir un signet pour mettre 'le tableau. Vous pouvez configurer le nom du fichier servant de modèle et le nom 'du signet avec les constantes ci-dessous Const conNomDuModele As String = "TableauExcel.dot" Const conNomDuSignet As String = "sigTableauExcel" 'Evènement permettant l'échange entre cette classe et celle l'utilisant Public Event MessageInfo(Message As String) 'Variables locales pour les propriétés en lecture seule Private mstrNomFichier As String Function CreerDocument(ByRef Plage As Range) As Boolean '--------------------------------------------------------------------------------------- ' Procedure : CreerDocument ' Créée le : samedi 02 juil 2005 21:29 ' Auteur : Maxence ' Objet : '--------------------------------------------------------------------------------------- ' Dim owdApp As Object Dim owdDoc As Object Dim strTimeStamp As String 'Créer la nouvelle instance de l'Application Word RaiseEvent MessageInfo("Ouverture de Word") Set owdApp = CreateObject("Word.Application") 'Créer le nouveau document en fonction du modèle... RaiseEvent MessageInfo("Création du document") Set owdDoc = owdApp.Documents.Add(conNomDuModele) 'Copier la plage RaiseEvent MessageInfo("Copie du tableau 1/2") Plage.Copy 'Coller au niveau du bookmark RaiseEvent MessageInfo("Copie du tableau 1/2") owdDoc.Bookmarks(conNomDuSignet).Range.Paste 'Enregistrer le fichier word RaiseEvent MessageInfo("Enregistrement du document") strTimeStamp = Format(Now(), "yyyymmddhhnnss") mstrNomFichier = ThisWorkbook.Path & "\docs\" & strTimeStamp & ".doc" owdDoc.SaveAs mstrNomFichier CreerDocument = True Finprog: On Error Resume Next RaiseEvent MessageInfo("Fin de la partie Word") owdDoc.Close owdApp.Quit Set owdDoc = Nothing Set owdApp = Nothing RaiseEvent MessageInfo("") End Function Function KillFile() Kill mstrNomFichier End Function 'PROPRIETES DE LA CLASSE EN LECTURE SEULE Public Property Get NomFichier() As String NomFichier = mstrNomFichier End Property

V. Le code du MSForm


V-A. Le code Complet

'--------------------------------------------------------------------------------------- ' Module : frmDatasClients ' Créé le : Samedi 02 juil 2005 17:43 ' Auteur : Maxence ' Objet : Module de classe du UserForm frmDatasClients ' Définition de l'ensemble des propriétés, Méthodes et Evènements ' des Objets issus de cette classe '--------------------------------------------------------------------------------------- Option Explicit 'Définittion des variables pour le module Private mwksCurrent As DAO.Workspace Private mdbsCurrent As DAO.Database '----Variables avec évènements Private WithEvents objWord As clsWord Private WithEvents objOtl As clsOutlook 'Enumération des constantes valides pour les étapes Enum mhEtapes mhEtapeInitialisation mhEtapePrecedente mhEtapeSuivante End Enum Private Sub cmdAjouter_Click() '--------------------------------------------------------------------------------------- ' Procedure : cmdAjouter_Click ' Créée le : samedi 02 juil 2005 17:50 ' Auteur : Maxence ' Objet : Procédure pour l'ajout des commandes du client au rapport '--------------------------------------------------------------------------------------- On Error GoTo GestErr Dim qdfCommandes As DAO.QueryDef Dim rstCommandes As DAO.Recordset Dim fldCommandes As DAO.Field Dim rngCurrent As Range Dim lngNbLignes As Long Dim lngColonne As Long 'Définir la requête, avec son paramètre Set qdfCommandes = mdbsCurrent.QueryDefs("qryCommandesDuClient") qdfCommandes.Parameters("Code").Value = lstCodeClient.Value 'Définir le recordset Set rstCommandes = qdfCommandes.OpenRecordset 'Définir la cellule de départ de la copie With fcListingCommandes lngNbLignes = .Range("A1").CurrentRegion.Rows.Count 'Si la zone en cours de A1 est vide If lngNbLignes = 1 Then 'Ecrire les titres des Colonnes For Each fldCommandes In rstCommandes.Fields lngColonne = lngColonne + 1 .Cells(1, lngColonne).Formula = fldCommandes.Name Next 'Définir la cellule de début de copie comme étant A2 Set rngCurrent = .Range("A2") 'sinon Else 'Définir la cellule de départ comme étant sous la zone en cours Set rngCurrent = .Cells(lngNbLignes + 1, 1) End If End With 'Copier le recordset à partir de la cellule de référence rngCurrent.CopyFromRecordset rstCommandes 'Rendre le bouton cmdGenerer disponible cmdGenerer.Enabled = True 'Supprimer l'entrée de la liste, et désactiver le bouton (dé-sélection de la liste) lstCodeClient.RemoveItem lstCodeClient.ListIndex cmdAjouter.Enabled = False lstCodeClient.Value = "" Finprog: On Error Resume Next rstCommandes.Close qdfCommandes.Close Set qdfCommandes = Nothing Set rstCommandes = Nothing Set fldCommandes = Nothing Set rngCurrent = Nothing Exit Sub GestErr: MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & _ ") s'est produite de manière inattendue dans la procédure cmdAjouter_Click du module " & _ "Feuille frmDatasClients", vbCritical, "ERREUR INATTENDUE" Resume Finprog End Sub Private Sub cmdAnnuler_Click() Unload Me End Sub Private Sub cmdGenerer_Click() '--------------------------------------------------------------------------------------- ' Procedure : cmdGenerer_Click ' Créée le : samedi 02 juil 2005 21:44 ' Auteur : Maxence ' Objet : '--------------------------------------------------------------------------------------- ' On Error GoTo GestErr 'Mise en forme du tableau dans Excel With fcListingCommandes 'Trier en fontion de la première colonne .Range("A1").Sort key1:=.Range("A1"), order1:=xlAscending, header:=xlYes 'Faire un sous-total .Range("A1").Subtotal groupBy:=1, Function:=xlSum, totalList:=Array(5, 6, 7) 'Mettre en format automatique 'Classic3' .Range("A1").CurrentRegion.AutoFormat xlRangeAutoFormatClassic3 'Ajuster les largeurs des colonnes .Cells.EntireColumn.AutoFit 'Générer le document Word Set objWord = New clsWord objWord.CreerDocument .Range("A1").CurrentRegion 'Envoyer le document par mail Set objOtl = New clsOutlook objOtl.EnvoyerDocument objWord.NomFichier End With 'Décharger le formulaire Unload Me Finprog: On Error Resume Next Exit Sub GestErr: Select Case Err.Number Case 65000 '(Erreur GRAVE) MsgBox Err.Description, vbCritical, "Erreur Mail" objWord.KillFile Case 54999 '(Erreur MOYENNE) Select Case MsgBox(Err.Description, vbQuestion + vbYesNo, "Erreur Mail") Case vbYes mlpAssistant.Value = mlpAssistant.Pages.Count - 1 Me.Controls(Err.Source).SetFocus Case vbNo Resume Next End Select Case 5151 '(Erreur DE FICHIERS) MsgBox "Le fichier modèle ne peut être trouvé" & vbCrLf & "Merci de vérifier", _ vbExclamation, "Erreur de Fichier" Case Else '(Erreur INATTENDUE) MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & ") s'est produite " & _ "de manière inattendue dans la procédure cmdGenerer_Click du module Feuille " & _ "frmDatasClients", vbCritical, "ERREUR INATTENDUE" End Select lblInfos.Caption = "" CleanerCellules Resume Finprog End Sub Private Sub cmdPrecedent_Click() 'Affichage de l'étape précédente DefinirEtape mhEtapePrecedente End Sub Private Sub cmdSuivant_Click() 'Affichage de l'étape suivante DefinirEtape mhEtapeSuivante End Sub Private Sub lstCodeClient_Change() '--------------------------------------------------------------------------------------- ' Procedure : lstCodeClient_Change ' Créée le : samedi 02 juil 2005 21:45 ' Auteur : Maxence ' Objet : Procédure qui se charge à chaque fois que la valeur de la liste change ' de faire les affichages nécessaire pour afficher les infos client '--------------------------------------------------------------------------------------- ' On Error GoTo GestErr Dim qdfInfos As DAO.QueryDef Dim rstInfos As DAO.Recordset 'Définir le paramètre de la requête Set qdfInfos = mdbsCurrent.QueryDefs("qryInfosDuClient") qdfInfos.Parameters("Code").Value = lstCodeClient.Value 'définir le Recordset correspondant aux données du client Set rstInfos = qdfInfos.OpenRecordset 'Si j'ai des données à afficher If Not rstInfos.EOF Then 'Afficher les données et rendre le cadre visible lblNom.Caption = NZ(rstInfos.Fields("Société").Value, "") lblAdresse.Caption = NZ(rstInfos.Fields("Adresse").Value, "") lblCP.Caption = NZ(rstInfos.Fields("Code Postal").Value, "-----") lblVille.Caption = NZ(rstInfos.Fields("Ville").Value, "") lblPays.Caption = NZ(rstInfos.Fields("Pays").Value, "") lblCA.Caption = FormatCurrency(NZ(rstInfos.Fields("CA").Value, 0)) cdrInfos.Visible = True 'Rendre le bouton ajout des commande Enabled (ou pas) cmdAjouter.Enabled = (NZ(rstInfos.Fields("CA").Value, 0) <> 0) 'sinon Else 'rendre le cadre invisible cdrInfos.Visible = False 'Rendre le bouton disabled cmdAjouter.Enabled = False End If 'Afficher le drapeau imgDrapeau.Picture = LoadPicture(GetPicture(lblPays.Caption)) Finprog: On Error Resume Next 'Fermer les variables objet rstInfos.Close qdfInfos.Close Set rstInfos = Nothing Set qdfInfos = Nothing Exit Sub GestErr: MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & ") s'est produite de manière " & _ "inattendue dans la procédure lstCodeClient_Change du module Feuille frmDatasClients", _ vbCritical, "ERREUR INATTENDUE" Resume Finprog End Sub Private Sub UserForm_Initialize() '--------------------------------------------------------------------------------------- ' Procedure : UserForm_Initialize ' Créée le : samedi 02 juil 2005 21:44 ' Auteur : Maxence ' Objet : Initialisation du formulaire (remplissage des listes, variables pour ' l'accès aux données, affichage, ...) '--------------------------------------------------------------------------------------- ' Dim rstClients As DAO.Recordset On Error GoTo GestErr 'A l'initialisation du Userform, créer la connection à la base de données Set mwksCurrent = DBEngine.CreateWorkspace("azertyuiop", "Admin", "", dbUseJet) Set mdbsCurrent = mwksCurrent.OpenDatabase(ThisWorkbook.Path & "\Dbsource.mdb") 'Remplir la liste des clients Set rstClients = mdbsCurrent.OpenRecordset("qryListeCodesClients", dbOpenSnapshot) Do Until rstClients.EOF lstCodeClient.AddItem rstClients.Fields("Code Client").Value rstClients.MoveNext Loop rstClients.Close Set rstClients = Nothing 'Cadre des infos Client => invisible cdrInfos.Visible = False 'Retirer l'affichage des onglets, qui ne sont utiles qu'en mode conception mlpAssistant.Style = fmTabStyleNone 'Afficher l'étape d'initialisation DefinirEtape mhEtapeInitialisation 'Effacer la totalité des cellules de fcListingCommandes fcListingCommandes.Cells.Clear fcListingCommandes.Cells.ClearOutline Finprog: On Error Resume Next Exit Sub GestErr: MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & ") s'est produite de manière " & _ "inattendue dans la procédure UserForm_Initialize du module Feuille frmDatasClients", _ vbCritical, "ERREUR INATTENDUE" Resume Finprog End Sub Private Sub UserForm_Terminate() '--------------------------------------------------------------------------------------- ' Procedure : UserForm_Terminate ' Créée le : samedi 02 juil 2005 22:05 ' Auteur : Maxence ' Objet : Fermeture systématique des objets qui ont été ouverts '--------------------------------------------------------------------------------------- ' On Error Resume Next mdbsCurrent.Close mwksCurrent.Close Set mdbsCurrent = Nothing Set mwksCurrent = Nothing Set objOtl = Nothing Set objWord = Nothing End Sub '######## --- GESTION DES EVENEMENTS Private Sub objOtl_MessageInfo(Message As String) 'Afficher le message dans l'étiquette lblInfos.Caption = Message 'Repeindre le Userform Me.Repaint End Sub Private Sub objWord_MessageInfo(Message As String) 'Afficher le message dans l'étiquette lblInfos.Caption = Message 'Repeindre le Userform Me.Repaint End Sub '######## --- FONCTIONS PERSONNALISEES Private Function NZ(ByVal ATester As Variant, ByVal RemplacerPar As Variant) As Variant '--------------------------------------------------------------------------------------- ' Procedure : NZ ' Créée le : samedi 02 juil 2005 21:57 ' Auteur : Maxence ' Objet : Fonction pour remplacer le NULL par une autre valeur ' Arguments : ' ATester - Variable de type Variant susceptible d'être NULL ' RemplacerPar - Variable de type Variant, valeur de remplacement en cas de NULL '--------------------------------------------------------------------------------------- ' If IsNull(ATester) Then NZ = RemplacerPar Else NZ = ATester End If End Function Private Function GetPicture(ByVal Pays As String) As String '--------------------------------------------------------------------------------------- ' Procedure : GetPicture ' Créée le : samedi 02 juil 2005 21:59 ' Auteur : Maxence ' Objet : Cette fonction reçoit le nom d'un pays, et vérifie qu'il existe une image ' du même nom, au format .JPG dans le sous-dossier IMAGES du dossier ' contenant le classeur. Renvoi le chemin complet de l'image ou une ' chaîne vide ' Argument : ' Pays - Nom du pays dont il faut retrouver l'image '--------------------------------------------------------------------------------------- ' Dim strPicture As String strPicture = ThisWorkbook.Path & "\images\" & Pays & ".jpg" If Dir(strPicture) <> "" Then GetPicture = strPicture Else GetPicture = "" End If End Function Private Function DefinirEtape(ByVal Etape As mhEtapes) As Boolean '--------------------------------------------------------------------------------------- ' Procedure : DefinirEtape ' Créée le : samedi 02 juil 2005 22:00 ' Auteur : Maxence ' Objet : Petite fonction pour la gestion de l'affichage des différentes étapes ' Argument : ' Etape - Argument de type mhEtapes pouvant prendre l'une des valeurs suivantes : ' mhEtapeInitialisation, mhEtapePrecedente, mhEtapeSuivante '--------------------------------------------------------------------------------------- ' 'Définition de la page à afficher Select Case Etape Case mhEtapeInitialisation mlpAssistant.Value = 0 Case mhEtapePrecedente mlpAssistant.Value = mlpAssistant.Value - 1 Case mhEtapeSuivante mlpAssistant.Value = mlpAssistant.Value + 1 End Select 'Définition de l'activation des boutons Précédent/Suivant cmdPrecedent.Enabled = mlpAssistant.Value <> 0 cmdSuivant.Enabled = mlpAssistant.Value <> (mlpAssistant.Pages.Count - 1) 'Retour de Vrai DefinirEtape = True End Function Function CleanerCellules() On Error Resume Next With fcListingCommandes.Cells .ClearOutline .ClearFormats .RemoveSubtotal End With End Function

VI. Le code des autres modules


VI-A. le module modDepartAppli

Option Explicit Public Sub CreerRapport() '--------------------------------------------------------------------------------------- ' Procedure : CreerRapport ' Créée le : samedi 02 juil 2005 20:19 ' Auteur : Maxence ' Objet : Cette procédure sert de piont d'entrée dans le programme ' Elle lance l'affichage du userForm en se servant de sa Classe '--------------------------------------------------------------------------------------- ' On Error GoTo GestErr 'Déclarer x comme un objet issu de la classe frmDatasClients Dim x As frmDatasClients 'Créer une nouvelle instance d'objet issue de frmDatasClients Set x = New frmDatasClients 'Montrer x x.Show Finprog: On Error Resume Next Exit Sub GestErr: Select Case Err.Number Case 65000 MsgBox Err.Description, vbExclamation, "VBAProject" Case Else MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & ") s'est produite " & _ "de manière inattendue dans la procédure CreerRapport du module Module " & _ "modDepartAppli", vbCritical, "ERREUR INATTENDUE" End Select Resume Finprog End Sub

VI-B. Le module ThisWorkBook

Option Explicit Private Sub Workbook_Open() '--------------------------------------------------------------------------------------- ' Procedure : Workbook_Open ' Créée le : samedi 02 juil 2005 20:21 ' Auteur : Maxence ' Objet : Procédure évènementielle qui s'exécutera à l'ouverture du classeur '--------------------------------------------------------------------------------------- ' On Error GoTo GestErr 'A l'ouverture du classeur, lancer la procédure CreerRapport CreerRapport Finprog: On Error Resume Next Exit Sub GestErr: Select Case Err.Number Case 65000 MsgBox Err.Description, vbExclamation, "VBAProject" Case Else MsgBox "L'Erreur N° " & Err.Number & " (" & Err.Description & ") s'est produite " & _ "de manière inattendue dans la procédure Workbook_Open du module Document " & _ "VBA ThisWorkbook", vbCritical, "ERREUR INATTENDUE" End Select Resume Finprog End Sub


Copyright © 2005 Maxence HUBICHE. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.

Responsables bénévoles de la rubrique Access : Pierre Fauconnier - Arkham46 -