Reply-to が設定されているメールに返信するとき、from アドレスを To に入れる

[Outlook VBA]Reply-to が設定されているメールに返信するとき、from アドレスを To に入れる

本記事の解説

まず、本コードは、2015/11~2018/1の間勤務していた職場で使うために作ったコードです。

社外から社内へコードを持ち込む際に、メールや外部記憶媒体を使わない手段を考えたときに選んだ手段が「サイト経由」でした。

そして本記事が書かれたのも1年以上前であり、ほぼ内容そのままの転載ですので陳腐化している可能性もあります。

ただし、当時の日本国内の記事では、with events を使ってeventを拡張する手順を記載したものはありませんでした。

検索してないですけど、今はあるのでしょうか。

ともあれ、何かの参考になれば幸いです。

概要

Reply-to に メーリングリストが設定されているメールに返信するとき、from アドレスを To に入れるVBAです。
メーリングリストを活用する際、ReplyToにメーリングリストを設定するのはよくある事ですが、
メーリングリスト外からメーリングリストにメール送信を行われた場合、その返信の時に差出人が宛先から漏れてしまいます。
そこで、Reply-toがある場合に、FromのユーザーをToに追加するVBAを作成しました。
仕様は以下の通りです。

1 返信メールを作成するタイミングで実行される。
2 ReplyToがある場合、Fromに設定されているアドレスをToに追加する。
3 ReplyToに設定された宛先に対して、「Fromに設定されていてもToに追加しない」という例外判定を行う。
  なお、この際のリストは外出しのテキストファイルとして定義する。
4 動作環境:Outlook2010

参考サイト

(1)ConversationIndex プロパティ (Message オブジェクト) ConversationIndex
(2)Item.To extraction from Outlook olMail-Item on ItemLoad VBA-Event
(3)メーリングリストのメールの差出人に返信し、ほかの受信者を Cc に指定するマクロ


なお。メーリングリスト自身がfromに設定されていることもありますので、
メーリングリストのメンバーとしてメーリングリスト自身も追加しておくのがお勧めです。

コード

以下、コードと解説を記載します。

ThisOutlookSession

返信メールが作成されたタイミングで処理を行うためクラスインスタンスを作成し、
返信メールのItemLoadイベントでクラス「cc」に返信メールのオブジェクトを渡しています。
ItemLoadの時点では初期化処理が行われていないため、VBAからプロパティへの参照・書き込みができません。
そこで、クラスインスタンスの中でOpenイベントを拾う様にしています。

Option Explicit

'クラスインスタンス作成
Dim cc As New cc

Private Sub Application_ItemLoad(ByVal Item As Object)
    If (TypeOf Item Is MailItem) Then
        Set cc.myItem = Item
    End If
End Sub

 

cc

クラスモジュール「cc」を追加し、以下のコードを貼り付けてください。

メインの処理です。クラスモジュールで定義した、アイテムのオープンイベントで処理を行います。
まず、インスペクター全体から返信元文書を探し、見つからなかった場合は、アクティブエクスプローラーの選択行を確認し、返信元文書を見つけます。
インスペクターには、Outlookアイテムのうち、開かれているすべてのアイテムが含まれます。
アクティブエクスプローラーは、Outlookのリスト表示です。
次に、ReplyToアドレスがある場合に処理を行います。
ただし、ReplyToアドレスがメーリングリストである前提で処理を組んでいます。
Fromに指定されたアドレスがメーリングリストに含まれているかどうかの判定を、「isMember」関数で行っていますが、
今回、メーリングリスト参加者のリストはテキストファイルとして外出ししました。
なお、ファイルサーバー上に配置しても問題なく動作します。
ちなみに、メーリングリストに配布リストを使っている場合は自動でメンバー確認する処理も作成できるのですが、
ユースケースとして需要が低いと考えましたので、今回はロジックを組んでいません。

Option Explicit

Public WithEvents myItem As Outlook.MailItem

