Excel SendMail

Msg

Subject

EmailTo

EmailCC

EmailBCC

Attachment

Importance

Public Enum ImportanceLevel

  High

  Medium
  Low
End Enum

Function SendMessage(Msg As String, Subject As String, EmailTo As String, _
                     Optional EmailCC As String, Optional EmailBCC As String, _
                     Optional Attachment As String, _
                     Optional Importance As ImportanceLevel = 1)
' by Jimmy Pena, http://www.codeforexcelandoutlook.com, October 18 2009

  On Error Resume Next

  Const olMailItem As Long = 0


 Dim Outlook As Object  ' Outlook.Application
 Dim OutlookMsg As Object  'Outlook.MailItem


 Set Outlook = GetOutlookApp
  If Outlook Is Nothing Then GoTo ProgramExit

 
 Set OutlookMsg = Outlook.CreateItem(olMailItem)

  With OutlookMsg

    ' set basic params
   .Subject = Subject
    .HTMLBody = Msg

    .To = EmailTo

    ' add cc's (if any)
   If Len(EmailCC) > 0 Then
      .CC = EmailCC
    End If

    ' add bcc's (if any)
   If Len(EmailBCC) > 0 Then
      .BCC = EmailBCC
    End If

    ' add attachments
   If Len(Attachment) > 0 Then
      If Len(Dir(Attachment)) > 0 Then
        .Attachments.Add (Attachment)
      End If
    End If

    ' set importance
   Select Case Importance
    Case 0  ' high
     .Importance = olImportanceHigh
    Case 1  ' medium
     .Importance = olImportanceNormal
    Case 2  ' low
     .Importance = olImportanceLow
    End Select

    .Display
    '.Send
    '.Save
  End With
On Error GoTo continue
SendEmail:
     AppActivate OutlookMsg
     DoEvents
    SendKeys "%s", Wait:=True    '特別注意此處，該項表示相關於在郵件編輯窗口中，單擊發送按鈕
    DoEvents
    AppActivate OutlookMsg
GoTo SendEmail
continue:
   On Error GoTo 0
    Set Outlook = Nothing
    Set OutlookMsg = Nothing

'Next
Set OutlookMsg = Nothing
Set Outlook = Nothing

ProgramExit:
  Exit Function
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Function

Function GetOutlookApp() As Object
  On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0
End Function