frog.raindrop.jp.knowledge

Option Explicit

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
Private Declare Function BringWindowToTop Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Const FORMAT_MESSAGE_FROM_SYSTEM     As Long = &H1000&
Private Const FORMAT_MESSAGE_IGNORE_INSERTS  As Long = &H200&
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, lpBuffer As Any, ByVal nSize As Long, Arguments As Long) As Long

'******************************************************************
'プロシージャ名   :ForceSetForegroundWindow
'説明             :フォームを強制的にアクティブにする
'引数             :pfrmTarget           I   アクティブにするウインドウ
'******************************************************************
Public Sub ForceSetForegroundWindow(pfrmTarget As VB.Form)
'============= Declare ==============
Dim lngRet              As Long
Dim hWndActive          As OLE_HANDLE
Dim hThreadActive       As OLE_HANDLE

'============= Initiarize ===========
On Error GoTo ERR_HANDLER_00

'============= Main =================

    '' 現在アクティブなスレッドを取得する
    hWndActive = GetForegroundWindow()
    If (0& = hWndActive) Then
        Call DllErrRaise(Err.LastDllError, "GetForegroundWindow")
    End If
    hThreadActive = GetWindowThreadProcessId(hWndActive, ByVal 0&)
    If (0& = hThreadActive) Then
        Call DllErrRaise(Err.LastDllError, "GetWindowThreadProcessId")
        
    '' 自分自身がアクティブなら、ただ最前面にするだけ
    ElseIf App.ThreadID = hThreadActive Then
        lngRet = SetForegroundWindow(pfrmTarget.hWnd)
        If (0& = lngRet) Then
            Call DllErrRaise(Err.LastDllError, "SetForegroundWindow")
        End If
        
    '' 自分自身がアクティブでなければ、アクティブなスレッドにアタッチする
    Else
        lngRet = AttachThreadInput(App.ThreadID, hThreadActive, 1&)
        If (0& = lngRet) Then
            Call DllErrRaise(Err.LastDllError, "AttachThreadInput")
        Else
On Error GoTo ERR_HANDLER_10
            '' ウインドウをアクティブにする
            lngRet = SetForegroundWindow(pfrmTarget.hWnd)
            If (0& = lngRet) Then
                Call DllErrRaise(Err.LastDllError, "SetForegroundWindow")
            End If
            
            '' スレッドをデタッチする
            lngRet = AttachThreadInput(App.ThreadID, hThreadActive, 0&)
            If (0& = lngRet) Then
                Call DllErrRaise(Err.LastDllError, "AttachThreadInput")
            End If
On Error GoTo ERR_HANDLER_00
        End If
    End If

'============= Release ==============
RESUME_00:
    Exit Sub
'============= Error ================
ERR_HANDLER_10:
    '' スレッドをデタッチする
    Call AttachThreadInput(App.ThreadID, hThreadActive, 0&)
ERR_HANDLER_00:
    Call Err.Raise(Err.Number, "basCommonFunc.ForceSetForegroundWindow ← " & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext)

End Sub

'******************************************************************
'プロシージャ名:  :DllErrRaise
'説明:            :Err.LastDllErrorよりエラーを発生する
'引数:            :plngLastDllError   I   Err.LastDllError
'                 :pstrErrSource      I   エラーソース文字列
'******************************************************************
Public Sub DllErrRaise(ByVal plngLastDllError As Long, pstrErrSource As String)
'============= Declare ==============
Const clngMAX_BUFFER            As Long = 1024&
Dim bytBuf(clngMAX_BUFFER - 1&) As Byte 'バッファ
Dim lngRet                      As Long 'APIの戻り値
Dim strErrDescription           As String

'============= Initiarize ===========
    If plngLastDllError = 0& Then
        Exit Sub
    End If
    Erase bytBuf
    strErrDescription = ""
'============= Main =================
    
    ' エラー値に対応するメッセージを取得する
    lngRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
                            ByVal 0&, _
                            plngLastDllError, _
                            0&, _
                            bytBuf(0), _
                            clngMAX_BUFFER, _
                            ByVal 0&)
    If lngRet Then
        strErrDescription = StrConv(LeftB(bytBuf, lngRet - 2&), vbUnicode)
    End If
    
    ' エラーを発生する
    Call Err.Raise(plngLastDllError Or vbObjectError, pstrErrSource, strErrDescription)
    
End Sub