Le portail francophone de la géomatique

Public Function EditerDocumentWord(ByVal strCheminModeleWord As String, ByVal strCheminDocumentWord As String, ByRef dicMotsReserves As Dictionary) As Boolean

' Description : edite un document MS Word à partir d'un modèle MS Word et d'un dictionnaire de mots réservés et indique
'               si l 'édition a été effectuée
'
' Paramètres   :
'
'   - strCheminDocumentWord : chemin absolu du document MS Word à éditer
'   - strCheminModeleWord   : chemin absolu du modèle MS Word
'   - dicMotsReserves       : mots réservés à insérer dans le document Word.

    On Error GoTo Erreur

    Dim pApplicationWord As Word.Application    ' Application Word
    Dim pDocumentWord As Word.Document          ' Document Word à produire
    Dim objShape As InlineShape                 ' Objet image si l'utilisateur souhaite insérer des images
    
    Dim pFileSystemObject As FileSystemObject   ' Accès au système de fichier

    Dim pCodesMotsReserves()
    
    Dim strSignet As String                     ' Nom du signet
    Dim strCodeParametre As String              ' Code du paramètre
    Dim i, j As Integer                         ' Compteur
    Dim intNbSignets As Integer                 ' Nombre de signets
    Dim intNbConseils As Integer                ' Nombre de conseils non sélectionnés
    Dim numboucle As Long                       ' Nombre de boucles pour les chaînes de caractères de plus de 200 caractères


    Set pFileSystemObject = New FileSystemObject


    'si le modèle n'existe pas, on arrête
    If Not (pFileSystemObject.FileExists(strCheminModeleWord)) Then
        MsgBox "Le modèle '" & strCheminModeleWord & "' est introuvable. Edition abandonnée...", vbExclamation, "Fichier introuvable"
        Exit Function
    End If

    'si le document à éditer existe déjà, on demande si on veut le remplacer
    If pFileSystemObject.FileExists(strCheminDocumentWord) Then
        If MsgBox("Le fichier '" & strCheminDocumentWord & "' existe déjà." & vbCrLf & "Voulez-vous le remplacer?", _
           vbExclamation + vbYesNo, "Fichier existant") = vbNo Then
                Exit Function
        End If
    End If

    ' Récupération de l'application Word
    Set pApplicationWord = GetWord

    'on place le processus Word en tâche de fond pour ne pas ralentir l'édition
    pApplicationWord.Visible = False
    
    ' Copie du modèle. Cette copie devient le document à produire.
    pFileSystemObject.CopyFile strCheminModeleWord, strCheminDocumentWord, True
    
    
    'Ouverture du document MS Word
     pApplicationWord.Documents.Open FileName:=strCheminDocumentWord

    'Exemple de parcours de signets du document
    intNbSignets = pApplicationWord.ActiveDocument.Bookmarks.Count
    For i = 1 To intNbSignets

        'on récupère le signet en majuscules
        strSignet = UCase(pApplicationWord.ActiveDocument.Bookmarks.Item(i).Name)
        
        'si le signet existe dans le dictionnaire des mots réservés
        If dicMotsReserves.Exists(strSignet) Then

           'on effectue le traitement de son choix

        'sinon, on supprime ce que le signet contient
        Else
            pApplicationWord.ActiveDocument.Bookmarks(strSignet).Select

            'exemple pour un tableau
            'pApplicationWord.Selection.Tables(1).Delete
            
            'exemple pour une ligne de tableau
            'pApplicationWord.Selection.Rows.Delete
            
            'exemple avec du texte
            Selection.Delete Unit:=wdCharacter, Count:=1

            i = i - 1
        End If

        If i = pApplicationWord.ActiveDocument.Bookmarks.Count Then
            Exit For
        End If
    Next i

    
    'Injection du dictionnaire dans le document

    pCodesMotsReserves = dicMotsReserves.Keys
    For i = 0 To dicMotsReserves.Count - 1
    
      If Not IsNull(dicMotsReserves(pCodesMotsReserves(i))) Then
            
    ' possibilité d'insérer des images
     
       's'agit-il d'un fichier image ? (test sur l'extension censée terminer la chaine)
       If InStr(1, ".bmp.jpg.png.gif", Right(dicMotsReserves(pCodesMotsReserves(i)), 4)) <> 0 Then
         
        'le fichier est-il présent sur le disque ?
        If pFileSystemObject.FileExists(dicMotsReserves(pCodesMotsReserves(i))) Then
            'on se positionne en page 1
            pApplicationWord.Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst
      
            'on recherche le mot réservé
            pApplicationWord.Selection.Find.ClearFormatting
            With pApplicationWord.Selection.Find
                .Text = pCodesMotsReserves(i)
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
        
           'on remplace le mot par une insertion d'image
           'on répète l'opération tant que le mot clé est trouvé
           
           Do While pApplicationWord.Selection.Find.Execute
             Set objShape = pApplicationWord.Selection.InlineShapes.AddPicture(FileName:=dicMotsReserves(pCodesMotsReserves(i)), LinkToFile:=False, SaveWithDocument:=True)
             With objShape
                .LockAspectRatio = True
                .ScaleHeight = 100
                .ScaleWidth = 100
             End With
             Set objShape = Nothing
           Loop
        End If
        
       'ce n'est pas une image mais du texte
       Else
        
        'la chaine dépasse t'elle 200 caractères ?
        'traitement nécessaire car on utilise la fonction rechercher/remplacer de MS Word qui n'accepte que 255 caractères au maximum

        If Len(dicMotsReserves(pCodesMotsReserves(i))) > 200 Then
          
          'on calcule le nombre de boucles

          If Len(dicMotsReserves(pCodesMotsReserves(i))) Mod 200 = 0 Then
            numboucle = Len(dicMotsReserves(pCodesMotsReserves(i))) / 200
          Else
            numboucle = (Len(dicMotsReserves(pCodesMotsReserves(i))) / 200) + 1
          End If

          'on remplace par paquet de 200 caractères auxquels on ajoute le mot réservé pour permettre le déroulement des boucles
          For j = 0 To (numboucle - 1)
             With pApplicationWord.Selection.Find
                 .Text = pCodesMotsReserves(i)
                 .ClearFormatting
                 .Replacement.Text = Mid(dicMotsReserves(pCodesMotsReserves(i)), (j * 200) + 1, 200) & pCodesMotsReserves(i)
                 .Replacement.ClearFormatting
                 .Forward = True
                 .Wrap = wdFindContinue
                 .Format = False
                 .MatchCase = False
                 .MatchWholeWord = False
                 .MatchAllWordForms = False
                 .MatchWildcards = False
                 .MatchSoundsLike = False
             End With
             pApplicationWord.Selection.Find.Execute Replace:=wdReplaceAll
          
          Next j
            
          'on supprime le mot réservé
          With pApplicationWord.Selection.Find
             .Text = pCodesMotsReserves(i)
             .Replacement.Text = ""
             .Forward = True
             .Wrap = wdFindContinue
             .Format = False
             .MatchCase = False      'Non respect de la casse
             .MatchWholeWord = False
             .MatchAllWordForms = False
             .MatchWildcards = False
             .MatchSoundsLike = False
          End With
          pApplicationWord.Selection.Find.Execute Replace:=wdReplaceAll
          
 
        'la chaîne de caractères n'excéde pas 200 caractères
        'rechercher-remplacer classique
        Else
        
          With pApplicationWord.Selection.Find
            .Text = pCodesMotsReserves(i)
            .ClearFormatting
            .Replacement.Text = dicMotsReserves(pCodesMotsReserves(i))
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchWildcards = False
            .MatchSoundsLike = False
          End With
          pApplicationWord.Selection.Find.Execute Replace:=wdReplaceAll

        End If '200 caractères
       End If 'image ou texte
      End If 'non null
    
    Next i
    
    
    'enregistrement du document
     pApplicationWord.ActiveDocument.Save
   
    'fermeture du document
    pApplicationWord.ActiveDocument.Close
    MsgBox "Edition terminée...", vbOKOnly, "Fin de création"
        
    'tout s'est bien passé
    EditerDocumentWord = True
    
    Set pApplicationWord = Nothing
    Set pDocumentWord = Nothing
    Set pFileSystemObject = Nothing
        
    Exit Function
       
