●Excelから、シートに記載されている一覧を使って、メールを作成して下書きに保管
するようなものを作りたいと考えております。
・シート名:メール作成保管
・B2=件名、B3=提携本文が記載しております。(内容の中に、<送り先1>、<送り先2>があり、6行目からのD列:<送り先1>とE列<送り先2>のデータが差し込まれるようにしたいのです。・C3には、署名があります。
・6行目から宛先別のデータ一覧があります。
A列=メインのアドレス、B列=CCのアドレス、C列=BCCのアドレス、D列=送り先1に貼り付ける内容、E列=<送り先2に貼り付ける内容、F列=添付ファイルのPATHがあります。
※各行によって、メインアドレス、CCアドレス、BCCアドレス、送り先1、送り先2、添付ファイルを
それぞれのメールに適用させたいと考えております。
▲;下記のコードを実行すると、下書きに、メールは、作られるのですが、本文の<送り先1>、<送り先2>にD列、E列の内容が差し込まれません。署名が崩れてしまいます。下記コードをどのように修正したら良いのでしょうか
質問が下手なため、わかりにくいかと思いますが、ご指摘頂きながら、進行できれば良いと思っております。
宜しくお願い致します。
■件名(B2):「件名テスト」
■本文(B3):
<送り先1>送り先1
<送り先2>さま
ただいま、テスト中
二行目の書き込みテスト
三行目の書き込みテスト、明日の時間、明後日の時間
■署名(C3):
****************************
株式会社名
部署名 課名
担当者 指名
郵便番号 住所
担当者の電話番号
担当者のFAX番号
******************************"
●●●●●●●●●●●●下記VBA●●●●●●●●●●●●●
Dim oApp As New Outlook.Application
Dim oItem As Outlook.MailItem
Dim WSH As Object
Set WSH = CreateObject("Wscript.Shell")
Dim DesktopPath As String
DesktopPath = WSH.SpecialFolders("Desktop")
Dim 本文 As String, 件名 As String, 署名 As String
Dim 宛先列番号 As Long
Dim i, k, x
'Cells(1, 4) = "●": Stop
i = 6
Do Until Cells(i, 2) = ""
If Cells(i, 21) = "" Then
件名 = Cells(2, 2).Text
本文 = Cells(3, 2).Text
署名 = Cells(3, 3).Text
k = 5
'MsgBox 件名
'MsgBox 本文
Do Until Cells(6, k) = ""
件名 = Replace(件名, "<" & Cells(6, k) & ">", Cells(i, k))
本文 = Replace(本文, "<" & Cells(6, k) & ">", Cells(i, k))
署名 = Replace(署名, "<" & Cells(6, k) & ">", Cells(i, k))
k = k + 1
Loop
本文 = Replace(本文, vbLf, "<br />") 'HTMLが含まれたメッセージ
'MsgBox 本文: Stop
Set oItem = oApp.CreateItem(olMailItem)
'送信元を変更する場合、下記の行を有効にしてアカウント名を入力（Microsoft Outlook ○○ Object Library」を有効必須
'oItem.SendUsingAccount = Session.Accounts(“アカウント名”)
oItem.To = Replace(Cells(i, 1), vbLf, ";")
oItem.subject = 件名
'署名 = "<p style='font-size:14pt; font-weight:bold;'>" & 署名 & "</p>"
oItem.HTMLBody = "" & 本文 & "<br />" & Replace(署名, vbCrLf, "") & ""
oItem.CC = Replace(Cells(i, 2), vbLf, ";")
oItem.BCC = Replace(Cells(i, 3), vbLf, ";")
'oItem.Importance = olImportanceHigh
Dim 添付()
x = 0
ReDim Preserve 添付(x)
添付(x) = Cells(i, 6).Text
If 添付(x) <> "" Then
Select Case InStr(添付(x), vbLf)
Case Is = 0
oItem.Attachments.Add 添付(x)
Case Else
Do Until InStr(添付(x), vbLf) = 0
x = x + 1
ReDim Preserve 添付(x)
添付(x) = Mid(添付(x - 1), InStr(添付(x - 1), vbLf) + 1)
添付(x - 1) = Left(添付(x - 1), InStr(添付(x - 1), vbLf) - 1)
If 添付(x - 1) <> "" Then
oItem.Attachments.Add 添付(x - 1)
End If
Loop
If 添付(x) <> "" Then
oItem.Attachments.Add 添付(x)
End If
End Select
End If
oItem.Display '送信せずに画面を表示する
oItem.Save '下書き保存
oItem.Close 0 '閉じる
'oItem.Send ’送る場合
End If
i = i + 1
Loop
MsgBox "下書きに保管されました。"
