
02-10-13, 11:24
|
| Όνομα: Δημήτρης Έκδοση λογισμικού Office: Ms-Office 2007 Γλώσσα λογισμικού Office: Ελληνική | | Εγγραφή: 15-12-2011
Μηνύματα: 23
| |
Στο internet βρήκα τον παρακάτω κώδικα που τον προσάρμοσα στη βάση μου και τον εκτελώ με ένα κουμπί cmdEmail
Λειτουργεί αλλά όλα γίνονται από το microsoft. outlook ενεργοποιώντας από τα tools - references to microsoft.object library
κάτι που δεν μπορούν να τρέξουν όλοι οι χρήστες που έχουν άλλα προγράμματα mail Αν υπάρχει ευκολότερος τρόπος θα είναι καλοδεχούμενος.
Private Sub cmdEmail_Click()
Dim rsTable As DAO.Recordset
Dim rsAttachments As DAO.Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
On Error GoTo cmdEmail_Click_Error
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
'Add the To recipient(s) to the message. Substitute
'your names here.
Set objOutlookRecip = .Recipients.Add("onoma@yahoo.com") '<--Recipient's name or email address
objOutlookRecip.Type = olTo
'The Subject of the message.
.Subject = "Email Subject" '<--Subject
'The Email Body Text
.Body = "Body text of the email" '<--Email Body text.
'Instantiate the parent recordset.
Set rsTable = CurrentDb.OpenRecordset("PROTOKOLO")
'rsTable.MoveFirst
'Loop through the Records.
Do While Not rsTable.EOF
'Instantiate the child recordset.
Set rsAttachments = rsTable.Fields("SINIMMENA2").Value
'Loop through the attachments, attaching each one to the email
Do While Not rsAttachments.EOF
'Save current attachment to disk.
rsAttachments.Fields("FileData").SaveToFile "C:\"
Set objOutlookAttach = .Attachments.Add("C:\" & rsAttachments.Fields("FileName"))
'Delete this temp file:
Kill "C:\" & rsAttachments.Fields("FileName")
rsAttachments.MoveNext
Loop
rsTable.MoveNext
Loop
'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
'Send email without viewing it.
'.Send
'Dispay email before sending.
.Display
End With
'Cleanup Code
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Set objOutlookRecip = Nothing
Set objOutlookAttach = Nothing
'No need to close rsAttachments,
'in fact if you close it, it will generate an error
Set rsAttachments = Nothing
rsTable.Close
Set rsTable = Nothing
On Error GoTo 0
Exit Sub
cmdEmail_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdEmail_Click"
End Sub
|