| |
Excel 2007の場合、MailItem オブジェクト.Sendで送信できました。
2002の場合（2003は不明）、注記の条件下で、裏で動いているWordを「GetObject(, "Word.Application")」で拾ってきて、Wordの[送信]ボタンを押すことで送信できます。
（しかし、私のかつての環境では､「本文の末尾に件名の頭3文字が挿入される」珍現象が出ました。）
いずれも随分前の話で、今の私の環境ではテストできないので、動作の保証はできません。
（最下段のマクロ）
また、O'REILLY（オライリー）社の「EXCEL HACKS 第2版」の「HACK140」362頁に下の記述がありました。
「…このようなダイアログボックスが表示されないようにするためのツールがいくつか公開されています。
Express ClickYes（ht tp://www.contextmagic.com/express-clickyes/）」はフリーで利用できます。
VBAのコードの中から設定したい場合は、商用のOutlook Redemption（ht tp://www.dimastr.com/redemption/）を使うとよいでしょう。」
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 第5版：2008/08/12：Microsoft Outlookのバージョンにより送信する処理方法を分けた。
Rem *----*----* *----*----* *----*----* *----*----*
Rem 参照設定する場合...
Rem Microsoft Outlook 10.0 Object Library
Rem Microsoft Word 10.0 Object Library
Rem *----*----* *----*----* *----*----* *----*----*
Dim myOutlook As Variant ' Outlook.Application
Dim myMail As Variant ' MailItem
Dim myWord As Variant ' 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
- 09/10/21(水) 21:47 -
