EXCEL VBA呼叫OUTLOOK寄信(單一收件者，沒附件)

'產生郵件內容!! (傳入要寄送的EmailAddress)
Sub MailSend(ByVal EmailCC As String)

Dim i As Integer
Dim MailContent As String
Dim MySubject As String

'依照個人訊息決定的動態郵件內容
Dim MailComboMsg As String

Dim SenderEml As String '副本接收者

MySubject = Sheets("mailContent").Range("B1")
MailContent = Sheets("mailContent").Range("B2")
SenderEml = Sheets("mailContent").Range("B3")


'MailContent = Replace(MailContent, "", Sheets("input").Range("C5"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("E5"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B7"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B13"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B14"))
'MailContent = Replace(MailContent, "", Sheets("input").Range("B15"))
'MsgBox MailContent
'Exit Sub

Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim newMail As Outlook.MailItem

Dim k As String
'目前清單的範圍



'同一個人代為聯絡的數量
Dim nCount As Integer
'Set fso = CreateObject("Scripting.FileSystemObject")

Set ol = New Outlook.Application
'Return a reference to the MAPI layer.
'-------------------------------------------------------------------------------------------------

'準備寫入郵件！
'******************************************************************************************
Set ns = ol.GetNamespace("MAPI")
ns.Logon
'Create a new mail message item.
Set newMail = ol.CreateItem(olMailItem)

With newMail

'Add the subject of the mail message.
.Subject = MySubject

'Create some body text.

'Add a recipient and CC and test to make sure that the
'addresses are valid using the Resolve method.
'郵件位址 判斷 使用者 是要使用 字串 或是 清單

'MsgBox "收件者：" & X.Value

With .Recipients.Add(EmailCC)

.Type = olTo

If Not .Resolve Then
MsgBox "Unable to resolve address: TO", vbInformation
Exit Sub
End If
End With


With .Recipients.Add(SenderEml)
.Type = olBCC
If Not .Resolve Then
MsgBox "Unable to resolve address: Bcc", vbInformation
Exit Sub
End If
End With

'.Body = txtContentString.Text
'"nnn@email.ccc.tw"

MailContent = Replace(MailContent, "", Sheets("input").Range("C5"))
MailContent = Replace(MailContent, "", Sheets("input").Range("E5"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B7"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B13"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B14"))
MailContent = Replace(MailContent, "", Sheets("input").Range("B15"))

.Body = MailContent
'.Attachments.Add (ThisWorkbook.Path & "\xxxx.doc")
'.Attachments.Add (ThisWorkbook.Path & "\" & num1 & "文章.doc")

'Send the mail message.
.Send

End With

ns.Logoff

Set ns = Nothing
Set newMail = Nothing

'----------------------------------------------------------------------------------------------------
'Release memory.
Set ol = Nothing
'MsgBox "寄送完成"

End Sub