Option Explicit
'--------------------------------------------------------------------------------
'関数名：myReplace
'引数：
'strExp：対象の文字列
'strFind：検索するサブ文字列
'strRep：置換後の文字列
'戻り値：
'strExp の長さがゼロ：長さがゼロの文字列 ("")
'strExp が Null ：エラー。
'「strfind」 の長さがゼロ：「strExp」のコピー
'「strRep」 の長さがゼロ：すべての「strFind」が削除された「strExp」のコピー。
'
'参考：以下の、VBAに用意された既存関数の外部仕様を参考にコーディング
'目的は「原始的な置換ロジックのご説明」なので、必須でない引数は省略
'Replace(式、 find、 replace、[ start, [ count, [ compare ]])
'--------------------------------------------------------------------------------
Function myReplace(strExp As String, strFind As String, strRep As String) As String
'strExpのNull検査
If IsNull(strExp) Then
'Nullの使い方が不正です
Err.Raise 94
End If
'strExpの長さ0検査
If Len(strExp) = 0 Then
myReplace = ""
Exit Function
End If
'strFindの長さ0検査
If Len(strFind) = 0 Then
myReplace = strExp
Exit Function
End If
'strRepの長さ0検査
'検査不要。今回作成するロジックでは置換後文字列長は０でもかまわないため。
'置換後のバイト数を確認
Dim lngByte As Long
lngByte = getReplacedBytes(strExp, strFind, strRep)
'領域確保
Dim byteTemp() As Byte
ReDim byteTemp(lngByte + 1)
'置換実行
Call getReplacedString(strExp, strFind, strRep, byteTemp)
'戻り値に設定
myReplace = CStr(byteTemp)
End Function
Function getReplacedBytes(strExp As String, strFind As String, strRep As String) As Long
'--------------------------------------------------------------------------------
'関数名：getReplacedBytes
'引数：
'strExp：対象の文字列
'strFind：検索するサブ文字列
'strRep：置換後の文字列
'戻り値：
' 置換後の全体文字列長
'--------------------------------------------------------------------------------
Dim lngLen As Long '置換後の文字列長
Dim lngSub As Long '検索文字列中のマッチング文字数
Dim lngPos As Long '検索対象文字列中の検索位置
Dim lngWhole As Long '検索対象文字列全体のバイト長
'初期化
lngLen = 0
lngSub = 0
lngPos = 1
lngWhole = LenB(strExp)
'対象文字列を検査し終えるまでループ
Do Until lngPos > lngWhole
If MidB(strExp, lngPos, 1) <> MidB(strFind, lngSub + 1, 1) Then
'マッチングしていない場合
'置換後の全体文字列長に、これまでマッチした文字列長+1を加算
lngLen = lngLen + lngSub + 1
'検索文字列中のマッチング文字数をリセット
lngSub = 0
Else
'マッチングしている場合
If lngSub = LenB(strFind) - 1 Then
'マッチした文字数＝検索文字列長-1（マッチングの終了）
'置換後の全体文字列長に、「置換後の文字列」の長さを加算
lngLen = lngLen + LenB(strRep)
'マッチング文字数をリセット
lngSub = 0
Else
'マッチング終了していない場合
'マッチング文字数+1
lngSub = lngSub + 1
End If
End If
'検索位置を勧める
lngPos = lngPos + 1
Loop
'置換後の全体文字列長に、これまでマッチした文字列長を加算
'補足：検索対象の文字列の最後尾に、検索文字列が途中まで入っているケースへの対応
lngLen = lngLen + lngSub
'戻り値設定
getReplacedBytes = lngLen
End Function
Sub getReplacedString(strExp As String, strFind As String, strRep As String, byteRet() As Byte)
'--------------------------------------------------------------------------------
'関数名：getReplacedString
'引数：
'strExp：対象の文字列
'strFind：検索するサブ文字列
'strRep：置換後の文字列
'byteRet()：置換後の文字列（byte型配列）
'--------------------------------------------------------------------------------
Dim lngSub As Long '検索文字列中のマッチング文字数
Dim lngPos As Long '検索対象文字列中の検索位置
Dim lngDes As Long '置換後全体文字列中の位置
Dim lngWhole As Long '検索対象文字列全体のバイト長
Dim lngIdx As Long
'初期化
lngSub = 0
lngPos = 1
lngDes = 0
lngWhole = LenB(strExp)
'対象文字列を検査し終えるまでループ
Do Until lngPos > lngWhole
If MidB(strExp, lngPos, 1) <> MidB(strFind, lngSub + 1, 1) Then
'マッチングしていない場合
'置換後の全体文字列に、これまでマッチした文字列長+1を追加
For lngIdx = 0 To lngSub
byteRet(lngDes) = AscB(MidB(strExp, lngPos - lngSub + lngIdx))
lngDes = lngDes + 1
Next
'検索文字列中のマッチング文字数をリセット
lngSub = 0
Else
'マッチングしている場合
If lngSub = LenB(strFind) - 1 Then
'マッチした文字数＝検索文字列長-1（マッチングの終了）
'置換後の全体文字列長に、「置換後の文字列」を追加
For lngIdx = 1 To LenB(strRep)
byteRet(lngDes) = AscB(MidB(strRep, lngIdx, 1))
lngDes = lngDes + 1
Next
'マッチング文字数をリセット
lngSub = 0
Else
'マッチング終了していない場合
'マッチング文字数+1
lngSub = lngSub + 1
End If
End If
'検索位置を勧める
lngPos = lngPos + 1
Loop
'置換後の全体文字列長に、これまでマッチした文字列を追加
'補足：検索対象の文字列の最後尾に、検索文字列が途中まで入っているケースへの対応
For lngIdx = 1 To lngSub
byteRet(lngDes) = AscB(MidB(strFind, lngIdx, 1))
lngDes = lngDes + 1
Next
End Sub
Option Explicit
Private Sub Workbook_Open()
'入力規則設定
Const MAX_COL As Long = 1000 'キーワードを検索する右端のセル
Dim arySheet() As String
Dim objSheet As Worksheet
Dim lngCol As Long
'テンプレートを選択するセルをキーワードで探す
lngCol = getColumn("使用テンプレート", "名簿", 1)
'最大列数に到達していない場合、キーワードは見つかったとみなす
If lngCol <> MAX_COL Then
lngCol = lngCol + 1
ReDim Preserve arySheet(0)
For Each objSheet In ThisWorkbook.Sheets
'シート名に「テンプレート」の文字が入っているシートだけをテンプレートとして扱う
If InStr(objSheet.Name, "テンプレート") > 0 Then
'配列変数の配列を１増やす
ReDim Preserve arySheet(UBound(arySheet) + 1)
'シート名設定
arySheet(UBound(arySheet) - 1) = objSheet.Name
End If
Next
'設定先のセルを選択する
ThisWorkbook.Sheets("名簿").Activate
ThisWorkbook.Sheets("名簿").Cells(1, lngCol).Select
If UBound(arySheet) = 0 Then
'対象が無い場合、入力規則をクリアする
With Selection.Validation
.Delete
End With
Else
'対象がある場合、入力規則を設定する
ReDim Preserve arySheet(UBound(arySheet) - 1)
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Chr(32) & Join(arySheet, ",") & Chr(32)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End If
End If
End Sub
Option Explicit
Const TITLE_ROW As Long = 3 'タイトル行
Public Sub pSubSendMail()
Dim lngRow As Long
lngRow = TITLE_ROW + 1
Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
If ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a" Then
Call pSubMakOrSendeMail(lngRow, True)
End If
lngRow = lngRow + 1
Loop
End Sub
Public Sub pSubMakeMail()
Dim lngRow As Long
lngRow = TITLE_ROW + 1
Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
If ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a" Then
Call pSubMakOrSendeMail(lngRow, False)
End If
lngRow = lngRow + 1
Loop
End Sub
Private Sub pSubMakOrSendeMail(lngTargetRow As Long, blnSend As Boolean)
'メール作成
'「名簿マスター」シートの選択行から情報を読み取り、
'「テンプレート」シートのテンプレートに従ってメールを作成する
Const MAX_COL As Long = 1000 'キーワードを検索する右端のセル
Dim objOutlook As Outlook.Application
Dim objMail As MailItem
Dim lngRow As Long
Dim lngCol As Long
Dim strTemp As String
Dim strTitle As String
Dim strValue As String
Dim vntTemp As Variant
Dim varRecipients As Variant
Dim lngIdx As Long
Dim strTemplate As String
'テンプレートを選択するセルをキーワードで探す
lngCol = getColumn("使用テンプレート", "名簿", 1)
'最大列数に到達していない場合、キーワードは見つかったとみなす
If lngCol <> MAX_COL Then
strTemplate = Trim(ThisWorkbook.Sheets("名簿").Cells(1, lngCol + 1))
'Outlookオブジェクト作成
Set objOutlook = New Outlook.Application
'メールアイテム作成
Set objMail = objOutlook.CreateItem(olMailItem)
'＊＊＊ メールに項目を記載 ＊＊＊
'＊＊ ReplyTo ＊＊
strTemp = ThisWorkbook.Sheets(strTemplate).Cells(1, 2)
If strTemp <> "" Then
varRecipients = Split(strTemp, ";")
For lngIdx = 0 To UBound(varRecipients)
objMail.ReplyRecipients.Add varRecipients(lngIdx)
Next
End If
'＊＊ To ＊＊
objMail.To = ThisWorkbook.Sheets("名簿").Cells(lngTargetRow, getCol("電子メール アドレス"))
'＊＊ 件名 ＊＊
objMail.Subject = ThisWorkbook.Sheets(strTemplate).Cells(2, 2)
'＊＊ 本文 ＊＊
'＊ テンプレート読み込み ＊
'%END%になるまで読み込む
lngRow = 3
strTemp = ""
Do While (ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2) <> "%END%")
strTemp = strTemp & ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2) & vbCrLf
lngRow = lngRow + 1
Loop
'＊ キーワード置換 ＊
With ThisWorkbook.Sheets("名簿")
lngCol = 1
Do Until .Cells(TITLE_ROW, lngCol) = ""
strTitle = .Cells(TITLE_ROW, lngCol)
strValue = .Cells(lngTargetRow, lngCol)
strTemp = Replace(strTemp, "%" & strTitle & "%", strValue)
lngCol = lngCol + 1
Loop
End With
objMail.Body = strTemp
'＊＊ 添付ファイルを添付 ＊＊
'＊ 添付ファイルのパスを記載した行を探す ＊
Do While (ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 1) <> "添付ファイル")
lngRow = lngRow + 1
Loop
strTemp = ThisWorkbook.Sheets(strTemplate).Cells(lngRow, 2)
'＊ 添付ファイル追加 ＊
If strTemp <> "" Then
vntTemp = Split(strTemp, ",")
For lngIdx = 0 To UBound(vntTemp)
objMail.Attachments.Add (vntTemp(lngIdx))
Next
End If
'メール表示
objMail.Display
If blnSend Then
objMail.Send
End If
End If
End Sub
Function getCol(strKeyword As String) As Long
getCol = 1
Do Until (ThisWorkbook.Sheets("名簿").Cells(TITLE_ROW, getCol) = "") Or (ThisWorkbook.Sheets("名簿").Cells(TITLE_ROW, getCol) = strKeyword)
getCol = getCol + 1
Loop
End Function
Sub clearCheckAll()
'Noがある行のチェックをクリアする
Dim lngRow As Long
lngRow = TITLE_ROW + 1
Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = ""
lngRow = lngRow + 1
Loop
End Sub
Sub setCheckAll()
'Noがある行のチェックをセットする
Dim lngRow As Long
lngRow = TITLE_ROW + 1
Do Until (ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) = "")
ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a"
lngRow = lngRow + 1
Loop
End Sub
Sub clearCheck()
'Noがある行のチェックをクリアする
Dim lngRow As Long
Dim lngOldRow As Long
Dim objRange As Range
lngOldRow = 0
For Each objRange In Selection
lngRow = objRange.Row
If lngOldRow <> lngRow Then
If lngRow > TITLE_ROW And ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) <> "" Then
ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = ""
End If
lngOldRow = lngRow
End If
Next
End Sub
Sub setCheck()
'Noがある行のチェックをセットする
Dim lngRow As Long
Dim lngOldRow As Long
Dim objRange As Range
lngOldRow = 0
For Each objRange In Selection
lngRow = objRange.Row
If lngOldRow <> lngRow Then
If lngRow > TITLE_ROW And ThisWorkbook.Sheets("名簿").Cells(lngRow, 2) <> "" Then
ThisWorkbook.Sheets("名簿").Cells(lngRow, 1) = "a"
End If
lngOldRow = lngRow
End If
Next
End Sub
Function getColumn(strKeyword As String, strSheet As String, lngRow As Long) As Long
'入力規則設定
Const MAX_COL As Long = 1000 'キーワードを検索する右端のセル
Dim lngCol As Long
'キーワードで探す
lngCol = 1
Do Until ThisWorkbook.Sheets(strSheet).Cells(lngRow, lngCol) = strKeyword Or lngCol > MAX_COL
lngCol = lngCol + 1
Loop
getColumn = lngCol
End Function
'＊ 添付ファイル追加 ＊
If strTemp <> "" Then
'添付ファイルにキーワードを使えるようにする
If Left(strTemp, 1) = "%" Then
'＊ キーワード置換 ＊
With ThisWorkbook.Sheets("名簿")
lngCol = 1
Do Until .Cells(TITLE_ROW, lngCol) = ""
strTitle = .Cells(TITLE_ROW, lngCol)
strValue = .Cells(lngTargetRow, lngCol)
strTemp = Replace(strTemp, "%" & strTitle & "%", strValue)
lngCol = lngCol + 1
Loop
End With
End If
vntTemp = Split(strTemp, ",")
For lngIdx = 0 To UBound(vntTemp)
objMail.Attachments.Add (vntTemp(lngIdx))
Next
End If
Option Explicit
Sub psToggle()
'選択セルの行がグループ化されている場合、閉じる
If Rows(ActiveCell.Row).OutlineLevel > 1 Then
'上へ向かって探索、下へ向かって探索、隠す
Range(Rows(search2Up(ActiveCell)), Rows(search2Down(ActiveCell))).Hidden = True
Else
Select Case ActiveSheet.Outline.SummaryRow
Case 0
'集計行は詳細行の上
'1行下が隠れていて、かつ、Outlineレベルが2以上であるとき、
'折りたたまれていると判定して、開く
If (Rows(ActiveCell.Row + 1).OutlineLevel < 1048576) And (Rows(ActiveCell.Row + 1).Hidden) Then
'下へ向かって探索、表示する
Range(Rows(ActiveCell.Row), Rows(search2Down(ActiveCell))).Hidden = False
End If
Case 1
'集計行は詳細行の下
'1行上が隠れていて、かつ、Outlineレベルが2以上であるとき、
'折りたたまれていると判定して、開く
If (Rows(ActiveCell.Row - 1).OutlineLevel > 1) And (Rows(ActiveCell.Row - 1).Hidden) Then
'上へ向かって探索、表示する
Range(Rows(search2Up(ActiveCell)), Rows(ActiveCell.Row)).Hidden = False
End If
End Select
End If
End Sub
Function search2Up(objRange As Range) As Long
Dim lngFirst As Long
'上へ向かって探索
lngFirst = objRange.Row
If lngFirst - 1 > 1 Then
Do While (lngFirst - 1 > 1) And (Rows(lngFirst - 1).OutlineLevel > 1)
lngFirst = lngFirst - 1
Loop
End If
search2Up = lngFirst
End Function
Function search2Down(objRange As Range) As Long
Dim lngLast As Long
'下へ向かって探索
lngLast = objRange.Row
If lngLast + 1 < 1048576 Then
Do While (lngLast + 1 < 1048576) And (Rows(lngLast + 1).OutlineLevel > 1)
lngLast = lngLast + 1
Loop
End If
search2Down = lngLast
End Function
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
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
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キー：選択行を１つ上へ移動
If ActiveCell.Row > 2 Then
ActiveCell.Offset(-1, 0).Activate
End If
Case "{DOWN}"
'Downキー：選択行を１つ下へ移動
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キー：選択行を１つ上へ移動
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キー：選択行を１つ下へ移動
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
