Auteur : Fabby69
| | Version : 27/08/2004 | | |
| | 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)
Set appBO = New busobj.Application
appBO.Interactive = True
appBO.LoginAs "LOGIN", "PASSWORD", False
appBO.Visible = True
Dim datDB
datDB = Now - 30
Dim datFIN
datFIN = Now - 2
Set docBO = appBO.Documents.Open(Chemin_Req_BO)
docBO.Variables.Item("DB").Value = datDB
docBO.Variables.Item("FIN").Value = datFIN
appBO.Interactive = False
docBO.Refresh
Set repBO = docBO.Reports.Item(1)
repBO.ExportAsText (Chemin_Fich_txt)
docBO.Close
appBO.Quit
Set docBO = Nothing
Set repBO = Nothing
Set appBO = Nothing
DoCmd.TransferText acImportDelim, "BO_Spécification_importation", _
Nom_Table, Chemin_Fich_txt placée en paramètre aussi
End Function |
|
| |
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
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Clients", txtChemin, True
Set oAppExcel = CreateObject("Excel.Application")
Set oClasseur = oAppExcel.Workbooks.Open(txtChemin)
Set oFeuille = oClasseur.Worksheets(1)
i = 1
While oFeuille.Cells(1, i).Value <> ""
Set oCell = oFeuille.Cells(1, i)
oCell.Font.Bold = chkGras
oCell.Font.Italic = ChkItalic
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
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
oCell.EntireColumn.AutoFit
i = i + 1
Wend
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 | | |
| | 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)
If PCalendrier = "" Then
Set MyFolder = MycalendarFolder.Items
Else
Set MyFolder = MycalendarFolder.Folders(PCalendrier).Items
End If
Set objAppt = MyFolder.Add
With objAppt
If PDuree > 0 Then
.Start = PDate & " " & PHeure
.Duration = PDuree
Else
.Start = PDate
.AllDayEvent = True
End If
.Subject = PSubject
.Body = PNotes
.Location = PLieu
If PMinutesRappel > 0 Then
.ReminderMinutesBeforeStart = PMinutesRappel
.ReminderSet = True
End If
.SAVE
.Close (olSave)
End With
Set objAppt = Nothing
Set objOutlook = Nothing
MsgBox "Rdv ajouté!"
Exit Function
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.
|
| |
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()
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
Set oApp = CreateObject("Outlook.Application")
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"
Set oRst = CurrentDb.OpenRecordset("SELECT * FROM Clients")
While Not oRst.EOF
strTo = strTo & oRst.Fields("ChampEmailClient") & "; "
oRst.MoveNext
Wend
oMail.BCC = Left(strTo, Len(strTo) - 2)
oMail.Subject = "NewsLetter " & Date
oMail.Send
oRst.Close
Set oRst = Nothing
oApp.Quit
Set oApp = Nothing
End Sub |
|
| |
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
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
Set oApp = CreateObject("Outlook.Application")
Set oRst = CurrentDb.OpenRecordset("Produits")
Set oMail = oApp.CreateItem(olMailItem)
oMail.BodyFormat = olFormatHTML
strContenu = "<b>Bonjour !</b>"
strContenu = strContenu & SAUTLIGNE & SAUTLIGNE
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>"
strContenu = strContenu & SAUTLIGNE & SAUTLIGNE
strContenu = strContenu & "<div align=""center""><table>"
strContenu = strContenu & "<tr>"
For Each oFld In oRst.Fields
strContenu = strContenu & "<td><b>" & oFld.Name & "</b></td>"
Next oFld
strContenu = strContenu & "</tr>"
While Not oRst.EOF
strContenu = strContenu & "<tr>"
For Each oFld In oRst.Fields
strContenu = strContenu & "<td>" & oFld.Value & "</td>"
Next oFld
strContenu = strContenu & "</tr>"
oRst.MoveNext
Wend
strContenu = strContenu & "</table></div>"
oMail.HTMLBody = strContenu
oMail.To = "MMMMMMMMMMMMMMMM@FD.fr"
oMail.Subject = "Envoi catalogue"
oMail.Send
oRst.Close
Set oRst = Nothing
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é.
|
| | 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
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim ntsServer As String
Dim ntsMailFile As String
On Error GoTo err_SendNotesMsg
Set oSess = CreateObject("Notes.NotesSession")
ntsServer = oSess.GetEnvironmentString("MailServer", True)
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
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 |
|
| | 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()
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 |
|
| | 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()
Dim wdapp As Word.Application
Dim moncode
moncode = code.Value
Set wdapp = CreateObject("Word.application")
wdapp.Visible = False
wdapp.Documents.Open "j:\Doc_Atelier\td138\td138_gdt.doc"
If code.Value <> "" Then
wdapp.ActiveDocument.Bookmarks("code").Range.Text = code.Value
Else
wdapp.ActiveDocument.Bookmarks("code").Range.Text = "."
End If
wdapp.ActiveDocument.SaveAs "j:\Doc_Atelier\td138\" & moncode & ".doc"
wdapp.ActiveDocument.Close
wdapp.Application.Quit SaveChanges:=wdDoNotSaveChanges
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.
|
 
|
