VBA/Excel/Access/Word/Outlook/Email

Материал из VB Эксперт
Версия от 15:47, 26 мая 2010; Admin (обсуждение | вклад) (1 версия)
(разн.) ← Предыдущая | Текущая версия (разн.) | Следующая → (разн.)
Перейти к: навигация, поиск

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

   <source lang="vb">

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

</source>
   
  


Display the information in a list of mails

   <source lang="vb">

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

</source>
   
  


Searching for Items

   <source lang="vb">

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

</source>
   
  


Send a table through email

   <source lang="vb">

Sub TestSendObject()

   DoCmd.SendObject acSendTable, "tblEmployees", acFormatXLS, "someone@yahoo.ru", , , "Employee List", "For your review.", False

End Sub

</source>
   
  


Send email by Using POP3

   <source lang="vb">

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

</source>
   
  


Send email for all records in an Access table

   <source lang="vb">

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

</source>
   
  


Sending a Message

   <source lang="vb">

Sub sendingmess()

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

End Sub

</source>
   
  


Send out an email by using the DoCmd.SendObject

   <source lang="vb">

Sub SendEmail

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

End Sub

</source>
   
  


Using the CreateItem Method to Create Default Items

   <source lang="vb">

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

</source>