Erreur:
    MsgBox "Erreur " & vbCrLf & Err.Number & " : " & Err.Description, vbCritical, "Erreur"
    pApplicationWord.Quit SaveChanges:=wdDoNotSaveChanges
    Set pApplicationWord = Nothing
    Set pDocumentWord = Nothing
    Set pFileSystemObject = Nothing
    EditerDocumentWord = False

End Function


Public Function GetWord() As Object
' Description : retourne une référence sur l'application Word

    On Error Resume Next
    
    Dim pApplicationWord As Object
    
    Set pApplicationWord = GetObject(, "Word.Application")
    ' L'application n'est pas ouverte : ouverture de l'application
    If Err.Number <> 0 Then
        Set pApplicationWord = CreateObject("Word.Application")
        Err.Clear
    End If
    Set GetWord = pApplicationWord
    
    Set pApplicationWord = Nothing

End Function

Public Sub test()
'Voici un extrait de fonction de pilotage de MS Word créée sous ArcMap 8/9. Elle peut donner des pistes...
 
 Dim blnEdition As Boolean
 Dim dicDico As New Dictionary
     
 dicDico.Add "TITRE", "C. Iuli Caesaris Commentariorum de Bello Civili"
 dicDico.Add "AUTEUR", "César"
 dicDico.Add "CITATION", "Litteris C. Caesaris consulibus redditis aegre ab his impetratum est summa tribunorum plebis contentione, ut in senatu recitarentur; ut vero ex litteris ad senatum referretur, impetrari non potuit. Referunt consules de re publica in civitate. . Incitat. L. Lentulus consul senatu rei publicae se non defuturum pollicetur, si audacter ac fortiter sententias dicere velint; sin Caesarem respiciant atque ejus gratiam sequantur, ut superioribus fecerint temporibus, se sibi consilium capturum neque senatus auctoritati obtemperaturum: habere se quoque ad Caesaris gratiam atque amicitiam receptum. In eandem sententiam loquitur Scipio: Pompeio esse in animo rei publicae non deesse, si senatus sequatur; si cunctetur atque agat lenius, nequiquam ejus auxilium, si postea velit, senatum imploraturum."
 dicDico.Add "IMAGE", "chemin absolu d'accès à l'image ex : d:\images\test.jpg"
 
 blnEdition = EditerDocumentWord("le chemin absolu du modèle MS Word ex. d:\modeles\modele.doc", "le chemin de sauvegarde ex : d:\documents\test.doc", dicDico)
 
End Sub