| |
Outlook 2003ではセキュリティ対策でメッセージが表示されるようになりました。
（2007以降は、Sendメソッドでメッセージなしで送信できるようです。）
ただ、私は長いことOutlookを使っていないので可否は保証できませんが…
私の知る限りのところを取り敢えず回答します。
2003までの場合、Outlookが「電子メールの編集にMicrosoft Wordを使用する」設定になっていれば、Wordの[送信]ボタンを押す（実行する）マクロを作ればメッセージなしで送信可能。
Outlookが起動した際、裏でWordが起動していますので、それを利用します。
下記は一例として…
Sub MyXlMail()
Rem *----*----* *----*----* *----*----* *----*----*
Rem ExcelシートデータOutlook電子メール送信処理
Rem 言語：Excel VBA
Rem 機能...
Rem Excelのシート上にあるデータをコピーして、
Rem 電子メールの本文に貼り付け送信する。
Rem 注記...
Rem 1. Microsoft Outlook（〜2003）上で、下記の手作業による事前設定が必要。
Rem Microsoft Outlookのメニューバーの[ツール]から[オプション...]をクリックし、
Rem [メール形式]タブの[電子メールの編集にMicrosoft Wordを使用する]チェックボックスを
Rem オンにする。
Rem 2. Microsoft Outlookが起動済みの状態である場合、すぐに電子メールが送信される。
Rem 起動してない場合は、これを起動して[送受信]ボタンを押して送信する必要がある。
Rem 3. 警告なしに送信する。
Rem 4. 不具合あり。
Rem Office2007以降ではExcelシート上のデータを表形式で送信することができない。
Rem 履歴...
Rem 第1版：2006/06/05：作成。参照設定なしで動作。
Rem *----*----* *----*----* *----*----* *----*----*
Rem 参照設定する場合...
Rem Microsoft Outlook 10.0 Object Library
Rem Microsoft Word 10.0 Object Library
Rem *----*----* *----*----* *----*----* *----*----*
Dim myOutlook As Object ' Outlook.Application
Dim myMail As Object ' MailItem
Dim myWord As Object ' Word.Application
Dim myCmmdBar As CommandBar
Dim myCtrl As CommandBarControl
Rem *----*----* *----*----* *----*----* *----*----*
'
ActiveSheet.UsedRange.Select
Selection.Copy
'
On Error Resume Next
Set myOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set myOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
'
Set myMail = myOutlook.CreateItem(0) ' = myOutlook.CreateItem(olMailItem)
With myMail
Rem ↓なぜか､本文の末尾に件名の頭3文字が挿入されるため､3文字の空白を件名の先頭に付ける｡
.Subject = " " & "このメールはテストです。"
.VotingOptions "はい！;いいえ！"
.To = "xxxxxxx@msn.com";
.BCC = "xxxxxx@xxxx.ne.jp";
.body = "下記の通り、お知らせ致します。" & vbCrLf & vbCrLf
.FlagRequest = "凄い！"
.Importance = 2 ' = olImportanceHigh
Rem 0 = olImportanceLow / 1 = olImportanceNormal
Rem メッセージ形式...
Rem テキスト形式の場合、書式設定（文字色・蛍光ペン書式など）は無効になる。
.BodyFormat = 2 ' 1 ' = olFormatPlain / 2 = olFormatHTML
.Display
End With
'
On Error Resume Next
Set myWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set myWord = CreateObject("Word.Application")
myWord.Visible = True
myWord.Documents.Add
End If
On Error GoTo 0
myWord.Selection.EndKey Unit:=6, Extend:=0 ' Unit:=wdStory, Extend:=wdMoveEnd
On Error Resume Next ' シートに何も入力されていない場合に対処。
myWord.Selection.Paste
myWord.Selection.WholeStory
On Error GoTo 0
'
Application.CutCopyMode = False
Range("A1").Select
Rem *----*----* *----*----* *----*----* *----*----*
'
If Val(myOutlook.Version) >= 12 Then
With myMail
.body = .body & myWord.Selection.Range.FormattedText ' myWord.ActiveDocument.Content ' myWord.Selection.FormattedText
.Send
End With
myWord.Documents.Close SaveChanges:=0 ' wdDoNotSaveChanges
myWord.Quit
Else
On Error Resume Next
myWord.CommandBars("Zzz").Delete
On Error GoTo 0
'
Set myCmmdBar = myWord.CommandBars.Add(Name:="Zzz", Position:=msoBarPopup, Temporary:=True)
With myCmmdBar.Controls
Set myCtrl = .Add(Type:=msoControlButton, ID:=3708)
With myCtrl
.Caption = "送信"
.DescriptionText = "電子メールの送信コマンドを実行します。"
.Execute
End With
End With
myCmmdBar.Delete
End If
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myOutlook = Nothing
Set myMail = Nothing
Set myWord = Nothing
Set myCmmdBar = Nothing
Set myCtrl = Nothing
End Sub ' MyXlMail *----*----* *----*----* *----*----* *----*----*
|
|
H. C. Shinopy
- 12/9/20(木) 21:17 -
