IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
logo
Sommaire > Divers > Automation
        BO - Importer des Données de Business Objects dans des tables Access
        Excel - Mettre en forme un fichier aprés une exportation
        Outlook - Créer des rendez-vous dans un calendrier.
        Outlook - Envoi massif de mails (NewsLetter)
        Outlook - Envoyer une requête dans le corps d'un mail
        Lotus - Envoyer un message d'alerte depuis acces via Lotus
        Lotus - Préparer/Envoyer un message via Lotus Notes avec option de sauvegarde.
        Word - Exporter des données vers un document

rechercher
precedent    sommaire    suivant    telecharger


Auteur : Fabby69
Version : 27/08/2004
BO - Importer des Données de Business Objects dans des tables Access
Versions : 97 et supérieures

Cette fonction permet d'importer des données directement d'un Rapport BO via un fichier texte, c'est très pratique et rapide
Private appBO As busobj.Application
Private docBO As busobj.Document
Private repBO As busobj.Report


Function Fct_ImportBO_Access(ByVal Nom_Table As String, _
            ByVal Chemin_Req_BO As String, ByVal Chemin_Fich_txt As String)


'***************************************************
'************ Ouverture de BO **********************
'***************************************************

'Initialisation de l'application BO
Set appBO = New busobj.Application               

'BO accepte les actions d'un utilisateur distant
appBO.Interactive = True                         

'Connexion à l'application BO avec le login et le mot de passe
appBO.LoginAs "LOGIN", "PASSWORD", False       

'Afficher la fenêtre BO
appBO.Visible = True              
                           
'--------------------  Calcul dates  ------------------------------------------------
'Valeur d'invite BO
Dim datDB       
datDB = Now - 30
 
'Valeur d'invite BO
Dim datFIN       
datFIN = Now - 2


'***************************************************
'************ Lancement d'une requête BO ***********
'***************************************************

'Définition de la requête BO à ouvrir grâce à son emplacement
Set docBO = appBO.Documents.Open(Chemin_Req_BO)   

'renseigne les valeurs de l'invite BO
docBO.Variables.Item("DB").Value = datDB       
docBO.Variables.Item("FIN").Value = datFIN

'L'utilisateur ne peut plus affecter l'application et le report BO ouvert
appBO.Interactive = False                         

'Rafraîchissement des données du Report BO
docBO.Refresh                                     

'Sélection du rapport (onglet)
Set repBO = docBO.Reports.Item(1)                 

'Export au format texte dans le fichier dont le nom est en paramètre
repBO.ExportAsText (Chemin_Fich_txt)              

'***************************************************
'************ Fermeture de BO **********************
'***************************************************

'Fermeture du Report
docBO.Close                                       

'Fermeture de l'application BO
appBO.Quit                                        

'Réinitialisation des données
Set docBO = Nothing                               
Set repBO = Nothing
Set appBO = Nothing

'***************************************************
'************ Import du fichier .txt ***************
'***************************************************

'Import du fichier texte dont le chemin est en paramètre dans la table 
DoCmd.TransferText acImportDelim, "BO_Spécification_importation", _
        Nom_Table, Chemin_Fich_txt  placée en paramètre aussi


End Function

Auteur : Tofalu
Version : 20/05/2005
Page de l'auteur
Téléchargez le zip
Excel - Mettre en forme un fichier aprés une exportation
Version : Access 97 et supérieures

Important : Pour que ce code fonctionne, vous devez ajouter la référence Microsoft Excel X.0 à votre projet.

Lorsque vous transférez les données d'une table ou d'une requête vers un fichier Excel, aucune mise en forme n'est appliquée au fichier xls. Les colonnes ont ainsi toutes la même taille, les titres ne se distinguent pas, etc ...

Pour pouvoir modifier l'aspect du fichier, il faut utiliser le processus Automation à travers un objet Excel.Application.