Private Sub myItem_Open(Cancel As Boolean)
    Const PR_SENT_REPRESENTING_EMAIL_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x0065001e"
    Const PR_SENT_REPRESENTING_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x5d02001e"
    Const PR_SENT_REPRESENTING_NAME = "http://schemas.microsoft.com/mapi/proptag/0x0042001e"
    
    Dim strFromAddress As String
    Dim strFromName As String
    Dim objReply As MailItem                    '返信文書
    Dim objMail As MailItem                     '返信元文書
    Dim objRecipient As Outlook.Recipient
    Dim objInspector As Outlook.Inspector
    Dim strConversationTopic As String
    Dim strConversationIndex As String
    Dim strTemp As String
    Dim strSubject As String
    Dim strConversationIndex4Org As String      '返信元文書のConversationIndex
    Dim strRecipient As String

    '送信していないアイテムのみ処理する
    If myItem.Sent = True Then
        Exit Sub
    End If
    
    '自分自身のConversationTopicとConversationIndexを取得
    Set objReply = myItem
    strConversationTopic = objReply.ConversationTopic
    strConversationIndex = objReply.ConversationIndex
    
    '新規メールについては処理を行わない
    If strConversationIndex = "" Then
        GoTo End_Sub
    End If
    
    '返信元文書のConversationIndexを作成する。
    '返信時、strConversationIndexは末尾に8バイトのタイムスタンプが追加されるので、これを削除する。ただし、削除するのは10バイト。理由は不明。
    '【参考URL】https://msdn.microsoft.com/ja-jp/library/cc420686.aspx
    strConversationIndex4Org = Left(strConversationIndex, Len(strConversationIndex) - 10)
    
    'すべてのインスペクターから、返信元文書を検索する
    strTemp = ""
    For Each objInspector In Inspectors
        Set objMail = objInspector.CurrentItem
        
        If objMail.ConversationIndex = strConversationIndex4Org Then
            strTemp = strTemp & "Inspector:" & objReply.Subject & vbCrLf
            Exit For
        End If
        
        Set objMail = Nothing
    Next
        
    '返信元が無い場合、ActiveExplorerの選択範囲が返信元文書かどうか確認する
    '複数範囲指定されている場合については考慮しない
    If strTemp = "" Then
        Set objMail = ActiveExplorer.Selection(1)
        
        If objMail.ConversationIndex = strConversationIndex4Org Then
            strTemp = strTemp & "ActiveExplorer:" & objMail.Subject & vbCrLf
        End If
    End If
                
    '返信元文書を取得できなかった場合、処理を終了する
    If strTemp = "" Then
        GoTo End_Sub
    End If
    
    '送信時、ReplyTo有無を確認する
    If objMail.ReplyRecipients.Count > 0 Then
        'ReplyToが1以上のとき、処理を行う
        
        ' From のアドレスと表示名を取得
        If objMail.SenderEmailType = "SMTP" Then
            'SMTPから受信した場合
            strFromAddress = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_EMAIL_ADDRESS)
            strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME)
        Else
            'SMTP以外から受信した場合
            strFromAddress = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_SMTP_ADDRESS)
            strFromName = objMail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_NAME)
        End If

        'Fromを返信先に加えるか判定する
        If isMember(strFromAddress, objMail.ReplyRecipients) = False Then
            'From のアドレスについて、名前がついていれば名前付きアドレスにする
            If strFromAddress <> strFromName Then
                strRecipient = """" & strFromName & """" & "<" & strFromAddress & ">"
            Else
                strRecipient = strFromAddress
            End If
            'Fromが返信先に含まれていない場合、Toに追加する
            objReply.Recipients.Add strRecipient
        End If
    End If
    
End_Sub:
    'オブジェクトの解放
    If IsNull(objReply) = False Then
        Set objReply = Nothing
    End If
    If IsNull(objMail) = False Then
        Set objMail = Nothing
    End If
End Sub

Private Function isMember(strFromAddress As String, objMailingLists As Outlook.Recipients) As Boolean
'メーリングリストの中にメンバーが所属しているか判定する
'引数:
'   strFromAddress  :判定するメンバー
'   objMailingLists :メーリングリスト(複数)

