• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 391
  • Last Modified:

Send mail form Excel using Visual Basic

How can I send a mail from Excel? I mean wryly send it, not just showing the mail-sending dialog. This should work so, that I have to set the parameters from VB code (address, attachment, subject, CC: etc), then send the mail. Is it any solution to this?
0
octi
Asked:
octi
  • 8
  • 5
  • 2
  • +2
1 Solution
 
Ryan ChongCommented:
Hi octi, u can use the outlook object to send the mail, then attach the Excel file as an attachment/ or body?

See this sample: Control Outlook from Excel
http://www.erlandsendata.no/english/vba/ole/controloutlook.htm
0
 
ie1978Commented:
This should do it, if you don't want an attatchment just delete the relevant lines of code

Cheers

ie

Sub SendMessage(AttachmentPath)
         
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim dDate As Date
   
    On Error GoTo fail
   
    Set objOutlook = CreateObject("Outlook.Application")

    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

    dDate = Now

    With objOutlookMsg
        Set objOutlookRecip = .Recipients.Add("e-mail address")
        objOutlookRecip.Type = olTo
       
        Set objOutlookRecip = .Recipients.Add("e-mail address")
        objOutlookRecip.Type = olTo
       
        Set objOutlookRecip = .Recipients.Add("e-mail address")
        objOutlookRecip.Type = olTo
       
        Set objOutlookRecip = .Recipients.Add("type e-mail address")
        objOutlookRecip.Type = olTo
       
        Set objOutlookRecip = .Recipients.Add("asaldanha@fandc.co.uk")
        objOutlookRecip.Type = olTo
       
        .Subject = "Volatility Prediction"
        .Body = "Volatility Prediction for " & Space(1) & dDate & vbCrLf & vbCrLf
        .Importance = olImportanceHigh  'High importance

        If Not IsMissing(AttachmentPath) Then
            Set objOutlookAttach = .Attachments.Add(AttachmentPath)
        End If

        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
        Next
       
       .Send

    End With
       
    Set objOutlook = Nothing

Exit Sub

fail:
    MsgBox "E-mail has failed", vbExclamation

End Sub
0
 
ie1978Commented:
Guess I should explain it.

.subject   is the subject of the e-mail
.body      is the body of the e-mail

obviously, u don't need to send it to as many people as I have...used this code only last week :)

if you need any more help pls ask

Cheers

ie
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
octiAuthor Commented:
The solutions are not working because references missing from the Outlook objects. The other problem is, that if I use on other default mailer (Netscape), this samples are unusable.
Thanks,
       Br. Attila
0
 
mcbethCommented:
Try this.. You'll need to reference MS CDO Object. The Class use the CDO Object to send your Mail. To Add Attachments create a new Function like Recipient.
Run StartMapiSession to Logon to your Mail Account. Your standard profile comes from the reg.

Option Explicit
Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
End Type

Enum eDialog
    ShowDialog = True
    HideDialog = False
End Enum

Enum eSession
    NewSession = True
    NoNewSession = False
End Enum

Const REG_SZ As Long = 1
Const REG_DWORD As Long = 4
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_NONE = 0
Const ERROR_BADDB = 1
Const ERROR_BADKEY = 2
Const ERROR_CANTOPEN = 3
Const ERROR_CANTREAD = 4
Const ERROR_CANTWRITE = 5
Const ERROR_OUTOFMEMORY = 6
Const ERROR_INVALID_PARAMETER = 7
Const ERROR_ACCESS_DENIED = 8
Const ERROR_INVALID_PARAMETERS = 87
Const ERROR_NO_MORE_ITEMS = 259
Const KEY_ALL_ACCESS = &H3F
Const REG_OPTION_NON_VOLATILE = 0

Dim oSession As MAPI.Session
Dim oMessage As MAPI.Message
Dim oRecipient As MAPI.Recipient
Dim oAttachment As MAPI.Attachment
Dim oStore As MAPI.InfoStore
Dim isRunning As Boolean

Dim lzMailCC As String
Dim lzMailSubject As String
Dim lzMailText As String



Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long



Public Sub EndMapiSession()
oSession.Logoff
isRunning = False
End Sub

Public Sub MailSubject(pzSubject As String)
lzMailSubject = pzSubject
End Sub

Public Sub MailText(pzText As String)
lzMailText = pzText
End Sub


Private Function QueryValue(sKeyName As String, sValueName As String)
Dim lRetVal As Long     'result of the API functions
Dim hKey As Long        'handle of opened key
Dim vValue As Variant   'setting of queried value

lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

On Error GoTo QueryValueExError

' Determine the size and type of data to be read
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5

Select Case lType
   ' For strings
   Case REG_SZ:
      sValue = String(cch, 0)
      lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
      If lrc = ERROR_NONE Then
         vValue = Left$(sValue, cch)
      Else
         vValue = Empty
      End If
   ' For DWORDS
   Case REG_DWORD:
      lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
      If lrc = ERROR_NONE Then vValue = lValue
   Case Else
      'all other data types not supported
      lrc = -1
End Select

QueryValueExExit:
         QueryValueEx = lrc
         Exit Function
QueryValueExError:
         Resume QueryValueExExit
End Function


Public Function SessionRunning() As Boolean
SessionRunning = isRunning
End Function

Public Function SetRecipient(lzRecipient As String) As Long
On Error GoTo ErrorHandler
If Not isRunning Then
    SetRecipient = -1
    Exit Function
End If
Set oRecipient = oMessage.Recipients.Add
oRecipient.Name = lzRecipient
oRecipient.Type = ActMsgTo
oRecipient.Resolve