L'exemple suivant permet de changer l'apparence de l'entête et de redimensionner les colonnes afin de les ajuster à leur contenu.

L'interface se présente ainsi :

Le code du bouton Exécuter est le suivant :
Private Enum CouleurFond
  cfBleu = 16764057
  cfrouge = 10079487
  cfvert = 13434828
  cfjaune = 10092543
End Enum

Private Sub Commande5_Click()
Dim oAppExcel As Excel.Application
Dim oClasseur As Excel.Workbook
Dim oFeuille As Excel.Worksheet
Dim oCell As Excel.Range
Dim i As Integer
If Nz(txtChemin, "") = "" Then
  MsgBox "Sélectionner une destinations"
Else
  'Exporter
  DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Clients", txtChemin, True
  'Ouvre le fichier excel
  Set oAppExcel = CreateObject("Excel.Application")
  Set oClasseur = oAppExcel.Workbooks.Open(txtChemin)
  'Sélectionne la première feuille
  Set oFeuille = oClasseur.Worksheets(1)
  'Parcours les cellules de la première ligne
  i = 1
  While oFeuille.Cells(1, i).Value <> ""
    Set oCell = oFeuille.Cells(1, i)
    'définit le gras
    oCell.Font.Bold = chkGras
    'définit l'italic
    oCell.Font.Italic = ChkItalic
    'Définit la couleur du texte
    Select Case Nz(TxtCouleurtexte, "")
      Case "Bleu": oCell.Font.Color = vbBlue
      Case "Rouge": oCell.Font.Color = vbRed
      Case "Vert": oCell.Font.Color = vbGreen
      Case Else: oCell.Font.Color = vbYellow
    End Select
    'Définit la couleur de fond
    Select Case Nz(txtCouleurFond, "")
      Case "Bleu": oCell.Interior.Color = cfBleu
      Case "Rouge": oCell.Interior.Color = cfrouge
      Case "Vert": oCell.Interior.Color = cfvert
      Case Else: oCell.Interior.Color = cfjaune
    End Select
    'Ajuste la taille des colonnes au texte
    oCell.EntireColumn.AutoFit
    i = i + 1
  Wend
  'Ferme Excel
  oClasseur.Save
  oClasseur.Close
  oAppExcel.Quit
  Set oAppExcel = Nothing
  Set oClasseur = Nothing
  MsgBox "fini"
End If
 
End Sub
N'hésitez pas à télecharger le fichier Zip afin de visualiser le résultat obtenu.


Auteur : Macno
Version : 05/03/2005
Outlook - Créer des rendez-vous dans un calendrier.
Versions : 2000 et supérieures

Cette fonction crée un rendez vous dans un calendrier Outlook. Elle nécessite la référence Microsoft Outlook Object Library.
Public Function CreerRendezVous(PCalendrier As String, _
 PDate As String, _
 PHeure As String, _
 PDuree As Integer, _
 PSubject As String, _
 PNotes As String, _
 PLieu As String, _
 Optional PMinutesRappel As Integer = 0)

On Error GoTo Add_Err

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim olns As Outlook.NameSpace
Dim MycalendarFolder As Outlook.MAPIFolder
Dim MyFolder As Outlook.Items

Set objOutlook = CreateObject("Outlook.Application")
Set olns = objOutlook.GetNamespace("MAPI")
Set MycalendarFolder = olns.GetDefaultFolder(olFolderCalendar)
'Selectionne le calendrier
'Selectionne le calendrier
If PCalendrier = "" Then
Set MyFolder = MycalendarFolder.Items
Else
Set MyFolder = MycalendarFolder.Folders(PCalendrier).Items
End If
Set objAppt = MyFolder.Add
'Cree le rendez vous
With objAppt

  If PDuree > 0 Then
  .Start = PDate & " " & PHeure
  .Duration = PDuree
  Else
  .Start = PDate
  .AllDayEvent = True
  End If
  .Subject = PSubject
  .Body = PNotes
  .Location = PLieu
  'Ajoute le rappel
  If PMinutesRappel > 0 Then
    .ReminderMinutesBeforeStart = PMinutesRappel
    .ReminderSet = True
  End If
  'Sauvegarde et ferme
  .SAVE
  .Close (olSave)
