Sub myMailReplyOne()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 返信メール作成定型文挿入処理
  Rem 記録者：Hitrock Camellia Shinopy
  Rem 言語：Outlook VBA
  Rem 機能...
  Rem   開いている受信トレイアイテム（一通）を元に､
  Rem   定型文を挿入して、返信メールを作成する｡
  Rem 注記...
  Rem   受信トレイアイテムを開く前に、マクロを実行しておくほうが便利。
  Rem   受信トレイのアイテムを開いた状態で処理が有効。
  Rem 履歴...
  Rem   第1版：2005/10/14：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Dim blln As Balloon
  Dim bttn As Long
  Dim bllnID As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 初期処理を実行させる。
  bttn = -888
  Call myMailReplyOneBttn(blln, bttn, bllnID)
End Sub ' myMailReplyOne *----*----*    *----*----*    *----*----*    *----*----*

Sub myMailReplyOneBlln(myPage As Variant)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem バルーン表示処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Dim myTitle As String
  Dim myPageMax As Integer
  Dim myText As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "myMailReplyOne"
  myPageMax = 3
  '
  Assistant.Visible = True
  '
  With Assistant.NewBalloon
    .Animation = msoAnimationIdle
    .BalloonType = msoBalloonTypeButtons
    .Icon = msoIconAlertQuery
    Rem *----*----*    *----*----*
    Rem 見出し表示
    myText = myTitle & vbCr
    myText = myText & "定型文" & " " & "返信" & " " & "処理" & vbCr
    myText = myText & myPage & "/" & myPageMax & "頁" & vbCr
    .Heading = myText
    .Text = "選択して下さい。"
    Rem *----*----*    *----*----*
    Rem ラベル表示
    Select Case myPage
      Case 1
        .Labels(1).Text = "入荷済み"
        .Labels(2).Text = "未入荷"
        '.Labels(3).Text = ""
        '.Labels(4).Text = ""
        '.Labels(5).Text = ""
        .Button = msoButtonSetNextClose
       Case 2
        .Labels(1).Text = "検品中"
        '.Labels(2).Text = ""
        '.Labels(3).Text = ""
        '.Labels(4).Text = ""
        '.Labels(5).Text = ""
        .Button = msoButtonSetBackNextClose
      Case 3
        .Labels(1).Text = "出荷済み"
        .Labels(2).Text = "未出荷"
        '.Labels(3).Text = ""
        '.Labels(4).Text = ""
        '.Labels(5).Text = ""
        .Button = msoButtonSetBackClose
    End Select
    Rem *----*----*    *----*----*
    .Mode = msoModeModeless
    .Callback = "myMailReplyOneBttn"
    .Show
  End With
End Sub ' myMailReplyOneBlln *----*----*    *----*----*    *----*----*    *----*----*

Sub myMailReplyOneBttn(blln As Balloon, bttn As Long, bllnID As Long)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 各ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Dim myTitle As String
  Dim myMail As MailItem
  Dim myText As String
  Dim myBody As String
  Dim myAns As Long
  '
  Static myPage As Variant
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Select Case bttn
    Case msoBalloonButtonClose, msoBalloonButtonCancel
      blln.Close
      Assistant.Visible = False
      Exit Sub
    Case msoBalloonButtonNext
      blln.Close
      myPage = myPage + 1
      Call myMailReplyOneBlln(myPage)
      GoTo myMailReplyOneBttnSubExit
    Case msoBalloonButtonBack
      blln.Close
      myPage = myPage - 1
      Call myMailReplyOneBlln(myPage)
      GoTo myMailReplyOneBttnSubExit
    Case -888 ' 初期処理
      Call myMailReplyOneInit(myPage)
      Call myMailReplyOneBlln(myPage)
      Exit Sub
  End Select
  '
  On Error Resume Next
  If TypeName(ActiveInspector.CurrentItem) <> "MailItem" Then Exit Sub
  '
  myTitle = "myMailReplyOne"
  '
  Set myMail = ActiveInspector.CurrentItem
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
myMailReplyOneBttnSubEntry:
  Select Case bttn
    Case 1 To 5
      myText = "[ " & myMail.SenderName & " ]様へ" & vbCr
      myText = myText & "[ " & myMail.Subject & " ]を" & vbCr
      myText = myText & "[ " & blln.Labels(bttn).Text & " ]の回答で" & vbCr
      myText = myText & "返信します。"
      With Assistant.NewBalloon
        .Animation = msoAnimationIdle
        .Icon = msoIconAlert
        .Button = msoButtonSetOkCancel
        .Heading = myTitle & vbCr & "[返信の確認]"
        .Text = myText
        myAns = .Show
      End With
      '
      myMail.Close olDiscard
      If myAns <> msoBalloonButtonOK Then GoTo myMailReplyOneBttnSubExit
  End Select
  Application.ActiveExplorer.WindowState = olMinimized
  '
  Rem 定型文
  myText = myMail.SenderName & " 様、" & vbCrLf
  myText = myText & "御照会の件、下記の通り回答いたします。"
  myText = myText & vbCrLf & vbCrLf
  '
  Select Case bttn
    Case 1 To 5
      myText = myText & "下記の物件は、"
      myText = myText & blln.Labels(bttn).Text & "です｡" & vbCrLf
      myText = myText & "以上" & vbCrLf
  End Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With myMail.Reply
    Rem 重要度・フラグ
    ' .Importance = olImportanceHigh  ' olImportanceHigh olImportanceLow olImportanceNormal
    ' .FlagRequest = "御確認ください。"
    '
    Rem CC・件名
    .CC = myMail.CC
    .Subject = "Re:" & myMail.Subject
    '
    Rem 本文
    .Body = myText & vbCrLf
    Rem 受信トレイアイテムの本文を引用する。
    myBody = ">" & myMail.Body
    myBody = Replace(myBody, vbCrLf, vbCrLf & ">")
    .Body = .Body & myBody
    '
    Rem 返信メールを表示する。／保存する。
    .Display ' .Close olDiscard
    .Send ' 返信メールを送信する。
  End With
  '
myMailReplyOneBttnSubExit:
  Assistant.Visible = True ' 次のボタン押下に備える。
  Assistant.Animation = msoAnimationIdle
  Application.ActiveExplorer.WindowState = olNormalWindow
  '
  Set myMail = Nothing
End Sub ' myMailReplyOneBttn *----*----*    *----*----*    *----*----*    *----*----*

Sub myMailReplyOneInit(myPage As Variant)
  If TypeName(myPage) = "Empty" Then
    myPage = 1
  End If
End Sub ' myMailReplyOneInit *----*----*    *----*----*    *----*----*    *----*----*