[269] | 1 | 'Classes/ActiveBasic/Windows/Windows.ab
|
---|
| 2 |
|
---|
| 3 | Namespace ActiveBasic
|
---|
| 4 | Namespace Windows
|
---|
| 5 |
|
---|
| 6 | Function GetPathFromIDList(pidl As LPITEMIDLIST) As String
|
---|
| 7 | Dim buf[ELM(MAX_PATH)] As TCHAR
|
---|
| 8 | If SHGetPathFromIDList(pidl, buf) Then
|
---|
| 9 | Return New String(buf)
|
---|
| 10 | Else
|
---|
| 11 | Return ""
|
---|
| 12 | End If
|
---|
| 13 | End Function
|
---|
| 14 |
|
---|
| 15 | Function GetFolderPath(hwnd As HWND, folder As Long) As String
|
---|
| 16 | Dim pidl As LPITEMIDLIST
|
---|
| 17 | Dim hr = SHGetSpecialFolderLocation(hwnd, folder, pidl)
|
---|
| 18 | If SUCCEEDED(hr) Then
|
---|
| 19 | GetFolderPath = GetPathFromIDList(pidl)
|
---|
| 20 | CoTaskMemFree(pidl)
|
---|
| 21 | Else
|
---|
| 22 | GetFolderPath = ""
|
---|
| 23 | End If
|
---|
| 24 | End Function
|
---|
| 25 |
|
---|
| 26 | Function GetFolderPath(folder As Long) As String
|
---|
| 27 | Return GetFolderPath(0, folder)
|
---|
| 28 | End Function
|
---|
[303] | 29 | /*
|
---|
| 30 | Function MessageBox(hw As HWND, s As PCSTR, t As PCSTR, b As DWord) As DWord
|
---|
| 31 | Return MessageBoxA(hw, s, t, b)
|
---|
| 32 | End Function
|
---|
[269] | 33 |
|
---|
[303] | 34 | Function MessageBox(hw As HWND, s As PCWSTR, t As PCWSTR, b As DWord) As DWord
|
---|
| 35 | Return MessageBoxW(hw, s, t, b)
|
---|
| 36 | End Function
|
---|
| 37 | */
|
---|
| 38 |
|
---|
| 39 | Namespace Detail
|
---|
| 40 | Function _System_MessageBox(hw As HWND, s As PCSTR, t As PCSTR, b As DWord) As DWord
|
---|
| 41 | Return MessageBoxA(hw, s, t, b)
|
---|
| 42 | End Function
|
---|
| 43 |
|
---|
| 44 | Function _System_MessageBox(hw As HWND, s As PCWSTR, t As PCWSTR, b As DWord) As DWord
|
---|
| 45 | Return MessageBoxW(hw, s, t, b)
|
---|
| 46 | End Function
|
---|
| 47 | End Namespace
|
---|
| 48 |
|
---|
[603] | 49 | Function HResultToString(hr As HRESULT) As String
|
---|
| 50 | Dim pszMsg As PCSTR
|
---|
| 51 | FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER Or FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS,
|
---|
| 52 | 0, hr, LANG_USER_DEFAULT, VarPtr(pszMsg) As PTSTR, 0, 0)
|
---|
| 53 | If pszMsg <> 0 Then
|
---|
| 54 | HResultToString = New String(pszMsg)
|
---|
| 55 | LocalFree(pszMsg)
|
---|
| 56 | End If
|
---|
| 57 | End Function
|
---|
[559] | 58 |
|
---|
| 59 | /*!
|
---|
| 60 | @brief Windows/COMのエラーを伝える例外クラス
|
---|
| 61 | @date 2008/07/13
|
---|
| 62 | @auther Egtra
|
---|
| 63 | */
|
---|
| 64 | Class WindowsException
|
---|
| 65 | Inherits System.Exception
|
---|
| 66 | Public
|
---|
| 67 | /*!
|
---|
| 68 | @biref コンストラクタ
|
---|
| 69 | */
|
---|
| 70 | Sub WindowsException()
|
---|
| 71 | Exception()
|
---|
| 72 | HResult = E_FAIL
|
---|
| 73 | End Sub
|
---|
| 74 | /*!
|
---|
| 75 | @biref コンストラクタ
|
---|
| 76 | @param[in] hr エラー値
|
---|
| 77 | */
|
---|
| 78 | Sub WindowsException(hr As HRESULT)
|
---|
[603] | 79 | Exception(HResultToString(hr))
|
---|
[559] | 80 | HResult = hr
|
---|
| 81 | End Sub
|
---|
| 82 | /*!
|
---|
| 83 | @biref コンストラクタ
|
---|
| 84 | @param[in] message エラーメッセージ
|
---|
| 85 | */
|
---|
| 86 | Sub WindowsException(message As String)
|
---|
| 87 | Exception(message)
|
---|
| 88 | HResult = E_FAIL
|
---|
| 89 | End Sub
|
---|
| 90 | /*!
|
---|
| 91 | @biref コンストラクタ
|
---|
| 92 | @param[in] hr エラー値
|
---|
| 93 | @param[in] message エラーメッセージ
|
---|
| 94 | */
|
---|
| 95 | Sub WindowsException(hr As HRESULT, message As String)
|
---|
| 96 | Exception(message)
|
---|
| 97 | HResult = hr
|
---|
| 98 | End Sub
|
---|
| 99 | /*!
|
---|
| 100 | @biref コンストラクタ
|
---|
| 101 | @param[in] message エラーメッセージ
|
---|
| 102 | @param[in] innerException 内部例外
|
---|
| 103 | */
|
---|
| 104 | Sub WindowsException(message As String, innerException As Exception)
|
---|
| 105 | Exception(message, innerException)
|
---|
| 106 | HResult = E_FAIL
|
---|
| 107 | End Sub
|
---|
| 108 | Private
|
---|
| 109 | End Class
|
---|
| 110 |
|
---|
| 111 | /*!
|
---|
[599] | 112 | @brief Windowsのエラー値を基に例外を投げる
|
---|
[559] | 113 | @param[in] dwErrorCode Win32エラーコード
|
---|
[615] | 114 | @param[in] msg 補足説明
|
---|
[559] | 115 | @throw WindowsException 常に投げられる。
|
---|
[599] | 116 | @date 2008/07/13
|
---|
| 117 | @auther Egtra
|
---|
[559] | 118 | */
|
---|
[615] | 119 | Sub ThrowWithErrorCode(dwErrorCode As DWord, msg = Nothing As String)
|
---|
| 120 | Throw New WindowsException(HRESULT_FROM_WIN32(dwErrorCode), msg)
|
---|
[559] | 121 | End Sub
|
---|
| 122 | /*!
|
---|
[615] | 123 | @brief WindowsExceptionを投げるラッパ。直前に呼び出したAPI関数などが失敗したときに用いる。
|
---|
| 124 | @param[in] msg 補足説明
|
---|
| 125 | @throw WindowsException 常に投げられる。
|
---|
| 126 | @date 2008/08/20
|
---|
| 127 | @auther Egtra
|
---|
| 128 | WindowsExceptionを構築する際、GetLastError()の値を渡す。
|
---|
| 129 | この関数では、直前のAPI関数が成功したかどうかを調べられないことに注意。
|
---|
| 130 | */
|
---|
| 131 | Sub ThrowWithLastError(msg = Nothing As String)
|
---|
| 132 | ThrowWithErrorCode(GetLastError(), msg)
|
---|
| 133 | End Sub
|
---|
| 134 | /*!
|
---|
| 135 | @brief (主にuser32の全部、gdi32の一部が対象)WindowsExceptionを投げるラッパ。直前に呼び出したAPI関数などが失敗したときに用いる。
|
---|
| 136 | @param[in] msg 補足説明
|
---|
| 137 | @throw WindowsException 常に投げられる。
|
---|
[599] | 138 | @date 2008/08/26
|
---|
| 139 | @auther Egtra
|
---|
[615] | 140 | user32やgdi32の一部など、9xではGetLastErrorでエラーメッセージが取得できないものがある。
|
---|
| 141 | そのため、9xでは一律にmsgのみでWindowsExceptionを構築して投げるようにしている。
|
---|
| 142 |
|
---|
| 143 | ところで、CEではNT同様GetLastErrorが使用できるため、
|
---|
| 144 | CEへの移植を仮定すると、関数名にNTと付けるのがそぐわないと感じる。代案募集中。
|
---|
[599] | 145 | */
|
---|
[615] | 146 | Sub ThrowWithLastErrorNT(msg As String)
|
---|
| 147 | If Not Version.Is9x() Then
|
---|
| 148 | ThrowWithErrorCode(GetLastError(), msg)
|
---|
| 149 | Else
|
---|
| 150 | Throw New WindowsException(msg)
|
---|
| 151 | End If
|
---|
[599] | 152 | End Sub
|
---|
| 153 | /*!
|
---|
[559] | 154 | @brief HRESULT値を基に例外を投げる。
|
---|
[615] | 155 | @param[in] hr HRESULT値
|
---|
| 156 | @param[in] msg 補足説明
|
---|
[559] | 157 | @throw WindowsException FAILED(hr)が真の場合
|
---|
[615] | 158 | @date 2008/07/13
|
---|
| 159 | @auther Egtra
|
---|
[559] | 160 | hrが成功値 (FAILED(hr) = False) の場合、この関数は何も行わない。
|
---|
| 161 | */
|
---|
[615] | 162 | Sub ThrowIfFailed(hr As HRESULT, msg = Nothing As String)
|
---|
[559] | 163 | If FAILED(hr) Then
|
---|
[615] | 164 | Throw New WindowsException(hr, msg)
|
---|
[559] | 165 | End If
|
---|
| 166 | End Sub
|
---|
| 167 |
|
---|
[269] | 168 | End Namespace 'Widnows
|
---|
| 169 | End Namespace 'ActiveBasic
|
---|