Les meilleures sources AccessConsultez toutes les sources

Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013 

 
OuvrirSommaireDiversAutomation

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

 
Sélectionnez
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
Créé le 27 août 2004  par Fabby69

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 :

Image non disponible

Le code du bouton Exécuter est le suivant :

 
Sélectionnez

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.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

L'utilité de cette fonction (à copier dans un module) est la suivante : générer tous les rapports Excel d'une application avec la même mise en page.
Testé sous Access 97 et 2000.

Les références utilisées sont listées ci-dessous :

  • Visual Basic for Applications
  • Microsoft Access x.0 Object Library
  • OLE Automation
  • Microsoft Activex Data Object Library
  • Microsoft DAO 3.x Object Library

Nous allons tout d'abord définir un ensemble de constantes afin de conserver la syntaxe Excel.

 
Sélectionnez

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

Les arguments attendus par la fonction sont énumérés ci-dessous :

  • Arg_Path : String donnant chemin (path + nom de fichier + extension) du fichier Excel servant éventuellement de "modèle" pour le rapport.
  • Arg_Rs : DAO.Recordset contenant les données à intégrer dans le rapport.
  • Arg_MEF : Boolean indiquant si oui ou non on fait une petite mise en forme des données.
  • Arg_Ligne : Integer indiquant le N° de ligne où coller les données.
  • Arg_Colonne : Integer indiquant le N° de colonne où coller les données
 
Sélectionnez

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  " & _
		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

Voici un exemple d'utilisation de la fonction

 
Sélectionnez

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  " & _
		Err.Number & " ( " & Err.Description & " )! Contactez l'administrateur.", _
		vbOKOnly + vbCritical, "Erreur inattendue !"
End If
Set Excl = Nothing
 
End Sub

Liens utiles :
Communication entre Access et Excel : les différentes méthodes d'export par cafeine
Excel - Mettre en forme un fichier après une exportation

Créé le 15 mai 2007  par Muhad'hib

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.

 
Sélectionnez

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 :

 
Sélectionnez

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.

Créé le 5 mars 2005  par Macno

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 :

 
Sélectionnez

oMail.BCC="toto@domaine.fr; titi@domaine.fr; tata@domaine.com"
 
Sélectionnez

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
Créé le 12 novembre 2005  par Tofalu

Page de l'auteur

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
 
Sélectionnez

'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 :

Image non disponible

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é.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

 
Sélectionnez

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

 
Sélectionnez

Private Sub Commande237_Click() 
 
    Dim strBody As String 
    strBody = "Vous avez la FI  " & Me.NNO & " à signer " 
    If Me.NNO <> "" Then 
        SendNotesMsg "Destinataire/chemin", "Fiches d'intervention", strBod 
End If 
 
End Sub
Créé le 28 janvier 2005  par HervéGermain

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:

 
Sélectionnez

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:

 
Sélectionnez
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) :

 
Sélectionnez

 
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

 
Sélectionnez

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...

 
Sélectionnez
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 
Créé le 5 mars 2005  par Argyronet

Page de l'auteur

Voici un code à placer dans un module qui va vous permettre via une fonction, de préparer un mail et de le visualiser sous Lotus Notes avant de l'envoyer.

 
Sélectionnez

'---------- 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

Lotus - Préparer/Envoyer un message via Lotus Notes avec option de sauvegarde.

Créé le 15 mai 2007  par scorpion1611

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 !

 
Sélectionnez

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 :

 
Sélectionnez
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.

Créé le 27 août 2004  par Obipadawan
  

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 © 2013 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et 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.