Const MAILING_LISTS As String = "C:\temp\mailing_lists.txt"
Dim intFreeFile As Integer
Dim lngIdx As Long
Dim strMailingList As String
Dim strBuf As String

    '戻り値初期化
    isMember = False
        
    For lngIdx = 1 To objMailingLists.Count
        'メーリングリストが複数あった場合も、すべてについて確認を行う
        'メーリングリスト文字列初期化
        strMailingList = objMailingLists.Item(lngIdx).Address
        
        '空き番号取得
        intFreeFile = FreeFile
        
        'メーリングリストファイルを開く
        Open MAILING_LISTS For Input As intFreeFile
        
        'EOFが来るか、メーリングリスト+メンバーの組が見つかるまでループ
        Do
            '1行読み込む
            Line Input #intFreeFile, strBuf
            
            '対象のメーリングリストが見つかった場合、リストを探索
            If strBuf = strMailingList Then
                Do
                    '1行読み込む
                    Line Input #intFreeFile, strBuf
                    
                    'EOF_LISTが来るまでループ
                    If strBuf = "#EOF_LIST" Then
                        Exit Do
                    End If

                    '読み込んだアドレスが引数と一致していた場合、メーリングリストに含まれるメンバーだと判定
                    If strBuf = strFromAddress Then
                        'メーリングリストとメンバーの組があった
                        isMember = True
                        strBuf = "#EOF"
                        Exit Do
                    End If
                Loop
            End If
            
            'EOFが来るまでループ
            If strBuf = "#EOF" Then
                Exit Do
            End If
        Loop
        
        'メーリングリストファイルを閉じる
        Close #intFreeFile
    Next
End Function

 

mailing_lists.txt

メーリングリストを記述するファイルです。
記載例を以下に示します。
なお、ファイル終端に「#EOF」とわざわざ記載したのは、コードで楽をするためです。
普通に「eof(1)」で判定しても良いのですが、そうすると、メンバーが見つかった後の処理について、
gotoを使うか、if条件を追加する事になるので、終了条件に使いませんでした。

#reply-to にメーリングリストが入っていた場合、Fromに入っていてもToに移動しないメンバーを記載します。
#ここに記載のないメーリングリストやメンバーについては、FromからToに追加されます。
#メーリングリストを追加した場合、リストの最後に「#EOF_LIST」を追加してください。

munimuni@googlegroups.com
#EOF_LIST

hogehoge@googlegroups.com
wasawasa@g-mail.co.jp
#EOF_LIST
#EOF

 

入力規則に従ってオートコンプリート入力させる

[Excel VBA] 入力規則に従ってオートコンプリート入力させる

発端

以下のように、先日のばっちりさんのつぶやきが発端です。

で、お勧めされたのでブログを作ってみた次第です。

動作概要

入力規則がリスト形式である場合、リスト内容を前方一致で検索して候補をコメント文で表示します。

そうしてリストが表示されている場合、カーソルキーの上下で候補から選択を行います。

カーソルキーで上下選択を開始する以前であれば、連続入力で複数文字での絞込みが可能です。

一般的なオートコンプリート機能ですね。 ただし、オートコンプリートに使える文字はアルファベットと数字だけです。

動作

以下、動画を貼り付けた投稿です。

コード

VBAではキーボードイベントをApplication.OnKeyメソッドでプロシージャーに割り当てて処理を行っています。

ブックを開いたときに割り当てを行い、ブックを閉じる際に割り当てを解除しています。

キーボードイベントに対してプロシージャーを割り当てるので、同じExcelのプロセス上であればどこでも本VBAの影響を受けます。

本コードは、前述の通り、キーボードイベントをプロシージャーに割り当てたり割り当て解除したりするコード[ThisWorkbook]と、

実際に呼び出され、オートコンプリート処理を行う[modOnKey.bas] の2つのモジュールから成り立っています。

なお、Twitterのやりとりでは、入力規則の入ったセルをカーソルキーで縦移動する際に起こる動作が修正できないとか書いてますが、修正できました。

セルが空文字列であるかどうかで判定するのではなく、「コメント文が存在するか」で判定すればよかったのです。

まあ、百聞は一見にしかずですので、とりあえずコードをごらんください。あまり綺麗なコードでなくて恥ずかしいですが。