End With
'Libération des variables.
Set objAppt = Nothing
Set objOutlook = Nothing
MsgBox "Rdv ajouté!"
Exit Function
'Gere les erreurs
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End Function
Informations sur les paramètres :

  • PCalendrier : Le nom du calendrier concerné. Passez une chaîne vide pour utiliser le calendrier par défaut
  • PDate : La date du rendez vous.
  • PHeure : L'heure du rendez vous.
  • PDuree : La durée du rendez vous en minutes. Utilisez 0 pour que le rendez vous dure toute la journée.
  • PSubject : L'objet du rendez vous.
  • PNotes : Un court résumé du rendez vous.
  • PLieu : Le lieu du rendez vous.
  • PMinutesRappel : Le nombre de minutes avant un rappel. Ne pas renseigner ce paramètre si vous ne souhaitez pas utiliser le rappel Outlook.

Exemple d'insertion d'un rendez vous :
CreerRendezVous "Cal2", "25/02/2005", _
"14:00", 53, "Test", "Ceci est un test", _
"Gare de l'Est", 5
Ceci crée un rendez vous dans le calendrier nommé Cal2. Le rendez vous a lieu le 25 février 2005 à 14h00 à la Gare de l'Est et dure 53 minutes. Outlook me préviendra 5 minutes avant le rendez vous.


Auteur : Tofalu
Version : 12/11/2005
Page de l'auteur
Outlook - Envoi massif de mails (NewsLetter)
Versions : Access 2000 et supérieures

Pour que cet exemple fonctionne vous devez activer les références Microsoft DAO et Microsoft Outlook

Ce module reprend le principe d'envoie de NewsLetter aux clients d'une société. La base de données se compose notamment d'une table nommée clients où figure un champ (ChampEmailClient) où est stockée l'adresse mail de chaque client.

Le principe est trés simple il suffit d'enrichir la propriété BCC (copie carbone cachée) de l'objet oMail à partir de la liste des clients.

On aura ainsi :
oMail.BCC="toto@domaine.fr; titi@domaine.fr; tata@domaine.com"
Public Sub EnvoiMassif()
'Ajouter les références suivantes :
'Microsoft Outlook
'Microsoft DAO
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim strContenu As String
Dim oRst As DAO.Recordset
Dim oFld As DAO.Field
Dim strTo As String
'Instancie Outlook
Set oApp = CreateObject("Outlook.Application")
'Crée un nouveau message
Set oMail = oApp.CreateItem(olMailItem)
oMail.Body = "Bonjour," & vbCrLf & _
             "Venez retrouver l'ensemble de nos produits sur notre site Web" & _
             vbCrLf & "http://www.notresite.fr"

'Ouvre un recordset sur les clients
Set oRst = CurrentDb.OpenRecordset("SELECT * FROM Clients")
'Boucle sur chaque client et les ajoute au champ BCC du mail
While Not oRst.EOF
  strTo = strTo & oRst.Fields("ChampEmailClient") & "; "
  oRst.MoveNext
Wend
'Supprime la dernière virgule
oMail.BCC = Left(strTo, Len(strTo) - 2)
oMail.Subject = "NewsLetter " & Date
'Envoi le mail
oMail.Send
'ferme le curseur
oRst.Close
Set oRst = Nothing
'Ferme Outlook
oApp.Quit
Set oApp = Nothing
End Sub

Auteur : Tofalu
Version : 20/05/2005
Page de l'auteur
Outlook - Envoyer une requête dans le corps d'un mail
Version : 2000 et supérieures

