| |
すみません。マクロを少し修正しました
一時的に「Zzz」というコマンドバーを追加し、
そこに[送信]コマンドボタンを追加して実行します。
これで、Wordでの事前設定は不要です。
注記1.について：
事前に、手作業でOutlookの [電子メールの編集にMicrosoft Wordを使用する]をオンにして下さい。マクロでやろうとして、
「myMail.FormDescription.UseWordMail = True」とすると、
なぜか[送信]ボタンが機能しなくなります。
（たぶん、セキュリティ上そうなっているのでしょう。）
注記2.について：
「起動済みの状態」とは、Outlookを起動して使っているという意味ですが、
会社などでOutlookを使用する場合、パソコンに電源を入れて動いている間、
Outlookを常に動かしていると思います。（メールの受信待ちのため、
大抵はOutlookのウインドウを最小化した状態にしているはずです。
これも、「起動済みの状態」です。）
処理後にOutlookのフォルダを確認して頂ければ、未送信の場合、メールが[送信トレイ]に残っています。無事に送信済みであれば、[送信済みアイテム]にメールが移っています。
Office 2002で動作することを確認しています。
2000あるいは2003をお使いの方がいらしたら、
このマクロの動作可否をお知らせ頂けたらと存じます。
Sub MyXlMail()
Rem *----*----* *----*----* *----*----* *----*----*
Rem Excelシートデータ電子メール送信処理
Rem 言語：Excel VBA
Rem 機能...
Rem Excelのシート上にあるデータをコピーして、
Rem 電子メールの本文に貼り付け送信する。
Rem 注記...
Rem 1. Microsoft Outlook上で、下記の手作業による事前設定が必要。
Rem Microsoft Outlookのメニューバーの[ツール]から[オプション...]をクリックし、
Rem [メール形式]タブの[電子メールの編集にMicrosoft Wordを使用する]チェックボックスを
Rem オンにする。
Rem 2. Microsoft Outlookが起動済みの状態である場合、すぐに電子メールが送信される。
Rem 起動してない場合は、これを起動して[送受信]ボタンを押して送信する必要がある。
Rem 3. 警告なしに送信する。
Rem 履歴...
Rem 第1版：2006/06/05：作成。
Rem 第2版：2006/06/11：Microsoft Wordでの手作業による事前設定が不要になるよう修正した。
Rem 第3版：2006/06/16：シートに何も入力されていない場合に対処するよう修正した。
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
'
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)
Rem ↓なぜか、本文の末尾に件名の頭3文字が挿入されるため、3文字の空白を件名の先頭に付ける。
myMail.Subject = " " & "このメールはテストです。"
myMail.To = "xxxxxxx@msn.com"
myMail.BCC = "xxxxxx@xxxx.ne.jp"
myMail.Body = "下記の通り、お知らせ致します。" & vbCrLf & vbCrLf
myMail.FlagRequest = "凄い！"
myMail.Importance = 2 ' = olImportanceHigh
Rem olImportanceHigh olImportanceLow olImportanceNormal
Rem メッセージ形式...
Rem テキスト形式の場合、書式設定（文字色・蛍光ペン書式など）は無効になる。
myMail.BodyFormat = olFormatPlain ' olFormatHTML
myMail.Display
'
Set myWord = GetObject(, "Word.Application")
myWord.Selection.EndKey Unit:=6, Extend:=0 ' Unit:=wdStory, Extend:=wdMoveEnd
On Error Resume Next ' シートに何も入力されていない場合に対処。
myWord.Selection.Paste
On Error GoTo 0
'
Application.CutCopyMode = False
Range("A1").Select
'
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
'
Set myOutlook = Nothing
Set myMail = Nothing
Set myWord = Nothing
Set myCmmdBar = Nothing
Set myCtrl = Nothing
End Sub ' MyXlMail *----*----* *----*----* *----*----* *----*----*
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 06/3/28(火) 16:24 -
- 06/3/28(火) 18:07 -