似た内容のコードが多くて、なんか、こう、もっと、クラスでまとめたりとかあれこれできたんじゃないかとは思うのですよね。

でもまあ、とりあえずこんな感じで公開しておきます。改善するかどうかは未定です。

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'キーボードイベントのフック処理を戻す
    Call Reset_OnKey
End Sub

Private Sub Workbook_Open()
    'キーボードイベントをフックする
    Call Setup_OnKey
End Sub
Option Explicit

'参考URL
'Refernces
'Keypress events
'https://www.engram9.info/excel-vba-programming/keypress-events.html
'OnKey メソッド (Excel)(MS公式)
'https://docs.microsoft.com/ja-jp/office/vba/api/excel.application.onkey
'すごい名前生成器
'https://namegen.jp/?sex=male&country=japan&middlename=&middlename_cond=fukumu&middlename_rarity=&middlename_rarity_cond=ika&lastname=&lastname_cond=fukumu&lastname_rarity=&lastname_rarity_cond=ika&lastname_type=name&firstname=&firstname_cond=fukumu&firstname_rarity=&firstname_rarity_cond=ika&firstname_type=name

Dim lngRow As Long          '候補の中から選択中の行番号。0は未選択状態。
Dim strBK As String         'オートコンプリート入力されている文字列のバックアップ

Sub Setup_OnKey()
    'キーイベントを関数に割り当てる
    Application.OnKey "0", "Alpha_0_Sub"
    Application.OnKey "1", "Alpha_1_Sub"
    Application.OnKey "2", "Alpha_2_Sub"
    Application.OnKey "3", "Alpha_3_Sub"
    Application.OnKey "4", "Alpha_4_Sub"
    Application.OnKey "5", "Alpha_5_Sub"
    Application.OnKey "6", "Alpha_6_Sub"
    Application.OnKey "7", "Alpha_7_Sub"
    Application.OnKey "8", "Alpha_8_Sub"
    Application.OnKey "9", "Alpha_9_Sub"
    Application.OnKey "A", "Alpha_LA_Sub"
    Application.OnKey "B", "Alpha_LB_Sub"
    Application.OnKey "C", "Alpha_LC_Sub"
    Application.OnKey "D", "Alpha_LD_Sub"
    Application.OnKey "E", "Alpha_LE_Sub"
    Application.OnKey "F", "Alpha_LF_Sub"
    Application.OnKey "G", "Alpha_LG_Sub"
    Application.OnKey "H", "Alpha_LH_Sub"
    Application.OnKey "I", "Alpha_LI_Sub"
    Application.OnKey "J", "Alpha_LJ_Sub"
    Application.OnKey "K", "Alpha_LK_Sub"
    Application.OnKey "L", "Alpha_LL_Sub"
    Application.OnKey "M", "Alpha_LM_Sub"
    Application.OnKey "N", "Alpha_LN_Sub"
    Application.OnKey "O", "Alpha_LO_Sub"
    Application.OnKey "P", "Alpha_LP_Sub"
    Application.OnKey "Q", "Alpha_LQ_Sub"
    Application.OnKey "R", "Alpha_LR_Sub"
    Application.OnKey "S", "Alpha_LS_Sub"
    Application.OnKey "T", "Alpha_LT_Sub"
    Application.OnKey "U", "Alpha_LU_Sub"
    Application.OnKey "V", "Alpha_LV_Sub"
    Application.OnKey "W", "Alpha_LW_Sub"
    Application.OnKey "X", "Alpha_LX_Sub"
    Application.OnKey "Y", "Alpha_LY_Sub"
    Application.OnKey "Z", "Alpha_LZ_Sub"
    Application.OnKey "a", "Alpha_Sa_Sub"
    Application.OnKey "b", "Alpha_Sb_Sub"
    Application.OnKey "c", "Alpha_Sc_Sub"
    Application.OnKey "d", "Alpha_Sd_Sub"
    Application.OnKey "e", "Alpha_Se_Sub"
    Application.OnKey "f", "Alpha_Sf_Sub"
    Application.OnKey "g", "Alpha_Sg_Sub"
    Application.OnKey "h", "Alpha_Sh_Sub"
    Application.OnKey "i", "Alpha_Si_Sub"
    Application.OnKey "j", "Alpha_Sj_Sub"
    Application.OnKey "k", "Alpha_Sk_Sub"
    Application.OnKey "l", "Alpha_Sl_Sub"
    Application.OnKey "m", "Alpha_Sm_Sub"
    Application.OnKey "n", "Alpha_Sn_Sub"
    Application.OnKey "o", "Alpha_So_Sub"
    Application.OnKey "p", "Alpha_Sp_Sub"
    Application.OnKey "q", "Alpha_Sq_Sub"
    Application.OnKey "r", "Alpha_Sr_Sub"
    Application.OnKey "s", "Alpha_Ss_Sub"
    Application.OnKey "t", "Alpha_St_Sub"
    Application.OnKey "u", "Alpha_Su_Sub"
    Application.OnKey "v", "Alpha_Sv_Sub"
    Application.OnKey "w", "Alpha_Sw_Sub"
    Application.OnKey "x", "Alpha_Sx_Sub"
    Application.OnKey "y", "Alpha_Sy_Sub"
    Application.OnKey "z", "Alpha_Sz_Sub"

    Application.OnKey "{DEL}", "Alpha_DEL_Sub"
    Application.OnKey "{ESC}", "Alpha_ESC_Sub"
    Application.OnKey "{UP}", "Alpha_UP_Sub"
    Application.OnKey "{DOWN}", "Alpha_DOWN_Sub"
    Application.OnKey "{ENTER}", "Alpha_ENTER_Sub"
    Application.OnKey "~", "Alpha_ENTER2_Sub"
