VBA/Excel/Access/Word/Outlook/Email

Adds an addressee, a subject, and body text; applies the HTML format; sets the importance to high; and sends the message:

 
Sub message()
    Dim myMessage As MailItem
    Set myMessage = Application.CreateItem(ItemType:=olMailItem)
    With myMessage
        .To = "yourName@yourSite.ru"
        .Subject = "Preparation "
        .Body = "review."
        .BodyFormat = olFormatHTML
        .Importance = olImportanceHigh
        .Send
    End With
End Sub

Display the information in a list of mails

 
Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim myMailItem As Object
    Dim intMsgIDStart As Integer, intMsgIDEnd As Integer
    Dim intCutPoint As String, strMailItemID As String
    intMsgIDStart = 1
    intCutPoint = Len(EntryIDCollection)
    intMsgIDEnd = InStr(intMsgIDStart, EntryIDCollection, ",")
    Do While intMsgIDEnd <> 0
        strMailItemID = Strings.Mid(EntryIDCollection, intMsgIDStart, _
            (intMsgIDEnd - intMsgIDStart))
        Set myMailItem = Application.Session.GetItemFromID(strMailItemID)
        Debug.Print myMailItem.Subject
        intMsgIDStart = intMsgIDEnd + 1
        intMsgIDEnd = InStr(intMsgIDStart, EntryIDCollection, ",")
    Loop
End Sub

Searching for Items

 
Sub Sample_Advanced_Search()
    Dim mySearch As Search
    Dim myResults As Results
    Dim intCounter As Integer
    Set mySearch = AdvancedSearch(Scope:="Inbox",Filter:="urn:schemas:mailheader:subject = "Project"")
    Set myResults = mySearch.Results
    If myResults.Count > 0 Then
        Debug.Print "found"
    For intCounter = 1 To myResults.Count
        Debug.Print myResults.Item(intCounter).SenderName
    Next intCounter
    Else
        Debug.Print "no messages that match the search criteria."
    End If
End Sub

Send a table through email

 
Sub TestSendObject()
    DoCmd.SendObject acSendTable, "tblEmployees", acFormatXLS, "someone@yahoo.ru", , , "Employee List", "For your review.", False
End Sub

Send email by Using POP3

 
Public Sub SendUsingPOP3()
    Dim myMailItem As Outlook.MailItem
    Dim colAccounts As Outlook.Accounts
    Dim oNS As Outlook.NameSpace
    Dim oAccount As Outlook.Account
    Dim strUser As String
    Dim strAddress As String
    Dim strAccountName As String
    Dim blnFound As Boolean
    blnFound = False
    Set oNS = Application.GetNamespace("MAPI")
    Set colAccounts = oNS.Accounts
    For Each oAccount In colAccounts
        If oAccount.AccountType = OlAccountType.olPop3 Then
            strAddress = oAccount.SmtpAddress
            strUser = oAccount.UserName
            strAccountName = oAccount.DisplayName
            blnFound = True
            Exit For
        End If
    Next
    If blnFound Then
        Set myMailItem = Application.CreateItem(olMailItem)
        myMailItem.Subject = "Sent using: " & strAccountName
        myMailItem.Body = "Sent by " & strUser & vbCrLf & "Sent using the " & strAddress & " SMTP address."
        myMailItem.Recipients.Add ("test@test.ru")
        myMailItem.Recipients.ResolveAll
        Set myMailItem.SendUsingAccount = oAccount
        myMailItem.Send
    End If
End Sub

Send email for all records in an Access table

 
Sub ControlOutlook()
    
    Dim objOutlook As New Outlook.Application
    Dim objEmail As Outlook.MailItem
    
    Dim strLtrContent As String
    Dim rsContacts As New ADODB.Recordset
    
    rsContacts.ActiveConnection = CurrentProject.Connection
    rsContacts.Open "tblContacts"
    
    Do While Not rsContacts.EOF
       strLtrContent = "Dear " & rsContacts("FirstName") & " "
       strLtrContent = strLtrContent & rsContacts("LastName") & ":" 
       Set objEmail = objOutlook.CreateItem(olMailItem)
       objEmail.Recipients.Add rsContacts("Email")
       objEmail.Subject = "Our address has changed."
       objEmail.Body = strLtrContent
       objEmail.Send
       rsContacts.MoveNext
    Loop
End Sub

Sending a Message

 
Sub sendingmess()
    Dim myMessage As MailItem
    Set myMessage = Application.CreateItem(ItemType:=olMailItem)
    myMessage.Send
End Sub

Send out an email by using the DoCmd.SendObject

 
Sub SendEmail
    DoCmd.SendObject acSendNoObject, , , "d@yahoo.ru", , , "This is cool!", "an email.", False
End Sub

Using the CreateItem Method to Create Default Items

 
Sub mail()
    Dim myMessage As MailItem
    Set myMessage = Application.CreateItem(ItemType:=olMailItem)
    With myMessage
        .To = "test@example.ru"
        .Subject = "Test message"
        .Body = "This is a test message."
        .Display
    End With
End Sub