Cet exemple permet d'envoyer le résultat d'une requête dans le corps d'un message et non en pièce jointe. Pour que cela, il est nécessaire de créer le corps du message en HTML. Le but est donc de générer un code HTML en VBA qui sera passé à la propriété HTMLbody du message.

Pour que ce code fonctionne, vous devez ajouter deux références à votre projet :

  • Microsoft Outlook Object Library
  • Microsoft DAO Object Library
'Ajouter les références suivantes :
'Microsoft Outlook
'Microsoft DAO
Const SAUTLIGNE = "<br/>"
Private Sub Commande7_Click()
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
Dim strContenu As String
Dim oRst As DAO.Recordset
Dim oFld As DAO.Field
'Instancie Outlook
Set oApp = CreateObject("Outlook.Application")
'Ouvre un curseur sur la table produits
Set oRst = CurrentDb.OpenRecordset("Produits")
'Crée un nouveau message
Set oMail = oApp.CreateItem(olMailItem)
'Définit un message HTML
oMail.BodyFormat = olFormatHTML
'Ecrit bonjour en gras
strContenu = "<b>Bonjour !</b>"
'Saute deux lignes
strContenu = strContenu & SAUTLIGNE & SAUTLIGNE
'Ecrit le reste de l'entete
strContenu = strContenu & "<div>Comme convenu, je vous envoie l'ensemble " & _
                        "de la liste des produits que nous " & _
                        "proposons et qui correspondent à l'activité " & _
                        "de votre entreprise.</p>"
                        
'Saute deux lignes
strContenu = strContenu & SAUTLIGNE & SAUTLIGNE
'Crée le table
strContenu = strContenu & "<div align=""center""><table>"
'Crée la ligne d'entête
strContenu = strContenu & "<tr>"
'Pour chaque champ, crée une colonne avec le nom du champ
For Each oFld In oRst.Fields
  strContenu = strContenu & "<td><b>" & oFld.Name & "</b></td>"
Next oFld
'Termine la ligne
strContenu = strContenu & "</tr>"
'Pour chaque enregistrement, crée une nouvelle ligne
While Not oRst.EOF
  strContenu = strContenu & "<tr>"
  'Pour chaque champ, crée une colonne avec la valeur du champ
  For Each oFld In oRst.Fields
    strContenu = strContenu & "<td>" & oFld.Value & "</td>"
  Next oFld
  'Termine la ligne
  strContenu = strContenu & "</tr>"
  'Passe à l'enregistrement suivant
  oRst.MoveNext
Wend
'Ferme le tableau
strContenu = strContenu & "</table></div>"
'Affecte le code HTML au mail
oMail.HTMLBody = strContenu
oMail.To = "MMMMMMMMMMMMMMMM@FD.fr"
oMail.Subject = "Envoi catalogue"
'Envoi le mail
oMail.Send
'ferme le curseur
oRst.Close
Set oRst = Nothing
'Ferme Outlook
oApp.Quit
Set oApp = Nothing
End Sub
Ici, il s'agit d'envoyer l'ensemble de la table produits de l'application Comptoir.mdb

Le mail généré est le suivant :

HTML permettant tellement de combinaisons, les seules limites sont celles de vos connaissances et pour peu que vous connaissiez les possibiltés de ce langage, vous pourrez produire des mails d'une trés grande qualité.