End Sub

Sub Reset_OnKey()
    'キーイベントの解放
    Application.OnKey "0", ""
    Application.OnKey "1", ""
    Application.OnKey "2", ""
    Application.OnKey "3", ""
    Application.OnKey "4", ""
    Application.OnKey "5", ""
    Application.OnKey "6", ""
    Application.OnKey "7", ""
    Application.OnKey "8", ""
    Application.OnKey "9", ""
    Application.OnKey "A", ""
    Application.OnKey "B", ""
    Application.OnKey "C", ""
    Application.OnKey "D", ""
    Application.OnKey "E", ""
    Application.OnKey "F", ""
    Application.OnKey "G", ""
    Application.OnKey "H", ""
    Application.OnKey "I", ""
    Application.OnKey "J", ""
    Application.OnKey "K", ""
    Application.OnKey "L", ""
    Application.OnKey "M", ""
    Application.OnKey "N", ""
    Application.OnKey "O", ""
    Application.OnKey "P", ""
    Application.OnKey "Q", ""
    Application.OnKey "R", ""
    Application.OnKey "S", ""
    Application.OnKey "T", ""
    Application.OnKey "U", ""
    Application.OnKey "V", ""
    Application.OnKey "W", ""
    Application.OnKey "X", ""
    Application.OnKey "Y", ""
    Application.OnKey "Z", ""
    Application.OnKey "a", ""
    Application.OnKey "b", ""
    Application.OnKey "c", ""
    Application.OnKey "d", ""
    Application.OnKey "e", ""
    Application.OnKey "f", ""
    Application.OnKey "g", ""
    Application.OnKey "h", ""
    Application.OnKey "i", ""
    Application.OnKey "j", ""
    Application.OnKey "k", ""
    Application.OnKey "l", ""
    Application.OnKey "m", ""
    Application.OnKey "n", ""
    Application.OnKey "o", ""
    Application.OnKey "p", ""
    Application.OnKey "q", ""
    Application.OnKey "r", ""
    Application.OnKey "s", ""
    Application.OnKey "t", ""
    Application.OnKey "u", ""
    Application.OnKey "v", ""
    Application.OnKey "w", ""
    Application.OnKey "x", ""
    Application.OnKey "y", ""
    Application.OnKey "z", ""

    Application.OnKey "{DEL}", ""
    Application.OnKey "{ESC}", ""
    Application.OnKey "{UP}", ""
    Application.OnKey "{DOWN}", ""
    Application.OnKey "{ENTER}", ""
    Application.OnKey "~", ""
