Sub MyXlMail()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem ExcelシートデータOutlook電子メール送信処理
  Rem 作譜：Hitrock Camellia Shinopy
  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   第2版：2006/06/11：Microsoft Wordでの手作業による事前設定が不要になるよう修正した。
  Rem   第3版：2006/06/16：シートに何も入力されていない場合に対処するよう修正した。
  Rem   第4版：2006/06/25：myMail.BodyFormatの設定の不具合を修正した。
  Rem   第5版：2008/08/12：Microsoft Outlookのバージョンにより送信する処理方法を分けた。
  Rem   第6版：2009/04/09：Office2007での送信時の不具合を修正。
  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 *----*----*    *----*----*    *----*----*    *----*----*