AccessのSQLビューでTAB、ShiftTABを使用

Access VBA

Option Compare Database
Option Explicit
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
    ByVal hwndParent As Long, _
    ByVal hwndChildAfter As Long, _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Public Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" _
    (ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long, _
    ByVal fuFlags As Long, _
    ByVal uTimeout As Long, _
    lpdwResult As Long) As Long
Public Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

'Message関連
Public Const WM_GETTEXT = &HD
Public Const WM_SETTEXT = &HC
Public Const EM_GETSEL = &HB0
Public Const EM_SETSEL = &HB1
Public Const SMTO_ABORTIFHUNG = &H2

'キー
Public Const VK_TAB = &H9
Public Const VK_SHIFT = &H10

'ソース文字列、選択開始文字位置、選択終了文字位置
Private Type SEL_STRING
    strString As String
    lngLineStart As Long
    lngLineEnd As Long
End Type

Public blQuerySQLView As Boolean
'Tab、ShiftTabを有効にするボタン
'AutoExec等に記載
Public Function EditSQLView()
    
    Dim cb As CommandBar
    On Error GoTo ErrHDL
    
    Set cb = Application.CommandBars.Add("SQLViewEdit", msoBarTop, , True)
    cb.Visible = True
    With cb.Controls.Add(msoControlButton)
        .Caption = "SQLEditOn"
        .OnAction = "StartLoop"
        .style = msoButtonCaption
    End With

ErrHDL:
    
End Function
'Tab、ShiftTabを有効にする
Public Sub StartLoop()
    
    Dim ctl As CommandBarButton
    blQuerySQLView = True
    Set ctl = Application.CommandBars("SQLViewEdit").Controls("SQLEditOn")
    ctl.OnAction = "EndLoop"
    ctl.Caption = "SQLEditOff"
    KeyBoardChk
    
End Sub
'Tab、ShiftTabを無効にする
Public Sub EndLoop()
    
    Dim ctl As CommandBarButton
    Set ctl = Application.CommandBars("SQLViewEdit").Controls("SQLEditOff")
    ctl.OnAction = "StartLoop"
    ctl.Caption = "SQLEditOn"
    blQuerySQLView = False
    
End Sub
'Tab、ShiftTabの検出ループ
Public Sub KeyBoardChk()

    Dim lngRet As Long
    Dim s_sel As SEL_STRING
    
    Do While blQuerySQLView = True
        lngRet = GetAsyncKeyState(VK_TAB)
        If lngRet And &H1 Then  '押しっぱを排除
            If lngRet And &H8000 Then
                s_sel = GetActiveSelString()
                If GetAsyncKeyState(VK_SHIFT) And &H8000 Then
                    'Debug.Print "Shift"
                    SetSQLToQuery DelIndent(s_sel)
                Else
                    'Debug.Print "NoShift"
                    SetSQLToQuery AddIndent(s_sel)
                End If
            End If
        End If
        DoEvents
    Loop

End Sub
'アクティブなクエリウィンドウのSQLビューでSQLソース、
'選択開始位置、選択終了位置を取得
Private Function GetActiveSelString() As SEL_STRING
    
    Dim hWnd As Long
    Dim wParam As Long
    Dim lParam As Long
    Dim strBuff As String
    Dim lpdwResult As Long
    Dim lngRet As Long
    Dim strRet As String
    Dim lngSt As Long
    Dim lngEd As Long
    
    Dim s_sel As SEL_STRING
    
    
    'SQLビューのテキストボックスハンドル
    hWnd = FindWindowEx(0, 0, "OMain", vbNullString)
    hWnd = FindWindowEx(hWnd, 0, "MDIClient", "")
    hWnd = FindWindowEx(hWnd, 0, "OQry", vbNullString)
    hWnd = FindWindowEx(hWnd, 0, "OKttbx", vbNullString)
    
    If hWnd = 0 Then
        Exit Function
    End If
    
    
    'SQL文の取得
    strBuff = String(4096, vbNullChar)
    lngRet = SendMessageTimeout(hWnd, _
                                WM_GETTEXT, _
                                Len(strBuff), _
                                StrPtr(strBuff), _
                                SMTO_ABORTIFHUNG, _
                                1000, _
                                lpdwResult)
    strRet = StrConv(Left(strBuff, InStr(strBuff, vbNullChar) - 1), vbUnicode)
    
    'SQL文の選択範囲を取得
    lngRet = SendMessageTimeout(hWnd, _
                                EM_GETSEL, _
                                VarPtr(wParam), _
                                VarPtr(lParam), _
                                SMTO_ABORTIFHUNG, _
                                1000, _
                                lpdwResult)
    
    
'    Debug.Print lParam
'    Debug.Print wParam
    
    
    s_sel.lngLineStart = wParam
    s_sel.lngLineEnd = lParam
    s_sel.strString = strRet
    
    GetActiveSelString = s_sel
    
