| |
御質問から日にちが経っておりますので、
取り敢えず参考までにということで…
どういうやり方での送信だったのか判りませんが…
下記のマクロは開いたシートのデータを本文に貼り付けて送信する処理です。
Office XP（Word / Excel / Outlook 2002）で動作を確認しましたが、
2000あるいは2003では動作するかどうか判りません。
（このマクロは参照設定なしでも動作するようにしています。）
Sub MyXlMail()
Rem *----*----* *----*----* *----*----* *----*----*
Rem Excelシートデータ電子メール送信処理
Rem 言語：Excel VBA
Rem 機能...
Rem Excelのシート上にあるデータをコピーして、
Rem 電子メールの本文に貼り付け送信する。
Rem 注記...
Rem 1. Microsoft Outlookで[電子メールの編集にMicrosoft Wordを使用する]を指定しておくこと。
Rem Microsoft Outlookのメニューバーの[ツール]から[オプション...]をクリックし、
Rem [メール形式]タブの[電子メールの編集にMicrosoft Wordを使用する]チェックボックスを
Rem オンにする。
Rem 2. Microsoft Wordの標準コマンドバーに<送信>コマンドボタンを追加しておくこと。
Rem Microsoft Wordのメニューバーの[ツール]から[ユーザー設定...]をクリックし、
Rem [ユーザー設定]ダイアログボックスから[コマンド]タブを選択し、
Rem [分類]の[すべてのコマンド]を選択して、[コマンド]の[EmailSend]を
Rem <標準>コマンドバーにドラッグし、<送信>コマンドボタンを追加する。
Rem 3. Microsoft Outlookが起動している場合、すぐに電子メールが送信される。
Rem 起動してない場合は、これを起動して[送受信]ボタンを押して送信する必要がある。
Rem 4. 警告なしに送信する。
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 Variant ' Outlook.Application
Dim myMail As Variant ' MailItem
Dim myWord As Variant
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文字の空白を件名の先頭に付ける。
myMail.Subject = " " & "このメールはテストです。"
myMail.To = "xxxxxx@msn.com"
myMail.BCC = "xxxxxx@xxxx.ne.jp"
myMail.Body = "下記の通り、お知らせ致します。" & vbCrLf & vbCrLf
myMail.FlagRequest = "凄い！"
myMail.Importance = 2 ' = olImportanceHigh
Rem olImportanceHigh olImportanceLow olImportanceNormal
myMail.Display
'
Set myWord = GetObject(, "Word.Application")
myWord.Selection.EndKey Unit:=6, Extend:=0 ' Unit:=wdStory, Extend:=wdMoveEnd
myWord.Selection.Paste
'
Application.CutCopyMode = False
Range("A1").Select
'
Set myCmmdBar = myWord.CommandBars("Standard") ' 標準
Set myCtrl = myCmmdBar.FindControl(ID:=3708) ' 送信 ' WordBasic.EmailSend
myCtrl.Execute
'
Set myOutlook = Nothing
Set myMail = Nothing
Set myWord = Nothing
Set myCmmdBar = Nothing
Set myCtrl = Nothing
End Sub ' MyXlMail *----*----* *----*----* *----*----* *----*----*
|
|
H. C. Shinopy
- 06/6/6(火) 0:20 -