End Sub

Sub myKeyPress(strChar As String)
Dim strTemp As String
Dim colMatch As Collection
    'KeyEventをフックして文字を表示したり、入力規則の文字選択を楽に行う
    '入力規則がある場合、オートコンプリートさせる
    On Error Resume Next
    If ActiveCell.Validation.Type <> xlValidateList Then
        '入力規則がリスト形式でない、もしくは入力規則がない場合は、
        '通常の入力処理と同等の処理になるようにキー入力を処理する。
        'なお、入力規則が無い場合はIf文中の「ActiveCell.Validation.Type」でエラーになる。
        '「On Error Resume Next」は「エラー時「次の行へ」進む」ので、こちらの分岐に入る。
        Select Case strChar
            Case "{DEL}"
                'セル範囲をクリア
                Selection.ClearContents
            Case "{ESC}"
                'セルの値をクリア
                ActiveCell.Value = ""
            Case "{UP}"
                'Upキー:選択行を1つ上へ移動
                If ActiveCell.Row > 2 Then
                    ActiveCell.Offset(-1, 0).Activate
                End If
            Case "{DOWN}"
                'Downキー:選択行を1つ下へ移動
                If ActiveCell.Row < 1048576 Then
                    ActiveCell.Offset(1, 0).Activate
                End If
            Case "{ENTER}"
                'Enterキー:確定して下へ移動
                If ActiveCell.Row < 1048576 Then
                    ActiveCell.Offset(1, 0).Activate
                End If
            Case Else
                'キー入力をそのまま伝え、編集状態にする
                ActiveCell.Value = ActiveCell.Value & strChar
                SendKeys "{F2}"
        End Select
    Else
        'オートコンプリートする
        Select Case strChar
            Case "{DEL}"
                'セル範囲をクリア
                Selection.ClearContents
            
                'コメント削除
                Call sClearAutoComp(ActiveCell)
            Case "{ESC}"
                'セルの値をクリア
                ActiveCell.Value = ""
            
                'コメント削除
                Call sClearAutoComp(ActiveCell)
            Case "{UP}"
                'Upキー:選択行を1つ上へ移動
                If Not (ActiveCell.Comment.Visible) Then
                    '入力文字列が無い場合、通常通りの移動を行う
                    If ActiveCell.Row > 2 Then
                        ActiveCell.Offset(-1, 0).Activate
                    End If
                Else
                    Select Case lngRow
                        Case 0
                            '何もしない
                        Case 1
                            '未選択状態にする
                            ActiveCell.Value = strBK
                            lngRow = 0
                        Case Else
                            'オートコンプリートの候補内で移動
                            lngRow = lngRow - 1
                            Set colMatch = fCheckAutoComp(ActiveCell, strBK)
                            ActiveCell.Value = colMatch.Item(lngRow)
                            Set colMatch = Nothing
                    End Select
                End If
            Case "{DOWN}"
                'Downキー:選択行を1つ下へ移動
                If Not (ActiveCell.Comment.Visible) Then
                    '入力文字列が無い場合、通常通りの移動を行う
                    If ActiveCell.Row < 1048576 Then
                        ActiveCell.Offset(1, 0).Activate
                    End If
                Else
                    'オートコンプリートの候補内で移動
                    Set colMatch = fCheckAutoComp(ActiveCell, strBK)
                    If lngRow < colMatch.Count Then
                        lngRow = lngRow + 1
                        ActiveCell.Value = colMatch.Item(lngRow)
                    End If
                    Set colMatch = Nothing
                End If
            
            Case "{ENTER}"
                'コメント削除
                Call sClearAutoComp(ActiveCell)
                
                'Enterキー:確定して下へ移動
                If ActiveCell.Row < 1048576 Then
                    ActiveCell.Offset(1, 0).Activate
                End If
            Case Else
                '現在のオートコンプリート範囲を消去
                Set colMatch = fCheckAutoComp(ActiveCell, ActiveCell.Value)
                If colMatch.Count > 0 Then
                    Call sClearAutoComp(ActiveCell)
                End If
            
                '入力されたキーを加えた場合の文字列作成
                strTemp = ActiveCell.Value & strChar
                
                '入力されたキーが入力規則にマッチしているか確認
                Set colMatch = fCheckAutoComp(ActiveCell, strTemp)
                
                '入力されたキーが入力規則に含まれている個数を判定
                Select Case colMatch.Count
                    Case 0
                        '0個:入力を捨てる
                        '0個:新規入力とみなしてセルをクリア
                    Case 1
                        '1個:確定して下へ
                        ActiveCell.Value = colMatch.Item(1)
                        ActiveCell.Offset(1, 0).Activate
                        Call sClearAutoComp(ActiveCell)
                    Case Else
                        '2個以上:オートコンプリート範囲を描画
                        '自セルには現在の入力文字列を表示
                        ActiveCell.Value = ActiveCell.Value & strChar
                       
                        'オートコンプリート範囲を描画
                        Call sDisplayAutoComp(ActiveCell, colMatch)
                        
                        '未選択状態にセット
                        lngRow = 0
                        strBK = ActiveCell.Value
                End Select
                
                Set colMatch = Nothing
        End Select
    End If
    On Error GoTo 0