SetRecipient = 0
Exit Function

ErrorHandler:
    SetRecipient = Err
End Function


Public Function StartMapiSession(Optional Profile As String, Optional nDialog As eDialog, Optional nSession As eSession) As Long
Dim retValue As Long
Dim lzProfile As String

If Len(Profile) < 1 Then
    retValue = GetDefaultProfile(lzProfile)
    If retValue <> 0 Then
        StartMapiSession = -1
        Exit Function
    End If
Else
    lzProfile = Profile
End If

Set oSession = CreateObject("MAPI.Session")
On Error Resume Next
If nDialog = ShowDialog Then
    oSession.Logon ShowDialog:=True, NewSession:=nSession
Else
    oSession.Logon lzProfile, ShowDialog:=False, NewSession:=nSession
End If
If Err <> 0 Then
    StartMapiSession = Err
    Exit Function
End If
Set oMessage = oSession.Outbox.Messages.Add
If Err <> 0 Then
    StartMapiSession = Err
    Exit Function
End If
StartMapiSession = 0
isRunning = True
End Function

Private Function GetDefaultProfile(ByRef lzProfile As String) As Long
Dim osInfo As OSVERSIONINFO
Dim retValue As Integer
Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserProfile As String
osInfo.dwOSVersionInfoSize = 148
osInfo.szCSDVersion = Space(128)
retValue = GetVersionEx(osInfo)
Select Case osInfo.dwPlatformId
Case 0 'Keine Info
    GetDefaultProfile = -1
    Exit Function
Case 1 ' Win95
    sKeyName = "Software\Microsoft\Windows Messaging Subsystem\Profiles"
Case 2 ' Win NT
    sKeyName = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles"
End Select

sValueName = "DefaultProfile"
sDefaultUserProfile = QueryValue(sKeyName, sValueName)
lzProfile = sDefaultUserProfile
GetDefaultProfile = 0
End Function


Private Sub Class_Initialize()
isRunning = False
End Sub


Public Function CreateMessage(nImportance As ActMsgImportance) As Long
On Error GoTo ErrorHandler
If Not isRunning Then
    CreateMessage = -1
    Exit Function
End If
oMessage.Importance = nImportance
oMessage.Subject = lzMailSubject
oMessage.Text = lzMailText
oMessage.Update
oMessage.Send ShowDialog:=False
CreateMessage = 0
Exit Function

ErrorHandler:
    CreateMessage = Err
End Function

Private Sub Class_Terminate()
If isRunning Then oSession.Logoff
End Sub


0
 
octiAuthor Commented:
Thanks for your answer mcbeth, but what you wrote there is a list of functions. I can't use it in excel as a macro, and I still don't konw how to send a mail.
0
 
mcbethCommented:
Sorry but you can (thanks to VBA). If you don't won't to put the code into excel, create an ActiveX DLL (the code is ready to use). Add a reference to the dll and all you need is :
Sub Macroxy()
Dim xMail As New cMAIL
xMail.startmapisession
lpResult = xMail.SetRecipient(<email_address>)
xMail.MailText <BOdyText>
xMail.CreateMessage ActMsgHigh
xMail.EndMapiSession
end sub
0
 
Éric MoreauSenior .Net ConsultantCommented:
Download the free vbSendMail from http://www.freevbcode.com/ShowCode.Asp?ID=109
0
 
octiAuthor Commented:
mcbeth>
In the VBA of my excel the Enum type is not recognized. Is there a problem with my excel version? I use Excel 8.0.

0
 
mcbethCommented:
>octi

just replace enum in functionheader and delete enums

Public Function StartMapiSession(Optional Profile As String, Optional nDialog As boolean, Optional nSession
As boolean) As Long

---------------------------------------------------
nDialog = true ( Show Dialog for Profile)
nSession = true (CreateNewSession)
0
 
octiAuthor Commented:
mcbeth>
This types are not recognized in Excel VBA
 octi

MAPI.Session
MAPI.Message
MAPI.Recipient
MAPI.Attachment
MAPI.InfoStore
0
 
mcbethCommented:
you have to reference the CDO Objects to your Excel Macro
if you are still in vba mode enter menu extra and click Reference. There you'll find Microsoft CDO for Windows 2000 Libraray. Add to code and excel vba will recognized it. btw.. it's a better way to download the file emoreau
posted. If you use vbsendmail you do not have to install any mailclient on your workstation to send mails... :-)
0
 
octiAuthor Commented:
I have NT 4.0.
For me, your solution is better, becase I must use a certain mail client.
0
 
mcbethCommented:
octi>
for NT 4 you have to reference

Active messaging Object Libraray

( its a former version
of the CDO Objects).

good luck...
0
 
octiAuthor Commented:
mcbeth>
How can I make an instance of the cMail class from your exemple? Where is declared this? It gives me a compile error.
0
 
octiAuthor Commented:
emoreau>
Sorry, but that solution with the free dll is not portable.
Beside this it's redundant. Why to make such dll if already exist in windows?
0
 
octiAuthor Commented:
emoreau>
Sorry, but that solution with the free dll is not portable.
Beside this it's redundant. Why to make such dll if already exist in windows?
0

Featured Post

NFR key for Veeam Backup for Microsoft Office 365

Veeam is happy to provide a free NFR license (for 1 year, up to 10 users). This license allows for the non‑production use of Veeam Backup for Microsoft Office 365 in your home lab without any feature limitations.

  • 8
  • 5
  • 2
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now