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

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

Global Const xlDownThenOver = 1
Global Const xlLandscape = 2
Global Const xlPaperA4 = 9
Global Const xlPrintNoComments = -4142
Global Const xlDiagonalUp = 6
Global Const xlDiagonalDown = 5
Global Const xlEdgeLeft = 7
Global Const xlContinuous = 1
Global Const xlMedium = -4138
Global Const xlAutomatic = -4105
Global Const xlEdgeTop = 8
Global Const xlEdgeBottom = 9
Global Const xlEdgeRight = 10
Global Const xlHairline = 1
Global Const xlInsideVertical = 11
Global Const xlInsideHorizontal = 12
Global Const xlNone = -4142
Global Const xlThin = 2
Global Const xlWorksheet = -4167
Global Const xlRight = -4152

Public Function fExportExcel(ByVal Arg_Path As String, ByVal Arg_Rs As DAO.Recordset, _
					Optional ByVal Arg_MEF As Boolean = False, _
					Optional ByVal Arg_Ligne As Integer = 1, _
					Optional ByVal Arg_Colonne As Integer = 1) As Object
    'Déclarations
    Dim I As Integer
    Dim J As Integer
    Dim NbrChamps As Integer
 
    Dim ExcelApp As Object
    Dim ExcelSheet As Object
    On Error GoTo fExportExcel_Err
 
    'existance d'un fichier modèle
    If Arg_Path & "" = "" Then
        'pas de fichier model
        Set ExcelApp = CreateObject("Excel.application").Workbooks.Add
        Set ExcelSheet = ExcelApp.worksheets(1)
        Else
        	'fichier modèle
            Set ExcelApp = GetObject(Arg_Path)
            Set ExcelSheet = ExcelApp.worksheets(1)
    End If
    ExcelApp.windows(1).Visible = True
 
    'ExcelApp.Application.Visible = True
 
    'existance des données
    If Not (Arg_Rs.BOF = True And Arg_Rs.EOF = True) Then
        'il y a des données à exporter
        Arg_Rs.MoveLast
        Arg_Rs.MoveFirst
        NbrChamps = Arg_Rs.Fields.Count
 
        'Titre de colonne
        For I = 0 To NbrChamps - 1
            ExcelSheet.cells(Arg_Ligne, I + Arg_Colonne) = Arg_Rs(I).name
        Next
 
        'copie des infos
        ExcelSheet.cells(Arg_Ligne + 1, Arg_Colonne).CopyFromRecordset Arg_Rs
        'mise en forme si arg_cadre = true
        If Arg_MEF = True Then
            'datage
            With ExcelSheet.cells(Arg_Rs.RecordCount + Arg_Ligne + 1, NbrChamps - 1 + Arg_Colonne)
                .Value = "'" & Format(Now, "dd/mm/yyyy")
                .Font.Size = 6
                .HorizontalAlignment = xlRight
            End With
 
            'cadre + couleur des titres
 
            'with = la zone tableau
            With ExcelSheet.Range(ExcelSheet.cells(Arg_Ligne, Arg_Colonne), _
					ExcelSheet.cells(Arg_Ligne + Arg_Rs.RecordCount, _
					Arg_Colonne + NbrChamps - 1))
                .Borders(xlInsideVertical).Weight = xlThin
                .Borders(xlInsideHorizontal).Weight = xlThin
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeTop).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
            End With
 
            With ExcelSheet.Range(ExcelSheet.cells(Arg_Ligne, Arg_Colonne), _
				ExcelSheet.cells(Arg_Ligne, Arg_Colonne + NbrChamps - 1))
                .Interior.ColorIndex = 37
                .Borders(xlEdgeBottom).Weight = xlMedium
            End With
        End If
    End If
 
GoTo fExportExcel_Exit
 
'gestion des erreurs
fExportExcel_Err:
    MsgBox "Une erreur inattendue est apparue dans la fonction fExportExcel. L'erreur N° " & _
		Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", _
		vbOKOnly + vbCritical, "Erreur inattendue !"
    Set fExportExcel = Nothing
    Exit Function
 
'Sortie
fExportExcel_Exit:
 
    Set fExportExcel = ExcelApp
    Set ExcelApp = Nothing
 
End Function

Sub Test()
Dim Chemin  As String
Dim Rs As DAO.Recordset
Dim Excl As Object
On Error GoTo Test_Err
Set Rs = CurrentDb.OpenRecordset("T_Test", dbOpenDynaset)
'Debug.Print fNbrField(Rs)
'Chemin = "c:\test.xls"
Chemin = ""
Set Excl = fExportExcel(Chemin, Rs, True, 11, 2)
 
If Excl.Name <> "" Then
    'Autres manipulations du classeur (titre, mise en forme, auteur, ..)
    'par exemple  rendre le doc visible :
    Excl.Application.Visible = True
    Excl.saveas "c:\test_bis.xls"
    Excl.Application.Quit
    Set Excl = Nothing
End If
Exit Sub
 
Test_Err:
 
If Err.Number <> 91 Then
	MsgBox "Une erreur inattendue est apparue dans la fonction Test. L'erreur N° " & _
		Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", _
		vbOKOnly + vbCritical, "Erreur inattendue !"
End If
Set Excl = Nothing
 
End Sub

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

CreerRendezVous "Cal2", "25/02/2005", _
"14:00", 53, "Test", "Ceci est un test", _
"Gare de l'Est", 5

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