Auteur : HervéGermain
Version : 28/01/2005
Lotus - Envoyer un message d'alerte depuis acces via Lotus
Versions : 97 et supérieures
Function SendNotesMsg(ByVal sSendTo As Variant, Optional ByVal sSubject As String, _ 
                       Optional ByVal sBodyText As String, _
                      Optional ByVal sAttachment) As Long 
   '********************************************************************************
   '********************************************************************************
   'Objet :   Envoie un message par Notes mail 
   'Arguments: 
   ' sSendTo (Recquis)- un mot représentant le nom du destinataire 
   '                   ou un tableau de noms de destinataires 
   '                   Si on doit utiliser de multiples destinataires, alors 
   '                   sSendTo to doit être passé comme un tableau 
   ' sSubject (Optionel)-la variable littérale à utiliser comme sujet du mail 
   'sBodyText (Optionel)-la variable littérale à utiliser comme corps du message 
   'sAttachment (Optionel)-la variable contenant le chemin et le nom du fichier 
   '                   attaché s'il existe 
   ' Syntaxe SendNotesMsg "MonNom", "C'est le sujet", "Le texte","C:\data\mondoc.doc" 
   '*******************************************************************************
   '*******************************************************************************
   Dim oSess As Object 
   Dim oDB As Object 
   Dim oDoc As Object 
   Dim oItem As Object 
   Dim ntsServer As String 
   Dim ntsMailFile As String 
   'Utiliser les constantes des lignes suivantes au lieu des 2 lignes précédentes 
   'seulement si le codage du serveur et le nom du fichier de mailing 
   'utilisent des variables vides pour ntsServer et s'il s'agit d'une base locale 
   '***************************************************************************** 
   '                 Const ntsserver = "notes46/pchelps46" 
   '                 Const ntsmailFile = "mail\bhartman.nsf" 
   '***************************************************************************** 
On Error GoTo err_SendNotesMsg 
   Set oSess = CreateObject("Notes.NotesSession") 
   'Ne pas utiliser les 2 suivantes en cas d'utilisation des constantes 
   'gets server name 
    
   ntsServer = oSess.GetEnvironmentString("MailServer", True) 
   'Acquière le nom du fichier mailfile de l'utilisateur courant dans Notes.ini 
   ntsMailFile = oSess.GetEnvironmentString("MailFile", True) 
   Set oDB = oSess.GetDatabase(ntsServer, ntsMailFile) 
   Set oDoc = oDB.CreateDocument 
   Set oItem = oDoc.CreateRichTextItem("BODY") 

   oDoc.Form = "Memo" 
   If Not IsMissing(sSubject) Then 
       If sSubject <> "" Then oDoc.Subject = sSubject 
   End If 
   If Not IsMissing(sSubject) Then 
       If sBodyText <> "" Then oDoc.body = sBodyText 
   End If 
   oDoc.FROM = oSess.CommonUserName 
   oDoc.PostedDate = Date 
   If Not IsMissing(sAttachment) Then 
       If sAttachment <> "" Then Call oItem.EmbedObject(1454, "", sAttachment) 
   End If 
   'Envoie le message 
   Call oDoc.Send(False, sSendTo) 
   SendNotesMsg = 0 
   MsgBox "Le message a été envoyé", vbInformation 
exit_SendNotesMsg: 
   On Error Resume Next 
   Set oSess = Nothing 
   Set oDB = Nothing 
   Set oDoc = Nothing 
   Set oItem = Nothing 
   Exit Function 
err_SendNotesMsg: 
   SendNotesMsg = err.Number 
   If err.Number = 7225 Then 
       MsgBox "Impossible d'attacher le fichier, vérifier le chemin!", vbCritical 
   Else 
       MsgBox "[" & err.Number & "]: " & err.Description 
   End If 
   MsgBox "Message non envoyé suite erreur!", vbCritical 
   Resume exit_SendNotesMsg 
End Function
On appelle la fonction par une Sub
Private Sub Commande237_Click() 
    
    Dim strBody As String 
    strBody = "Vous avez la FI N° " & Me.NNO & " à signer " 
    If Me.NNO <> "" Then 
        SendNotesMsg "Destinataire/chemin", "Fiches d'intervention", strBod 
End If 

End Sub

Auteur : Argyronet
Version : 05/03/2005
Page de l'auteur
Lotus - Préparer/Envoyer un message via Lotus Notes avec option de sauvegarde.
Versions : 97 et supérieures

Lorsque le client de messagerie est Lotus Notes, vous pouvez créer un formulaire personnalisé avec un look "Outlookien", à savoir zones de destinataires, pièces jointes, zone de message... Un petit bouton pour envoyer et c'est tout.

