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
Option Explicit
Const olMailItem As Long = 0
Const olDiscard As Long = 1
Public Event MessageInfo(Message As String)
Private mstrNomFichier As String
Private mstrObjet As String
Private mstrMessage As String
Private mstrDestinataire As String
Function EnvoyerDocument(ByVal NomFichier As String) As Boolean
Dim otlApp As Object
Dim otlMail As Object
Select Case ""
Case mstrDestinataire
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."
Case mstrMessage
Err.Raise 64999, "txtMessage", "Vous n'avez pas défini de message d'accompagnement pour l'email." & _
vbCrLf & "Est-ce volontaire ?"
Case mstrObjet
Err.Raise 64999, "txtObjet", "Vous n'avez pas défini d'objet pour l'email." & vbCrLf & _
"Est-ce volontaire ?"
End Select
RaiseEvent MessageInfo("Ouverture de Outlook")
Set otlApp = CreateObject("Outlook.Application")
RaiseEvent MessageInfo("Création du Mail")
Set otlMail = otlApp.CreateItem(olMailItem)
RaiseEvent MessageInfo("configuration du Mail")
With otlMail
.To = mstrDestinataire
.Subject = mstrObjet
.Body = mstrMessage
RaiseEvent MessageInfo("Ajout de la pièce jointe")
If mstrNomFichier = "" Then
.Attachments.Add NomFichier
Else
End If
RaiseEvent MessageInfo("Envoi ...")
.Send
End With
EnvoyerDocument = True
Finprog:
On Error Resume Next
RaiseEvent MessageInfo("Fin des traitements")
otlMail.Close olDiscard
otlApp.Quit
Set otlMail = Nothing
Set otlApp = Nothing
RaiseEvent MessageInfo("")
Exit Function
End Function
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
Option Explicit
Const conNomDuModele As String = "TableauExcel.dot"
Const conNomDuSignet As String = "sigTableauExcel"
Public Event MessageInfo(Message As String)
Private mstrNomFichier As String
Function CreerDocument(ByRef Plage As Range) As Boolean
Dim owdApp As Object
Dim owdDoc As Object
Dim strTimeStamp As String
RaiseEvent MessageInfo("Ouverture de Word")
Set owdApp = CreateObject("Word.Application")
RaiseEvent MessageInfo("Création du document")
Set owdDoc = owdApp.Documents.Add(conNomDuModele)
RaiseEvent MessageInfo("Copie du tableau 1/2")
Plage.Copy
RaiseEvent MessageInfo("Copie du tableau 1/2")
owdDoc.Bookmarks(conNomDuSignet).Range.Paste
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
Public Property Get NomFichier() As String
NomFichier = mstrNomFichier
End Property
V. Le code du MSForm
V-A. Le code Complet
Option Explicit
Private mwksCurrent As DAO.Workspace
Private mdbsCurrent As DAO.Database
Private WithEvents objWord As clsWord
Private WithEvents objOtl As clsOutlook
Enum mhEtapes
mhEtapeInitialisation
mhEtapePrecedente
mhEtapeSuivante
End Enum
Private Sub cmdAjouter_Click()
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
Set qdfCommandes = mdbsCurrent.QueryDefs("qryCommandesDuClient")
qdfCommandes.Parameters("Code").Value = lstCodeClient.Value
Set rstCommandes = qdfCommandes.OpenRecordset
With fcListingCommandes
lngNbLignes = .Range("A1").CurrentRegion.Rows.Count
If lngNbLignes = 1 Then
For Each fldCommandes In rstCommandes.Fields
lngColonne = lngColonne + 1
.Cells(1, lngColonne).Formula = fldCommandes.Name
Next
Set rngCurrent = .Range("A2")
Else
Set rngCurrent = .Cells(lngNbLignes + 1, 1)
End If
End With
rngCurrent.CopyFromRecordset rstCommandes
cmdGenerer.Enabled = True
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()
On Error GoTo GestErr
With fcListingCommandes
.Range("A1").Sort key1:=.Range("A1"), order1:=xlAscending, header:=xlYes
.Range("A1").Subtotal groupBy:=1, Function:=xlSum, totalList:=Array(5, 6, 7)
.Range("A1").CurrentRegion.AutoFormat xlRangeAutoFormatClassic3
.Cells.EntireColumn.AutoFit
Set objWord = New clsWord
objWord.CreerDocument .Range("A1").CurrentRegion
Set objOtl = New clsOutlook
objOtl.EnvoyerDocument objWord.NomFichier
End With
Unload Me
Finprog:
On Error Resume Next
Exit Sub
GestErr:
Select Case Err.Number
Case 65000
MsgBox Err.Description, vbCritical, "Erreur Mail"
objWord.KillFile
Case 54999
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
MsgBox "Le fichier modèle ne peut être trouvé" & vbCrLf & "Merci de vérifier", _
vbExclamation, "Erreur de Fichier"
Case Else
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()
DefinirEtape mhEtapePrecedente
End Sub
Private Sub cmdSuivant_Click()
DefinirEtape mhEtapeSuivante
End Sub
Private Sub lstCodeClient_Change()
On Error GoTo GestErr
Dim qdfInfos As DAO.QueryDef
Dim rstInfos As DAO.Recordset
Set qdfInfos = mdbsCurrent.QueryDefs("qryInfosDuClient")
qdfInfos.Parameters("Code").Value = lstCodeClient.Value
Set rstInfos = qdfInfos.OpenRecordset
If Not rstInfos.EOF Then
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
cmdAjouter.Enabled = (NZ(rstInfos.Fields("CA").Value, 0) <> 0)
Else
cdrInfos.Visible = False
cmdAjouter.Enabled = False
End If
imgDrapeau.Picture = LoadPicture(GetPicture(lblPays.Caption))
Finprog:
On Error Resume Next
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()
Dim rstClients As DAO.Recordset
On Error GoTo GestErr
Set mwksCurrent = DBEngine.CreateWorkspace("azertyuiop", "Admin", "", dbUseJet)
Set mdbsCurrent = mwksCurrent.OpenDatabase(ThisWorkbook.Path & "\Dbsource.mdb")
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
cdrInfos.Visible = False
mlpAssistant.Style = fmTabStyleNone
DefinirEtape mhEtapeInitialisation
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()
On Error Resume Next
mdbsCurrent.Close
mwksCurrent.Close
Set mdbsCurrent = Nothing
Set mwksCurrent = Nothing
Set objOtl = Nothing
Set objWord = Nothing
End Sub
Private Sub objOtl_MessageInfo(Message As String)
lblInfos.Caption = Message
Me.Repaint
End Sub
Private Sub objWord_MessageInfo(Message As String)
lblInfos.Caption = Message
Me.Repaint
End Sub
Private Function NZ(ByVal ATester As Variant, ByVal RemplacerPar As Variant) As Variant
If IsNull(ATester) Then
NZ = RemplacerPar
Else
NZ = ATester
End If
End Function
Private Function GetPicture(ByVal Pays As String) As String
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
Select Case Etape
Case mhEtapeInitialisation
mlpAssistant.Value = 0
Case mhEtapePrecedente
mlpAssistant.Value = mlpAssistant.Value - 1
Case mhEtapeSuivante
mlpAssistant.Value = mlpAssistant.Value + 1
End Select
cmdPrecedent.Enabled = mlpAssistant.Value <> 0
cmdSuivant.Enabled = mlpAssistant.Value <> (mlpAssistant.Pages.Count - 1)
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()
On Error GoTo GestErr
Dim x As frmDatasClients
Set x = New frmDatasClients
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()
On Error GoTo GestErr
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
|