End Sub

Function fCheckAutoComp(objRange As Range, strInput As String) As Collection
'--------------------------------------------------------------------------------
'オートコンプリート結果を取得する
'--------------------------------------------------------------------------------
'引数:
' objRange As Range:入力先セル
'戻り値:
' Collection:オートコンプリート結果をコレクションで返す
'--------------------------------------------------------------------------------
Dim strValidate As String
Dim vntValidate As Variant
Dim objValidate As Range

    'Collection 初期化
    Set fCheckAutoComp = New Collection

    '入力規則取得
    strValidate = objRange.Validation.Formula1
    
    '入力規則の先頭文字が「=」である場合、名前付き範囲が入力規則を示す
    If Left(strValidate, 1) = "=" Then
        '入力規則が「名前付き範囲」の場合
        For Each objValidate In Range(Mid(strValidate, 2))
            If UCase(Left(objValidate.Value, Len(strInput))) = UCase(strInput) Then
                '前方一致した場合、一致した単語をコレクションへ追加
                Call fCheckAutoComp.Add(objValidate.Value)
            End If
        Next
    Else
        '入力規則が「文字列の列挙」の場合
        '分割
        For Each vntValidate In Split(strValidate, ",")
            '前方一致した場合、一致した単語をコレクションへ追加
            If UCase(Left(CStr(vntValidate), Len(strInput))) = UCase(strInput) Then
                '前方一致した場合、一致した単語をコレクションへ追加
                Call fCheckAutoComp.Add(CStr(vntValidate))
            End If
        Next
    End If
End Function

Sub sDisplayAutoComp(objRange As Range, colMatch As Collection)
'--------------------------------------------------------------------------------
'オートコンプリート結果を表示する
'--------------------------------------------------------------------------------
'引数:
'objRange As Range:入力中のセル
'colMatch As Collection:オートコンプリート結果
'--------------------------------------------------------------------------------
Dim lngIdx As Long
Dim strDisplay As String

    'オートコンプリート結果を表示
    strDisplay = ""
    For lngIdx = 1 To colMatch.Count
        strDisplay = strDisplay & colMatch.Item(lngIdx) & vbLf
    Next
    
    '文末の改行を削除
    strDisplay = Left(strDisplay, Len(strDisplay) - 1)
    
    'コメントで表示
    Call objRange.AddComment(strDisplay)
    objRange.Comment.Visible = True
    
    'コメントの高さを調整
    objRange.Comment.Shape.TextFrame.AutoSize = True
End Sub

Sub sClearAutoComp(objRange As Range)
    'オートコンプリート結果を消す
    'コメントをクリア
    Call objRange.ClearComments
End Sub


Sub Alpha_0_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("0")
    End If
End Sub
Sub Alpha_1_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("1")
    End If
End Sub
Sub Alpha_2_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("2")
    End If
End Sub
Sub Alpha_3_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("3")
    End If
End Sub
Sub Alpha_4_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("4")
    End If
End Sub
Sub Alpha_5_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("5")
    End If
End Sub
Sub Alpha_6_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("6")
    End If