Procédure globale:
Public Sub SendNotesMail(ByVal Subject As String, _
ByVal Attachment As String, ByVal RECIPIENT As String, _
ByVal CC As String, ByVal BCC As String, _
ByVal BodyText As String, ByVal SaveIt As Boolean) 

Dim oMaildb As Object 
Dim oMailDoc As Object 
Dim oAttachME As Object 
Dim oSession As Object 
Dim oEmbedObj As Object 
    
Dim sUserName As String 
Dim sMailDbName As String 

Const STR_ATTACHMENT As String = "Attachment" 
    
On Error GoTo L_ErrCannotCreateNotesSession 
    Set oSession = CreateObject("Notes.NotesSession") 
    sUserName = oSession.sUserName 
    sMailDbName = Left$(sUserName, 1) & Right$(sUserName, _
         (Len(sUserName) - InStr(1, sUserName, " "))) & ".nsf" 
    DoEvents 
    lblStatus.Caption = "Information about sender..." 
    Call Sleep(1000) 
    Set oMaildb = oSession.GETDATABASE(vbNullString, _
             sMailDbName) 
     If oMaildb.IsOpen = True Then 
     Else 
         oMaildb.OPENMAIL 
     End If 
    Set oMailDoc = oMaildb.CREATEDOCUMENT 
    oMailDoc.Form = "Memo" 
    oMailDoc.SENDTO = RECIPIENT 
    If Len(CC) = 0 Then 
    Else 
        oMailDoc.CopyTo = BC 
    End If 
    If Len(BCC) = 0 Then 
    Else 
        oMailDoc.blindCopyTo = BCC 
    End If 
    oMailDoc.Subject = Subject 
    oMailDoc.Body = BodyText 
    oMailDoc.SAVEMESSAGEONSEND = SaveIt 
    DoEvents 
    lblStatus.Caption = "Looking for attached files..." 
    Call Sleep(1000) 

    If Attachment <> vbNullString Then 
        Set oAttachME = oMailDoc.CREATERICHTEXTITEM_
           (STR_ATTACHMENT) 
        Set oEmbedObj = oAttachME.EMBEDOBJECT(1454, _
                vbNullString, Attachment, STR_ATTACHMENT) 
        oMailDoc.CREATERICHTEXTITEM _
                (STR_ATTACHMENT) 
    End If 
    DoEvents 
    oMailDoc.PostedDate = Now() 
    

 'To send the message, remove the quotes characters (') near each line 
  ' lblStatus.Caption = "Sending message..." 
  ' Call Sleep(1000) 
  '
  ' oMailDoc.SEND 0, RECIPIENT 
  ' lblStatus.Caption = "Message sent" 

  ' MsgBox "Your message has been sent successfully...", 64, "End" 


L_ExCannotCreateNotesSession: 
    Set oMaildb = Nothing 
    Set oMailDoc = Nothing 
    Set oAttachME = Nothing 
    Set oSession = Nothing 
    Set oEmbedObj = Nothing 
    Exit Sub 
L_ErrCannotCreateNotesSession: 
  Select Case Err 
      Case 429 
          MsgBox "Impossible de localiser un Client Notes; " & _
                     "Votre message n'a pas été envoyé !", 16, _
                          "Lotus Notes requis" 
      Case Else 
          MsgBox "Un erreur a empêché l'envoi du message." & _
                  vbCrlf & "Veuillez en référer à votre administrateur " & _
                      "pour lui soumettre cette erreur..." & vbCrlf & Error ,_
                             16, "Error #" & Str(Err) 
  End Select 
  Resume L_ExCannotCreateNotesSession 
End Sub
Mode d'utilisation:
Sub CreateMemoNotes() 
  SendNotesMail Me!txtSubject, Me!txtAttachment, Me!txtTo, _
                Me!txtCC, Me!txtCCC, Me!txtMessage, False 