'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

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

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

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

Sub CreateMemoNotes() 
  SendNotesMail Me!txtSubject, Me!txtAttachment, Me!txtTo, _
                Me!txtCC, Me!txtCCC, Me!txtMessage, False 
End Sub

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

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

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

'---------- API -----------
'pour faire passer au premier plan
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
'pour ouvrir la fenêtre
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, _
					ByVal nCmdShow As Long) As Long
'pour vérifier si Lotus est ouvert
Private Declare Function FindWindow Lib "user32" Alias _
	"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Dim sSrvr As String 'Le serveur de mail de l'utilisateur courant
Dim MailDbName As String 'Le nom de la base mail de l'utilisateur courant
Dim UserName As String 'Le nom de l'utilisateur courant
 
Dim retVal As Variant 'La valeur de retour de la fonction
 
'---------------- fonction ouverture de session Notes -----------
Function CreateNotesSession() As Boolean
    Const notesclass$ = "NOTES"
    Const SW_SHOWMAXIMIZED = 3 'plein ecran
    Const SW_SHOWMMINIZED = 2 'reduire
    Const SW_SHOWWINDOW = 1 'fenetre
    Const SW_SHOW = 5
 
    Dim Lotus_Session As Object
    Dim rc&
    Dim lotusWindow&
 
    lotusWindow = FindWindow(notesclass, vbNullString)
 
    Set Lotus_Session = CreateObject("Notes.NotesSession")
    sSrvr = Lotus_Session.GETENVIRONMENTSTRING("MailServer", True)
    MailDbName = Lotus_Session.GETENVIRONMENTSTRING("MailFile", True)
    UserName = Lotus_Session.UserName
 
    DoEvents
    'Ouverture de Lotus Notes
    'Mettre votre chemin d'accès pour notes.exe et notes.ini'
    retVal = Shell("C:\notes\notes.exe =C:\notes\notes.ini", vbMaximizedFocus)
 
    'verifier que Lotus est bien ouvert (recupere le handle)
    lotusWindow = FindWindow(notesclass, vbNullString)
    If lotusWindow <> 0 Then
        rc = ShowWindow(lotusWindow, SW_SHOW)
        rc = SetForegroundWindow(lotusWindow)
        CreateNotesSession = True
    Else
         CreateNotesSession = False
    End If
End Function
 
Sub CreateMailandAttachFileAdr(ByVal IsSubject As String, _
		ByVal body As String, ByVal SendToAdr As String, _
		Optional ByVal CCToAdr As String, Optional ByVal BCCToAdr As String, _
		Optional ByVal Attach1 As String, Optional ByVal Attach2 As String)
 
    Const EMBED_ATTACHMENT As Integer = 1454
    Const EMBED_OBJECT As Integer = 1453
    Const EMBED_OBJECTLINK As Integer = 1452
 
    Dim s As Object ' use back end classes to obtain mail database name
    Dim db As Object '
    Dim doc As Object ' front end document
    Dim beDoc As Object ' back end document
    Dim workspace As Object ' use front end classes to display to user
    Dim bodypart As Object '
    Dim bodyAtt As Object '
    Dim lbsession As Boolean
 
    lbsession = CreateNotesSession
 
    If lbsession Then
        'cree la session Lotus Notes
        Set s = CreateObject("Notes.Notessession")
        'se connecte a sa database
        Set db = s.getDatabase(sSrvr, MailDbName)
        If db.ISOPEN = True Then
            'database deja ouvert
        Else
            Call db.Openmail
        End If
        'cree un document memo
        Set beDoc = db.CreateDocument
        beDoc.Form = "Memo"
 
        'construction du mail
        Set bodypart = beDoc.CREATERICHTEXTITEM("Body")
        'beDoc.From = "Moi" 'inutile
        beDoc.SendTo = SendToAdr
        beDoc.CopyTo = CCToAdr
        beDoc.BlindCopyTo = BCCToAdr
        beDoc.Subject = IsSubject
        '-----------------------------------------
        'Remarque s'il y a des destinataires multiples, il suffit de mettre un tableau 
		'd'e-mail dans SendTo (CopyTo,BlindCopyTo)
        'exemple :
        'Dim recip(25) as variant
        'recip(0) = "emailaddress1"
        'recip(1) = "emailaddress2" e.t.c
        'beDoc.sendto = recip
        '----------------------------------------
        ' documents joint 1
        If Len(Attach1) > 0 Then
            If Len(Dir(Attach1)) > 0 Then
               Set bodyAtt = bodypart.EmbedObject(EMBED_ATTACHMENT, "", Attach1, Dir(Attach1))
            End If
        End If
 
        ' documents joint 2
        If Len(Attach2) > 0 Then
            If Len(Dir(Attach2)) > 0 Then
                Call bodyAtt.EmbedObject(EMBED_ATTACHMENT, "", Attach2, Dir(Attach2))
            End If
        End If
 
        'Affichage du mail dans Lotus Notes
        Set workspace = CreateObject("Notes.NotesUIWorkspace")
        Call workspace.EditDocument(True, beDoc).FieldSetText("Body", body)
 
        Set s = Nothing
        Else
            MsgBox "Votre Lotus Notes est fermé !"
    End If
 
End Sub

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

wdapp.ActiveDocument.Bookmarks("code").Range.Text = code.Value