Εμφάνιση ενός μόνο μηνύματος
  #2  
Παλιά 02-10-13, 11:24
dim.konst Ο χρήστης dim.konst δεν είναι συνδεδεμένος
Όνομα: Δημήτρης
Έκδοση λογισμικού 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
Απάντηση με παράθεση