' 社内の人からのメールへ返信するメールを作成する
'
' Global
' ★メッセージ本文を記述してください。
'
Const MESSAGE_BODY_TXT = "" & _
          vbNewLine & _
          vbNewLine & _
          "おつかれさまです。" & _
          vbNewLine & _
          vbNewLine & _
          "早速ご回答いただきましてありがとうございます。" & _
          vbNewLine & _
          "貴重なご意見をいただき、とても助かりました。" & _
          vbNewLine & _
          vbNewLine & _
          "今回いただいたご意見を生かし、しっかりと営業活動に利用させていただきます。" & _
          vbNewLine & _
          vbNewLine & _
          "今後ともよろしくご指導のほどお願い致します。" & _
          vbNewLine & _
          vbNewLine & _
          "営業部 佐藤"
          
          
Public Sub 定型文返信()
    Dim nSelectCNT As Integer   '選択されている数、ctrl+クリックで複数選択可能なので
    Dim n As Integer            'ループのカウンター

    ' メールアイテム
    Dim msg As MailItem
    Dim Reply As String
    Dim S1, S2 As Integer
    
    
    nSelectCNT = Application.ActiveExplorer.Selection.Count '選択された件数
    If nSelectCNT = 0 Then
        Exit Sub
    End If
    ' メールをどのように開いているか確認 ------------------
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        ' メールを別ウィンドウとして開いている場合
        Set objItem = ActiveInspector.CurrentItem
    Else
        ' メールを閲覧ウィンドウで開いている場合
        Set objItem = ActiveExplorer.Selection(1)
    End If
    
    For n = 1 To nSelectCNT
    
        ' 選択しているメールアイテムの返信メールを取得 ---------
        ' Set msg = objItem.ReplyAll　元のすべての受信者に対する返信を作成・・・①
        Set msg = objItem.Reply '元の送信者に対する返信を作成　　　　　　 ・・・①
    
        ' メールのカスタマイズ ---------------------------------
        ' CCにメールアドレス挿入　　　　　　　　　　　　　　　　　　　　　・・・②
        ' msg.CC = "ssss.tttt@uuu.com"
    
        ' BCCにメールアドレス挿入　　　　　　　　　　　　　　　　　　　　 ・・・②
        ' msg.BCC = "vvvv.wwww@uuu.com"
        
        ' Subjectの変更　　　　　　　　　　　　　　　　　　　　　　　　　 ・・・③
        ' msg.Subject = "<mmmmmmm>" + msg.Subject
    
        ' ******************苗字取り出し**********************　　　　　　・・・④
        ' 電子メールアカウントの名前　会社固定：xxxx yyyy/苗字 名前 所属
        S1 = 0
        S2 = 0
        Reply = ""
        
        S1 = InStr(msg.To, "/")
        If S1 > 0 Then
            S2 = InStr(S1, msg.To, " ")
            '返信メールの先頭へ名前を挿入
            If S2 > S1 Then
                Reply = Mid(msg.To, S1 + 1, S2 - S1 - 1) & "さん"
            End If
        End If
        ' ******************苗字取り出し**********************
        If Reply = "" Then
            Reply = LastNameSearch(objItem.SenderEmailAddress)
            If Reply <> "" Then
                Reply = Reply & "さん"
            End If
        End If
            
        Reply = Reply & MESSAGE_BODY_TXT
        
        '返信メールの表示 ---------------------------------
        msg.Display
        Call EnterText(Reply)
        
        If n < nSelectCNT Then
            Set objItem = ActiveExplorer.Selection(n + 1)
        End If
    Next n

End Sub

Sub EnterText(strText As String)
    Dim objDoc ' As Word.Document
    On Error Resume Next
    Set objDoc = Application.ActiveInspector.WordEditor
    With objDoc.Windows(1).Selection
'        .Font.Bold = -1
'        .Font.Color = &HFF
'        .Font.Size = 20
        .TypeText strText
    End With
    Set objDoc = Nothing
End Sub