End Sub
Petit plus: Me!txtAttachment représente une ligne de chemin complet avec un nom de fichier valide séparé par le séparateur de CommonDialog Control. (La virgule en théorie). Dans le Formulaire où j'avais exploité ce code, j'avais utilisé un GetOpenFileName() commandé par petit bouton à 3 points (Parcourir...) et qui autorisait une sélection multiple de fichiers.

Déclaration de l'API (A placer en haut de module) :
Private Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long 

Private Type OPENFILENAME 
  lStructSize As Long 
  hwndOwner As Long 
  hInstance As Long 
  lpstrFilter As String 
  lpstrCustomFilter As String 
  nMaxCustFilter As Long 
  nFilterIndex As Long 
  lpstrFile As String 
  nMaxFile As Long 
  lpstrFileTitle As String 
  nMaxFileTitle As Long 
  lpstrInitialDir As String 
  lpstrTitle As String 
  flags As Long 
  nFileOffset As Integer 
  nFileExtension As Integer 
  lpstrDefExt As String 
  lCustData As Long 
  lpfnHook As Long 
  lpTemplateName As String 
End Type 

Private Const OFN_READONLY = &H1 
Private Const OFN_OVERWRITEPROMPT = &H2 
Private Const OFN_HIDEREADONLY = &H4 
Private Const OFN_NOCHANGEDIR = &H8 
Private Const OFN_SHOWHELP = &H10 
Private Const OFN_ENABLEHOOK = &H20 
Private Const OFN_ENABLETEMPLATE = &H40 
Private Const OFN_ENABLETEMPLATEHANDLE = &H80 
Private Const OFN_NOVALIDATE = &H100 
Private Const OFN_ALLOWMULTISELECT = &H200 
Private Const OFN_EXTENSIONDIFFERENT = &H400 
Private Const OFN_PATHMUSTEXIST = &H800 
Private Const OFN_FILEMUSTEXIST = &H1000 
Private Const OFN_CREATEPROMPT = &H2000 
Private Const OFN_SHAREAWARE = &H4000 
Private Const OFN_NOREADONLYRETURN = &H8000 
Private Const OFN_NOTESTFILECREATE = &H10000 
Private Const OFN_NONETWORKBUTTON = &H20000 
Private Const OFN_NOLONGNAMES = &H40000 
Private Const OFN_EXPLORER = &H80000 
Private Const OFN_NODEREFERENCELINKS = &H100000 
Private Const OFN_LONGNAMES = &H200000
Fonction d'affichage de la boîte de dialogue des fichiers à joindre
Public Function fnctGetAttachedFiles(ByVal InitialDir _
 As String, ByVal Extensions As String, _
        ByVal ApplicationName As String) As String 

Const MIN_PATH As Integer = 260 
Const MAX_PATH As Integer = 8192 
Dim oOFN As OPENFILENAME 
Dim lReturn As Long 
Dim sFilter As String 
Dim sAttachmentString As String 
Dim aApplications() As String 
Dim aExtensions() As String 
Dim I As Integer 

    aApplications = Split(ApplicationName, ";") 
    aExtensions = Split(Extensions, ";") 
    
    For I = LBound(aApplications) To UBound(aApplications) 
        sFilter = sFilter & "Fichiers " & aApplications(I) & _
          vbNullChar & aExtensions(I) & vbNullChar 
    Next 
    
    With oOFN 
    .lStructSize = Len(oOFN) 
    .hwndOwner = Application.hWndAccessApp 
    .lpstrFile = Extensions 
    .lpstrFilter = sFilter 
    .nFilterIndex = 1 
    .lpstrFile = String(MIN_PATH, 0) 
    .flags = OFN_LONGNAMES Or OFN_HIDEREADONLY _
          Or OFN_ALLOWMULTISELECT 
    .nMaxFile = IIf((.flags And OFN_ALLOWMULTISELECT) = _
         OFN_ALLOWMULTISELECT, MAX_PATH, MIN_PATH - 1) 
    .lpstrFileTitle = .lpstrFile 
    .nMaxFileTitle = .nMaxFile 
    .lpstrInitialDir = IIf(Len(InitialDir) = 0, _
          Left(Application.CurrentProject.Path, 3), InitialDir) 
    .lpstrTitle = "Sélection de fichiers en pièces jointes" 
    End With 
    lReturn = GetOpenFileName(oOFN) 
    
    sAttachmentString = oOFN.lpstrFile 
    If InStr(1, sAttachmentString, vbNullChar) Then 
      sAttachmentString = Trim(Left(sAttachmentString, _
       InStr(1, sAttachmentString, vbNullChar) - 1)) 
    End If 
    
    fnctGetAttachedFiles = sAttachmentString 

