引用:
テンプレート(msg)を再利用して新しくメールを作るExcel vba
引用:
メールの本文の途中に「場合もありますので、ご注意下さい。(担当者の認識とズレてしまいます)」の文字があり、その文字の下から、メールの下までの内容を削除したい
（標準モジュール）
----------------------------------------------------------------
Sub CreateMailItemFromTemplate()
Dim strMailTemplatePath As String
strMailTemplatePath = "C:\未確認アイテム 配信日 2024_06_18.msg"
If Dir(strMailTemplatePath) = "" Then
MsgBox "テンプレートファイル""" & strMailTemplatePath & """が見つかりません。", _
vbExclamation, _
"ファイル参照エラー"
Exit Sub
End If
Dim olkApp As Object 'Outlook.Application
Dim olkMailItem As Object 'Outlook.MailItem
On Error Resume Next
Set olkApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
Set olkApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olkMailItem = olkApp.CreateItemFromTemplate(strMailTemplatePath)
Dim wrdDoc As Object 'Word.Document
With olkMailItem
.To = ""
.CC = "qc@test.com; qa@test.com"
.AutoForwarded = True
.Subject = "PPS未確認アイテム 配信日 " & Format(Date, "yyyy/mm/dd")
.Display
Set wrdDoc = .GetInspector.WordEditor
End With
Dim wrdTargetRange As Object 'Word.Range
Dim lngDeleteStart As Long
Dim lngDeleteEnd As Long
Set wrdTargetRange = wrdDoc.Content
With wrdTargetRange.Find
.ClearFormatting
.ClearAllFuzzyOptions
.Forward = True
.MatchByte = False
.MatchCase = False
.Text = "場合もありますので、ご注意下さい。(担当者の認識とズレてしまいます)"
.Execute
If .Found = True Then
lngDeleteStart = wrdTargetRange.End
lngDeleteEnd = wrdDoc.Content.End
End If
End With
If lngDeleteStart < lngDeleteEnd Then
wrdDoc.Range(lngDeleteStart, lngDeleteEnd).Delete
End If
Set wrdDoc = Nothing
Set olkMailItem = Nothing
Set olkApp = Nothing
End Sub
----------------------------------------------------------------
以上のようなコードを実行できればよい、ということでしょうか。
