Export de access vers word

Messages postés
5
Date d'inscription
samedi 18 juin 2005
Statut
Membre
Dernière intervention
23 août 2006
-
Messages postés
5
Date d'inscription
samedi 18 juin 2005
Statut
Membre
Dernière intervention
23 août 2006
-
bonjour

je viens de creer une base de donnees sous access 2000  c'est une gestion de contacts

sur mon formulaire j'ai installé un bouton qui normalement devrait exporter certaines données du formulaire sous word ( un normal dot) qui est une lettre avec des champs pre formatées et reperés par des signets

mais.....
le code que j'ai recopié  d'un bouquin acheté ne marche pas

quelqu'un peut il m'aider ??

merci d'avance

rk

2 réponses

Messages postés
15814
Date d'inscription
jeudi 8 août 2002
Statut
Modérateur
Dernière intervention
4 mars 2013
133
Oui, tu n'as qu'à envoyer un email à l'auteur du livre et lui dire ce qui ne marche pas... car sans nous donner plus de détails (surtout le bout de code "recopié d'un bouquin acheté"), comment veux-tu qu'on puisse t'aider ?

A moins que notre champion toute catégorie de boule de cristal passe par là... hein jack ;)
Messages postés
5
Date d'inscription
samedi 18 juin 2005
Statut
Membre
Dernière intervention
23 août 2006

BONJOUR

 désolé tu as complètement raison voici le fameux code

encore merci de te pencher sur mon probleme

amicalement

GK

Private Sub Commande85_Click()
'Fichier WORD d'accusé de réception
    Dim dbBase As Database
    Dim rsEnreg As Recordset
    Dim Critere As String, Zone
    Dim Cible As String, Fin As Boolean, Rc As Integer
    Dim ofn As OPENFILENAME
    Dim a, myRange, Ligne, Msge, NomFic As String, Lg
    Dim appWord As Word.Application
    Dim Localisation As String

    ofn.lStructSize = Len(ofn)
    ofn.lpstrFilter = "Fichiers Word (*.doc)" + Chr$(0) + "*.doc"
    ofn.lpstrFile = Space$(254)
    ofn.nMaxFile = 255
    ofn.lpstrFileTitle = Space$(254)
    ofn.nMaxFileTitle = 255
    ofn.lpstrInitialDir = CurDir
    ofn.lpstrTitle = "Sauvegarde du fichier Word"
    ofn.flags = 0
   
    a = GetSaveFileName(ofn)
       
    If (a) Then
        Cible = Trim$(ofn.lpstrFile)
        Cible = Left$(Cible, Len(Cible) - 1)    'Elimine car. de fin
       
        If InStr(2, Cible, ".", 1) = 0 Then     'Pas d'extension
            Cible = Cible + ".doc"
        End If
    Else
        Cible = ""
        Exit Sub
    End If
   
    'Nom du fichier seulement
    NomFic = Trim$(ofn.lpstrFileTitle)
    NomFic = Left$(NomFic, Len(NomFic) - 1)    'Elimine car. de fin
       
    If InStr(2, NomFic, ".", 1) = 0 Then        'Pas d'extension
        NomFic = NomFic + ".doc"
    End If
   
    'Reprise du chemin d'accès aux données
    Set dbBase = CurrentDb()
    Set rsEnreg = dbBase.OpenRecordset("t_Localisation", DB_OPEN_DYNASET)
   
    rsEnreg.MoveFirst   'Lit 1er enregistrement table "t_Localisation"
    Localisation = rsEnreg![Localisation]      'Mémorise chemin trouvé

    rsEnreg.Close
    Set dbBase = Nothing
   
    'Sauvegarde le document sous le nom donné (par recopie fct API)
    a = CopyFile(Localisation & "\MOD_AR.doc", Cible, False)
   
    If a = 0 Then
        Rc = MsgBox("Fichier Word modèle [MOD_AR.doc] introuvable." _
            & Chr(13) & Chr(10) & "Contacter l'administrateur principal." _
            & Chr(13) & Chr(10) & "Code erreur : " & Err & ".", 0, "Application")
        DoCmd.Quit
    End If

    'Lance Word, nécessaire pour que "Documents" soit actif
    Set appWord = CreateObject("Word.Application")

    'Ouvre le nouveau fichier Word
    Documents.Open FileName:=Cible
   
    'Active le document ouvert + renseignements
    Documents(NomFic).Activate
    MsgBox "Nombre de documents ouverts : " & Documents.Count
    MsgBox "Nombre de champs du formulaire : " & ActiveDocument.FormFields.Count
    MsgBox "Nom du 1er champ de formulaire : " & ActiveDocument.FormFields(1).Name
   
    'Interrogations table ou requête
    On Error GoTo Err_UniteOPEN    'Installe trt d'erreurs

    Set dbBase = CurrentDb
    Set rsEnreg = dbBase.OpenRecordset("t_Direction", DB_OPEN_DYNASET)
  
    Critere = "[No unite]=" & InputBox("Indiquer un numéro d'unité (8 à 10)", "Application", 8)  'Pour exemple
       
    rsEnreg.FindFirst Critere   'Cherche 1er enreg. concordant

    If rsEnreg.NoMatch Then     'Auncun enreg. trouvé
        Rc = MsgBox("Aucun enregistrement trouvé.", 0, "Application")
    Else                        'Cherche tous les enreg. concordant
        ActiveDocument.FormFields("DateJour").Result = Date 'Champ "Date du jour"
        ActiveDocument.FormFields("DateEnvoi").Result = _
            InputBox("Indiquer une date d'envoi (jj/mm/aa)", "Application", Date)  'Pour exemple (défault = date du jour)
       
        Do Until rsEnreg.NoMatch        'Jusqu'à leur fin
            'Remplacement du texte par défaut d'un champ du formulaire
            ActiveDocument.FormFields("Nom").Result = rsEnreg![No UAC]
            ActiveDocument.FormFields("Nombre").Result = rsEnreg![Nombre postes]
           
            'Set Zone = ActiveDocument.Range(Start:=0, End:=0)
            'With Zone
                '.InsertBefore "Rapport, essai d'insertion de texte"
                '.Font.Name = "Arial"
                '.Font.Size = 24
                '.InsertParagrahAfter
            'End With
           
            rsEnreg.FindNext Critere    'Cherche enreg. concordant suivant
        Loop
    End If
       
    'Documents.Save NoPrompt:=True, OriginalFormat:=wdWordDocument
    ActiveDocument.Save
   
    rsEnreg.Close
    Set dbBase = Nothing
   
   
    Rc = MsgBox("Voulez-vous voir le document (==> barre des tâches) ?", vbYesNo, "Application")
   
    If Rc = vbYes Then
        appWord.Application.Visible = True
        MsgBox "Poursuivre (le document va être fermé)", vbOKOnly, "Application"
    End If

    'If MsgBox("Voulez-vous imprimer le document ?", vbYesNo, "Application") = vbYes Then
        'ActiveDocument.PrintOut    'Impression du document Word
    'End If
   
    'Fin propre
    ActiveDocument.Close SaveChanges:=wdSaveChanges, OriginalFormat:=wdWordDocument
    appWord.Application.Quit
    Set appWord = Nothing
      
    Exit Sub