Function LastNameSearch(address As String) As String
    '----- Outlook.Applicationの起動
    Dim oApp As Object        'OutlookのApplication オブジェクトを入れる変数
    Dim myNameSpace As Object '名前の領域を入れる変数
    Dim myFolder As Object    'フォルダー指定する変数

    Set oApp = CreateObject("Outlook.Application")
    
    
    '.GetNamespace("MAPI")
    Set myNameSpace = oApp.GetNamespace("MAPI")
    
    
    '作業フォルダーの指定(.GetDefaultFolder) と 表示(.Display)
    Set myFolder = myNameSpace.GetDefaultFolder(10)      '連絡先
    Dim i As Long   'ループカウンターストック用変数
    Dim name As String
    
    name = ""
    For i = 1 To myFolder.Items.Count   '連絡先データの件数分繰り返す
    'MsgBox myFolder.Items(i).Email1Address
    '-----
        If myFolder.Items(i).Class = olContact Then
            If address = myFolder.Items(i).Email1Address Then
                name = myFolder.Items(i).LastName
                Exit For
            End If
        End If
    '-----
    Next
    LastNameSearch = name
End Function

Public Sub クリップボード返信()
    Dim nSelectCNT As Integer   '選択されている数、ctrl+クリックで複数選択可能なので
    Dim n As Integer            'ループのカウンター

    ' メールアイテム
    Dim msg As MailItem
    Dim Reply As String
    Dim S1, S2 As Integer
    
    
    nSelectCNT = Application.ActiveExplorer.Selection.Count '選択された件数
    If nSelectCNT = 0 Then
        Exit Sub
    End If
    ' メールをどのように開いているか確認 ------------------
    If TypeName(Application.ActiveWindow) = "Inspector" Then
        ' メールを別ウィンドウとして開いている場合
        Set objItem = ActiveInspector.CurrentItem
    Else
        ' メールを閲覧ウィンドウで開いている場合
        Set objItem = ActiveExplorer.Selection(1)
    End If
    
    For n = 1 To nSelectCNT
    
        ' 選択しているメールアイテムの返信メールを取得 ---------
        ' Set msg = objItem.ReplyAll　元のすべての受信者に対する返信を作成・・・①
        Set msg = objItem.Reply '元の送信者に対する返信を作成　　　　　　 ・・・①
    
        ' メールのカスタマイズ ---------------------------------
        ' CCにメールアドレス挿入　　　　　　　　　　　　　　　　　　　　　・・・②
        ' msg.CC = "ssss.tttt@uuu.com"
    
        ' BCCにメールアドレス挿入　　　　　　　　　　　　　　　　　　　　 ・・・②
        ' msg.BCC = "vvvv.wwww@uuu.com"
        
        ' Subjectの変更　　　　　　　　　　　　　　　　　　　　　　　　　 ・・・③
        ' msg.Subject = "<mmmmmmm>" + msg.Subject
    
        ' ******************苗字取り出し**********************　　　　　　・・・④
        ' 電子メールアカウントの名前　会社固定：xxxx yyyy/苗字 名前 所属
        S1 = 0
        S2 = 0
        Reply = ""
        
        S1 = InStr(msg.To, "/")
        If S1 > 0 Then
            S2 = InStr(S1, msg.To, " ")
            '返信メールの先頭へ名前を挿入
            If S2 > S1 Then
                Reply = Mid(msg.To, S1 + 1, S2 - S1 - 1) & "さん" & vbNewLine & vbNewLine
            End If
        End If
        ' ******************苗字取り出し**********************
        If Reply = "" Then
            Reply = LastNameSearch(objItem.SenderEmailAddress)
            If Reply <> "" Then
                Reply = Reply & "さん" & vbNewLine & vbNewLine
            End If
        End If
            
        Reply = Reply & Clipboard
        
        '返信メールの表示 ---------------------------------
        msg.Display
        Call EnterText(Reply)
        
        If n < nSelectCNT Then
            Set objItem = ActiveExplorer.Selection(n + 1)
        End If
    Next n

End Sub