source: trunk/ab5.0/ablib/src/Classes/ActiveBasic/Windows/Windows.ab@ 603

'Classes/ActiveBasic/Windows/Windows.ab

Namespace ActiveBasic
Namespace Windows

Function GetPathFromIDList(pidl As LPITEMIDLIST) As String
    Dim buf[ELM(MAX_PATH)] As TCHAR
    If SHGetPathFromIDList(pidl, buf) Then
        Return New String(buf)
    Else
        Return ""
    End If
End Function

Function GetFolderPath(hwnd As HWND, folder As Long) As String
    Dim pidl As LPITEMIDLIST
    Dim hr = SHGetSpecialFolderLocation(hwnd, folder, pidl)
    If SUCCEEDED(hr) Then
        GetFolderPath = GetPathFromIDList(pidl)
        CoTaskMemFree(pidl)
    Else
        GetFolderPath = ""
    End If
End Function

Function GetFolderPath(folder As Long) As String
    Return GetFolderPath(0, folder)
End Function
/*
Function MessageBox(hw As HWND, s As PCSTR, t As PCSTR, b As DWord) As DWord
    Return MessageBoxA(hw, s, t, b)
End Function

Function MessageBox(hw As HWND, s As PCWSTR, t As PCWSTR, b As DWord) As DWord
    Return MessageBoxW(hw, s, t, b)
End Function
*/

Namespace Detail
Function _System_MessageBox(hw As HWND, s As PCSTR, t As PCSTR, b As DWord) As DWord
    Return MessageBoxA(hw, s, t, b)
End Function

Function _System_MessageBox(hw As HWND, s As PCWSTR, t As PCWSTR, b As DWord) As DWord
    Return MessageBoxW(hw, s, t, b)
End Function
End Namespace

Function HResultToString(hr As HRESULT) As String
    Dim pszMsg As PCSTR
    FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER Or FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS,
        0, hr, LANG_USER_DEFAULT, VarPtr(pszMsg) As PTSTR, 0, 0)
    If pszMsg <> 0 Then
        HResultToString = New String(pszMsg)
        LocalFree(pszMsg)
    End If
End Function

/*!
@brief  Windows/COMのエラーを伝える例外クラス
@date   2008/07/13
@auther Egtra
*/
Class WindowsException
    Inherits System.Exception
Public
    /*!
    @biref  コンストラクタ
    */
    Sub WindowsException()
        Exception()
        HResult = E_FAIL
    End Sub
    /*!
    @biref  コンストラクタ
    @param[in] hr   エラー値
    */
    Sub WindowsException(hr As HRESULT)
        Exception(HResultToString(hr))
        HResult = hr
    End Sub
    /*!
    @biref  コンストラクタ
    @param[in] message  エラーメッセージ
    */
    Sub WindowsException(message As String)
        Exception(message)
        HResult = E_FAIL
    End Sub
    /*!
    @biref  コンストラクタ
    @param[in] hr   エラー値
    @param[in] message  エラーメッセージ
    */
    Sub WindowsException(hr As HRESULT, message As String)
        Exception(message)
        HResult = hr
    End Sub
    /*!
    @biref  コンストラクタ
    @param[in] message  エラーメッセージ
    @param[in] innerException   内部例外
    */
    Sub WindowsException(message As String, innerException As Exception)
        Exception(message, innerException)
        HResult = E_FAIL
    End Sub
Private
End Class

/*!
@brief  Windowsのエラー値を基に例外を投げる
@param[in] dwErrorCode  Win32エラーコード
@throw WindowsException 常に投げられる。
@date 2008/07/13
@auther Egtra
*/
Sub ThrowWithErrorCode(dwErrorCode As DWord)
    Throw New WindowsException(HRESULT_FROM_WIN32(dwErrorCode))
End Sub

/*!
@brief 内部でGetLastErrorを呼んで、その値を基に例外を投げる。
@throw WindowsException 常に投げられる。
@date 2008/08/26
@auther Egtra
*/
Sub ThrowWithLastError()
    ThrowWithErrorCode(GetLastError())
End Sub
/*!
@brief  HRESULT値を基に例外を投げる。
@date   2008/07/13
@param[in] hr   HRESULT値
@throw WindowsException FAILED(hr)が真の場合
@auther Egtra
hrが成功値 (FAILED(hr) = False) の場合、この関数は何も行わない。
*/
Sub ThrowIfFailed(hr As HRESULT)
    If FAILED(hr) Then
        Throw New WindowsException(hr)
    End If
End Sub

End Namespace 'Widnows
End Namespace 'ActiveBasic