End Sub
Sub Alpha_7_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("7")
    End If
End Sub
Sub Alpha_8_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("8")
    End If
End Sub
Sub Alpha_9_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("9")
    End If
End Sub
Sub Alpha_LA_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("A")
    End If
End Sub
Sub Alpha_LB_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("B")
    End If
End Sub
Sub Alpha_LC_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("C")
    End If
End Sub
Sub Alpha_LD_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("D")
    End If
End Sub
Sub Alpha_LE_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("E")
    End If
End Sub
Sub Alpha_LF_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("F")
    End If
End Sub
Sub Alpha_LG_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("G")
    End If
End Sub
Sub Alpha_LH_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("H")
    End If
End Sub
Sub Alpha_LI_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("I")
    End If
End Sub
Sub Alpha_LJ_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("J")
    End If
End Sub
Sub Alpha_LK_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("K")
    End If
End Sub
Sub Alpha_LL_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("L")
    End If
End Sub
Sub Alpha_LM_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("M")
    End If
End Sub
Sub Alpha_LN_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("N")
    End If
End Sub
Sub Alpha_LO_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("O")
    End If
End Sub
Sub Alpha_LP_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("P")
    End If
End Sub
Sub Alpha_LQ_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("Q")
    End If
End Sub
Sub Alpha_LR_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("R")
    End If
End Sub
Sub Alpha_LS_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("S")
    End If
End Sub
Sub Alpha_LT_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("T")
    End If
End Sub
Sub Alpha_LU_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("U")
    End If
End Sub
Sub Alpha_LV_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("V")
    End If
End Sub
Sub Alpha_LW_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("W")
    End If
End Sub
Sub Alpha_LX_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("X")
    End If
End Sub
Sub Alpha_LY_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("Y")
    End If
End Sub
Sub Alpha_LZ_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("Z")
    End If
End Sub
Sub Alpha_Sa_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("a")
    End If
End Sub
Sub Alpha_Sb_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("b")
    End If
End Sub
Sub Alpha_Sc_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("c")
    End If
End Sub
Sub Alpha_Sd_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("d")
    End If
End Sub
Sub Alpha_Se_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("e")
    End If
End Sub
Sub Alpha_Sf_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("f")
    End If
End Sub
Sub Alpha_Sg_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("g")
    End If
End Sub
Sub Alpha_Sh_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("h")
    End If
End Sub
Sub Alpha_Si_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("i")
    End If
End Sub
Sub Alpha_Sj_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("j")
    End If
End Sub
Sub Alpha_Sk_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("k")
    End If
End Sub
Sub Alpha_Sl_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("l")
    End If
End Sub
Sub Alpha_Sm_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("m")
    End If
End Sub
Sub Alpha_Sn_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("n")
    End If
End Sub
Sub Alpha_So_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("o")
    End If
End Sub
Sub Alpha_Sp_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("p")
    End If
End Sub
Sub Alpha_Sq_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("q")
    End If
End Sub
Sub Alpha_Sr_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("r")
    End If
End Sub
Sub Alpha_Ss_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("s")
    End If
End Sub
Sub Alpha_St_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("t")
    End If
End Sub
Sub Alpha_Su_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("u")
    End If
End Sub
Sub Alpha_Sv_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("v")
    End If
End Sub
Sub Alpha_Sw_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("w")
    End If
End Sub
Sub Alpha_Sx_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("x")
    End If
End Sub
Sub Alpha_Sy_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("y")
    End If
End Sub
Sub Alpha_Sz_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("z")
    End If
End Sub

Sub Alpha_UP_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("{UP}")
    End If
End Sub

Sub Alpha_DOWN_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("{DOWN}")
    End If
End Sub

Sub Alpha_ENTER_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("{ENTER}")
    End If
End Sub

Sub Alpha_ENTER2_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("{ENTER}")
    End If
End Sub

Sub Alpha_DEL_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("{DEL}")
    End If
End Sub

Sub Alpha_ESC_Sub()
    On Error Resume Next
    If TypeName(ActiveSheet) = "Worksheet" Then
    Call myKeyPress("{ESC}")
    End If
End Sub