End Function
'アクティブなクエリウィンドウのSQLビューに指定の文字列、選択範囲を設定する
Private Sub SetSQLToQuery(s_sel As SEL_STRING)
    
    Dim hWnd As Long
    Dim lngRet As Long
    Dim lpdwResult As Long
    Dim strTmp As String
    
    hWnd = FindWindowEx(0, 0, "OMain", vbNullString)
    hWnd = FindWindowEx(hWnd, 0, "MDIClient", "")
    hWnd = FindWindowEx(hWnd, 0, "OQry", vbNullString)
    hWnd = FindWindowEx(hWnd, 0, "OKttbx", vbNullString)
    
    '選択範囲前と選択範囲後の改行を補う
    strTmp = s_sel.strString
    strTmp = StrConv(strTmp, vbFromUnicode)
    
    'SQL文の設定
    lngRet = SendMessageTimeout(hWnd, _
                                WM_SETTEXT, _
                                0, _
                                StrPtr(strTmp), _
                                SMTO_ABORTIFHUNG, _
                                1000, _
                                lpdwResult)
    'SQL文の選択範囲の設定
    lngRet = SendMessageTimeout(hWnd, _
                                EM_SETSEL, _
                                s_sel.lngLineStart, _
                                s_sel.lngLineEnd, _
                                SMTO_ABORTIFHUNG, _
                                1000, _
                                lpdwResult)
    
End Sub
'文字列中の先頭から指定の文字目が何行目に該当するかを返す
Private Function GetLineNumber(strLine As String, lngChars As Long) As Long
    
    Dim lngNum As Long
    Dim strTmp As String
    
    strTmp = Left(strLine, lngChars)
    If lngChars = 0 Then
        lngNum = 0
    Else
        lngNum = (Len(strTmp) - Len(Replace(strTmp, vbCrLf, ""))) / 2
    End If
    GetLineNumber = lngNum
    
End Function
'指定の開始文字位置、終了文字位置の間の行頭にインデントを追加し、
'合わせて開始文字位置、終了文字位置を更新して返す。
Private Function AddIndent(s_sel As SEL_STRING) As SEL_STRING

    Dim strTmp() As String
    Dim lngSt As Long
    Dim lngEd As Long
    
    Dim strRet As String
    Dim o_sel As SEL_STRING
    
    Dim i As Long
    
    strTmp = Split(s_sel.strString, vbCrLf)
    lngSt = GetLineNumber(s_sel.strString, s_sel.lngLineStart)
    If Mid(s_sel.strString, s_sel.lngLineEnd, 1) = vbCr Or _
       Mid(s_sel.strString, s_sel.lngLineEnd, 1) = vbLf Then
        lngEd = GetLineNumber(s_sel.strString, s_sel.lngLineEnd) - 1
    Else
        lngEd = GetLineNumber(s_sel.strString, s_sel.lngLineEnd)
    End If
    
    For i = lngSt To lngEd
        strTmp(i) = "    " & strTmp(i)
    Next i
    
    For i = 0 To UBound(strTmp)
        If i = 0 Then
            strRet = strTmp(0)
        Else
            strRet = strRet & vbCrLf & strTmp(i)
        End If
    Next i
    o_sel.lngLineStart = s_sel.lngLineStart
    o_sel.lngLineEnd = s_sel.lngLineEnd + 4 * (lngEd - lngSt + 1)
    o_sel.strString = strRet
    
    AddIndent = o_sel

End Function
'指定の開始文字位置、終了文字位置の間の行頭にあるインデント削除し、
'合わせて開始文字位置、終了文字位置を更新して返す。
Private Function DelIndent(s_sel As SEL_STRING) As SEL_STRING
    
    Dim strTmp() As String
    Dim lngSt As Long
    Dim lngEd As Long
    Dim strRet As String
    Dim o_sel As SEL_STRING
    Dim i As Long
    Dim dChars As Long
    
    strTmp = Split(s_sel.strString, vbCrLf)
    lngSt = GetLineNumber(s_sel.strString, s_sel.lngLineStart)
    If Mid(s_sel.strString, s_sel.lngLineEnd, 1) = vbCr Or _
       Mid(s_sel.strString, s_sel.lngLineEnd, 1) = vbLf Then
        lngEd = GetLineNumber(s_sel.strString, s_sel.lngLineEnd) - 1
    Else
        lngEd = GetLineNumber(s_sel.strString, s_sel.lngLineEnd)
    End If
    
    For i = lngSt To lngEd
        If Left(strTmp(i), 4) = "    " Then
            strTmp(i) = Mid(strTmp(i), 5)
            dChars = dChars + 4
        Else
            dChars = dChars + Len(strTmp(i))
            strTmp(i) = LTrim(strTmp(i))
            dChars = dChars - Len(strTmp(i))
        End If
    Next i
    
    For i = 0 To UBound(strTmp)
        If i = 0 Then
            strRet = strTmp(0)
        Else
            strRet = strRet & vbCrLf & strTmp(i)
        End If
    Next i
    o_sel.strString = strRet
    o_sel.lngLineStart = s_sel.lngLineStart
    o_sel.lngLineEnd = s_sel.lngLineEnd - dChars
    
    DelIndent = o_sel
    
End Function