End Function
Code à affecter au bouton Parcourir...
Sub ShowFileDialog() 
Dim sAttachmentString As String 

  sAttachmentString = fnctGetAttachedFiles("D:\Data", _
       "*.doc;*.xls;*.mdb;*.txt", "Word;Excel;Access;Notepad") 
  If Len(sAttachmentString) > 0 Then 
    Me!txtAttachment = sAttachmentString 
  Else 
    Me!txtAttachment = vbnulstring 
  End If 
End Sub

Auteur : Obipadawan
Version : 27/08/2004
Word - Exporter des données vers un document
Versions : 97 et supérieures

Grâce au forum j'ai pu résoudre mon problème d'exportation vers Word. Je trouve cette solution, peut être plus longue que le publipostage, mais moins lourde pour les fichiers Word générés. pour le titre et l'auteur désolé, je ne me souviens plus, je vous donne ici le code modifié pour mes besoins, mais applicable facilement. il s'agit d'un code pour piloter Word depuis Access en ouvrant un document et en y "collant" les données du formulaire. A noter que dans le document Word il faut insérer des bookmarks en leur donnant le même nom que le champ que l'on veut exporter. Pour simplifier : le bookmark "données" = données.value !
Private Sub CmdWORD_Click()
'Voici pour la déclaration du code:
Dim wdapp As Word.Application
Dim moncode

moncode = code.Value

'Démarrer Word
Set wdapp = CreateObject("Word.application")
' le code ci-dessous permet de faire apparaitre word 
' en premier plan ou pas, false -> non et true -> oui
wdapp.Visible = False
'on ouvre le document
wdapp.Documents.Open "j:\Doc_Atelier\td138\td138_gdt.doc"
' avant d'affecter la valeur du champ code au signet code,
' je teste si le champ code est vide, 
'car si oui cela posera probleme et dans ce cas j'affecte la valeur "."
If code.Value <> "" Then
wdapp.ActiveDocument.Bookmarks("code").Range.Text = code.Value
Else
wdapp.ActiveDocument.Bookmarks("code").Range.Text = "."
End If
' je sauvegarde le fichier sous un autre nom     
wdapp.ActiveDocument.SaveAs "j:\Doc_Atelier\td138\" & moncode & ".doc"
' je ferme le fichier
wdapp.ActiveDocument.Close
' je ferme l'application
wdapp.Application.Quit SaveChanges:=wdDoNotSaveChanges
' et j'avertis l'utilisateur que le fichier word est crée
MsgBox "Le fichier WORD est crée !"
set wdapp=nothing
End Sub
Quelques explications :
wdapp.ActiveDocument.Bookmarks("code").Range.Text = code.Value
Dans cet exemple, nous avons utilisé la propriété Text de l'objet Range pour mettre à jour les données voulues dans le signet. Si vous souhaitez ajouter ces données à des données déjà existantes dans le signet, vous pouvez vous intéresser aux méthodes InsertBefore et InsertAfter.


rechercher
precedent    sommaire    suivant    telecharger

Valid XHTML 1.1!Valid CSS!

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2005 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.