[696] | 1 | /*
|
---|
| 2 | ParallelBuild.ab
|
---|
| 3 | ビルドバッチ8つを同時実行、1つのウィンドウに8つエディットボックスを並べて、そこへ結果を出力します。
|
---|
| 4 |
|
---|
| 5 | ほか、特徴的な点
|
---|
| 6 | Windows.UIでのコントロール(エディットボックス)のサブクラス化
|
---|
| 7 | DWM下におけるGDIを用いた半透明描画 (BufferedPaint系関数の使用)
|
---|
| 8 | DWM下におけるタイトルバー上のアイコン・文字列の非表示
|
---|
| 9 | */
|
---|
| 10 |
|
---|
| 11 | #require <Classes/ActiveBasic/Windows/UI/Form.ab>
|
---|
| 12 | #require <Classes/ActiveBasic/Windows/UI/EditBox.ab>
|
---|
| 13 | #require <Classes/ActiveBasic/Windows/UI/Application.ab>
|
---|
| 14 |
|
---|
| 15 | #resource "UI_Sample.rc"
|
---|
| 16 |
|
---|
| 17 | Imports ActiveBasic.Windows
|
---|
| 18 | Imports ActiveBasic.Windows.UI
|
---|
| 19 | Imports System.Collections.Generic
|
---|
| 20 | Imports System.IO
|
---|
| 21 | Imports System.Threading
|
---|
| 22 |
|
---|
| 23 | TypeDef HPAINTBUFFER = HANDLE
|
---|
| 24 |
|
---|
| 25 | Const Enum BP_BUFFERFORMAT
|
---|
| 26 | BPBF_COMPATIBLEBITMAP = 0
|
---|
| 27 | BPBF_DIB = 1
|
---|
| 28 | BPBF_TOPDOWNDIB = 2
|
---|
| 29 | BPBF_TOPDOWNMONODIB = 3
|
---|
| 30 | End Enum
|
---|
| 31 |
|
---|
| 32 | Const BPBF_COMPOSITED = BPBF_TOPDOWNDIB
|
---|
| 33 |
|
---|
| 34 | Type BP_PAINTPARAMS
|
---|
| 35 | cbSize As DWord
|
---|
| 36 | dwFlags As DWord
|
---|
| 37 | prcExclude As *RECT
|
---|
| 38 | pBlendFunction As VoidPtr '*BLENDFUNCTION
|
---|
| 39 | End Type
|
---|
| 40 |
|
---|
| 41 | Type MARGINS
|
---|
| 42 | cxLeftWidth As Long
|
---|
| 43 | cxRightWidth As Long
|
---|
| 44 | cyTopHeight As Long
|
---|
| 45 | cyBottomHeight As Long
|
---|
| 46 | End Type
|
---|
| 47 |
|
---|
| 48 | Const Enum WINDOWTHEMEATTRIBUTETYPE
|
---|
| 49 | WTA_NONCLIENT = 1
|
---|
| 50 | End Enum
|
---|
| 51 |
|
---|
| 52 | Type WTA_OPTIONS
|
---|
| 53 | dwFlags As DWord
|
---|
| 54 | dwMask As DWord
|
---|
| 55 | End Type
|
---|
| 56 |
|
---|
| 57 | Const WTNCA_NODRAWCAPTION = 1
|
---|
| 58 | Const WTNCA_NODRAWICON = 2
|
---|
| 59 |
|
---|
| 60 | 'API宣言ここまで
|
---|
| 61 |
|
---|
| 62 | TypeDef PDwmExtendFrameIntoClientArea = *Function(hwnd As HWND, ByRef MarInset As MARGINS) As HRESULT
|
---|
| 63 | TypeDef PSetWindowThemeAttribute = *Function(hwnd As HWND, eAttribute As WINDOWTHEMEATTRIBUTETYPE, ByRef pvAttribute As Any, cbAttribute As DWord) As HRESULT
|
---|
| 64 | TypeDef PDwmIsCompositionEnabled = *Function(ByRef fEnabled As BOOL) As HRESULT
|
---|
| 65 | TypeDef PBeginBufferedPaint = *Function(hdcTarget As HDC, ByRef rcTarget As RECT, dwFormat As BP_BUFFERFORMAT, pPaintParams As *BP_PAINTPARAMS, ByRef hdc As HDC) As HPAINTBUFFER
|
---|
| 66 | TypeDef PBufferedPaintSetAlpha = *Function(hBufferedPaint As HPAINTBUFFER, ByRef rc As RECT, alpha As DWord) As HRESULT
|
---|
| 67 | TypeDef PBufferedPaintInit = *Function() As HRESULT
|
---|
| 68 | TypeDef PGetBufferedPaintBits = *Function(hBufferedPaint As HPAINTBUFFER, ByRef pbBuffer As *RGBQUAD, ByRef cxRow As Long) As HRESULT
|
---|
| 69 | TypeDef PEndBufferedPaint = *Function(hBufferedPaint As HPAINTBUFFER, fUpdateTarget As BOOL) As HRESULT
|
---|
| 70 |
|
---|
| 71 | Const BorderWidth = 6
|
---|
| 72 |
|
---|
| 73 | 'コメントアウトを外すと、エディットボックス部分が不透明になる。
|
---|
| 74 | '#define OPAQUE_EDITBOX
|
---|
| 75 |
|
---|
| 76 | Class MyForm
|
---|
| 77 | Inherits Form
|
---|
| 78 | Public
|
---|
| 79 | Sub MyForm()
|
---|
| 80 | AddResize(AddressOf(onResize))
|
---|
| 81 | AddPaintBackground(AddressOf(onPaintBackground))
|
---|
| 82 | AddMessageEvent(WM_CTLCOLORSTATIC, AddressOf(onCtlColorEditBox))
|
---|
| 83 | AddMessageEvent(WM_DWMCOMPOSITIONCHANGED, AddressOf(onCompositionChanged))
|
---|
| 84 | edit = New List<EditBox>
|
---|
| 85 |
|
---|
| 86 | CreateForm()
|
---|
| 87 |
|
---|
| 88 | Text = "ParallelBuild"
|
---|
| 89 |
|
---|
| 90 | Dim hdc = GetDC()
|
---|
| 91 | hfont = CreateFont(-MulDiv(9, GetDeviceCaps(hdc, LOGPIXELSY), 72), 0, 0, 0,
|
---|
| 92 | FW_DONTCARE, FALSE, FALSE, FALSE, SHIFTJIS_CHARSET, OUT_DEFAULT_PRECIS,
|
---|
| 93 | CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, FIXED_PITCH, "MS ゴシック")
|
---|
| 94 | ReleaseDC(hdc)
|
---|
| 95 | Dim wpFont = hfont As WPARAM
|
---|
| 96 |
|
---|
| 97 | Dim i As Long
|
---|
| 98 | For i = 0 To 7
|
---|
| 99 | Dim e = New EditBox
|
---|
| 100 | e.AddMessageEvent(WM_PAINT, AddressOf(onPaintEditBox))
|
---|
| 101 | e.Create(This, ES_MULTILINE Or ES_AUTOHSCROLL Or ES_AUTOVSCROLL Or ES_READONLY Or WS_HSCROLL Or WS_VSCROLL Or WS_VISIBLE, WS_EX_CLIENTEDGE)
|
---|
| 102 | e.SendMessage(WM_SETFONT, wpFont, 0)
|
---|
| 103 | e.BeginSubclass()
|
---|
| 104 | edit.Add(e)
|
---|
| 105 | Next
|
---|
| 106 |
|
---|
| 107 | thread = New Thread(AddressOf(ControlProcess))
|
---|
| 108 | thread.Start()
|
---|
| 109 |
|
---|
| 110 | hmodUxTheme = LoadLibrary("uxtheme")
|
---|
| 111 | hmodDwmApi = LoadLibrary("dwmapi")
|
---|
| 112 |
|
---|
| 113 | If hmodUxTheme <> 0 Then
|
---|
| 114 | pSetWindowThemeAttribute = GetProcAddress(hmodUxTheme, ToMBStr("SetWindowThemeAttribute")) As PSetWindowThemeAttribute
|
---|
| 115 | pBufferedPaintUnInit = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintUnInit")) As PBufferedPaintInit
|
---|
| 116 | pBeginBufferedPaint = GetProcAddress(hmodUxTheme, ToMBStr("BeginBufferedPaint")) As PBufferedPaintInit
|
---|
| 117 | pBufferedPaintSetAlpha = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintSetAlpha")) As PBufferedPaintSetAlpha
|
---|
| 118 | pEndBufferedPaint = GetProcAddress(hmodUxTheme, ToMBStr("EndBufferedPaint")) As PEndBufferedPaint
|
---|
| 119 | pGetBufferedPaintBits = GetProcAddress(hmodUxTheme, ToMBStr("GetBufferedPaintBits")) As PGetBufferedPaintBits
|
---|
| 120 | Dim pBufferedPaintInit = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintInit")) As PBufferedPaintInit
|
---|
| 121 | If pBufferedPaintInit <> 0 Then
|
---|
| 122 | Dim hr = pBufferedPaintInit()
|
---|
| 123 | If FAILED(hr) Then Debug
|
---|
| 124 | End If
|
---|
| 125 | End If
|
---|
| 126 |
|
---|
| 127 | If hmodDwmApi <> 0 Then
|
---|
| 128 | pDwmIsCompositionEnabled = GetProcAddress(hmodDwmApi, ToMBStr("DwmIsCompositionEnabled")) As PDwmIsCompositionEnabled
|
---|
| 129 | pDwmExtendFrameIntoClientArea = GetProcAddress(hmodDwmApi, ToMBStr("DwmExtendFrameIntoClientArea")) As PDwmExtendFrameIntoClientArea
|
---|
| 130 | SendMessage(WM_DWMCOMPOSITIONCHANGED)
|
---|
| 131 | End If
|
---|
| 132 | End Sub
|
---|
| 133 |
|
---|
| 134 | Private
|
---|
| 135 | hmodUxTheme As HMODULE
|
---|
| 136 | hmodDwmApi As HMODULE
|
---|
| 137 | pDwmIsCompositionEnabled As PDwmIsCompositionEnabled
|
---|
| 138 | pDwmExtendFrameIntoClientArea As PDwmExtendFrameIntoClientArea
|
---|
| 139 | pSetWindowThemeAttribute As PSetWindowThemeAttribute
|
---|
| 140 | pBufferedPaintUnInit As PBufferedPaintInit
|
---|
| 141 | pBeginBufferedPaint As PBeginBufferedPaint
|
---|
| 142 | pBufferedPaintSetAlpha As PBufferedPaintSetAlpha
|
---|
| 143 | pEndBufferedPaint As PEndBufferedPaint
|
---|
| 144 | pGetBufferedPaintBits As PGetBufferedPaintBits
|
---|
| 145 |
|
---|
| 146 | Sub onCompositionChanged(sender As Object, e As MessageArgs)
|
---|
| 147 | e.Handled = True
|
---|
| 148 | useDwm = False
|
---|
| 149 | If pDwmIsCompositionEnabled <> 0 Then
|
---|
| 150 | Dim enabled As BOOL
|
---|
| 151 | If SUCCEEDED(pDwmIsCompositionEnabled(enabled)) And enabled Then
|
---|
| 152 | useDwm = True
|
---|
| 153 | 'クライアント領域全体にガラス効果をかける。
|
---|
| 154 | Dim m = [-1, 0, 0, 0] As MARGINS
|
---|
| 155 | pDwmExtendFrameIntoClientArea(This, m)
|
---|
| 156 | 'タイトルバーのアイコン・文字列を消す。
|
---|
| 157 | Dim wo As WTA_OPTIONS
|
---|
| 158 | wo.dwFlags = WTNCA_NODRAWCAPTION Or WTNCA_NODRAWICON
|
---|
| 159 | wo.dwMask = WTNCA_NODRAWCAPTION Or WTNCA_NODRAWICON
|
---|
| 160 | pSetWindowThemeAttribute(hwnd, WTA_NONCLIENT, wo, Len(wo))
|
---|
| 161 | End If
|
---|
| 162 | End If
|
---|
| 163 | Invalidate()
|
---|
| 164 | End Sub
|
---|
| 165 |
|
---|
| 166 | Sub onDestroy(sender As Object, e As Args)
|
---|
| 167 | DeleteObject(hfont)
|
---|
| 168 | pBufferedPaintUnInit()
|
---|
| 169 | If hmodUxTheme <> 0 Then
|
---|
| 170 | FreeLibrary(hmodUxTheme)
|
---|
| 171 | End If
|
---|
| 172 | If hmodDwmApi <> 0 Then
|
---|
| 173 | FreeLibrary(hmodDwmApi)
|
---|
| 174 | End If
|
---|
| 175 | End Sub
|
---|
| 176 |
|
---|
| 177 | Sub onResize(sender As Object, e As ResizeArgs)
|
---|
| 178 | Dim i As Long
|
---|
| 179 | For i = 0 To 7
|
---|
| 180 | Dim t = edit[i]
|
---|
| 181 | t.Move((i Mod 4) * (e.X \ 4) + BorderWidth, (i \ 4) * (e.Y \ 2) + BorderWidth, e.X \ 4 - BorderWidth * 2, e.Y \ 2 - BorderWidth * 2)
|
---|
| 182 | Next
|
---|
| 183 | End Sub
|
---|
| 184 |
|
---|
| 185 | Sub onPaintBackground(sender As Object, e As PaintBackgroundArgs)
|
---|
| 186 | If useDwm Then
|
---|
| 187 | Dim hdc = e.Handle
|
---|
| 188 | SetBkColor(hdc, 0)
|
---|
| 189 | ExtTextOut(hdc, 0, 0, ETO_OPAQUE, ClientRect, "", 0, 0)
|
---|
| 190 | End If
|
---|
| 191 | End Sub
|
---|
| 192 |
|
---|
| 193 | Static Const backgroundColor = RGB(255, 255, 255)
|
---|
| 194 | Static Const textColor = RGB(0, 0, 0)
|
---|
| 195 |
|
---|
| 196 | Sub onCtlColorEditBox(sender As Object, e As MessageArgs)
|
---|
| 197 | Dim hdc = e.WParam As HDC
|
---|
| 198 | SetTextColor(hdc, textColor)
|
---|
| 199 | SetBkColor(hdc, backgroundColor)
|
---|
| 200 | e.LResult = GetStockObject(NULL_BRUSH) As LRESULT
|
---|
| 201 | e.Handled = True
|
---|
| 202 | End Sub
|
---|
| 203 |
|
---|
| 204 | Sub onPaintEditBox(sender As Object, e As MessageArgs)
|
---|
| 205 | Dim alpha = &hcc As DWord
|
---|
| 206 | Dim i As Long, j As Long
|
---|
| 207 | If useDwm Then
|
---|
| 208 | Dim edit = sender As EditBox
|
---|
| 209 | Dim ps As PAINTSTRUCT
|
---|
| 210 | BeginPaint(e.HWnd, ps)
|
---|
| 211 | Dim hdcMem As HDC
|
---|
| 212 | Dim hpb = pBeginBufferedPaint(ps.hdc, ps.rcPaint, BPBF_TOPDOWNDIB, 0, hdcMem)
|
---|
| 213 | If hpb <> 0 Then
|
---|
| 214 | FillRect(hdcMem, ps.rcPaint, GetStockObject(WHITE_BRUSH) As HBRUSH)
|
---|
| 215 | edit.DefWndProc(WM_PRINTCLIENT, hdcMem As WPARAM, PRF_CLIENT)
|
---|
| 216 | #ifdef OPAQUE_EDITBOX
|
---|
| 217 | pBufferedPaintSetAlpha(hpb, ps.rcPaint, 255)
|
---|
| 218 | #else
|
---|
| 219 | Dim cxRow As Long
|
---|
| 220 | Dim p As *RGBQUAD
|
---|
| 221 | pGetBufferedPaintBits(hpb, p, cxRow)
|
---|
| 222 | Dim pdw = p As *DWord
|
---|
| 223 | For i = 0 To ELM(ps.rcPaint.bottom - ps.rcPaint.top)
|
---|
| 224 | For j = 0 To ELM(ps.rcPaint.right - ps.rcPaint.left)
|
---|
| 225 | Dim rgb = pdw[i * cxRow + j] And &h00ffffff
|
---|
| 226 | If rgb = textColor Then 'ClearType下で試すと、rgb <> backgroundColorよりこのほうが綺麗。
|
---|
| 227 | pdw[i * cxRow + j] Or= &hff000000
|
---|
| 228 | Else
|
---|
| 229 | With p[i * cxRow + j]
|
---|
| 230 | .rgbReserved = alpha As Byte
|
---|
| 231 | .rgbRed = ((.rgbRed * alpha) >> 8) As Byte
|
---|
| 232 | .rgbGreen = ((.rgbGreen * alpha) >> 8) As Byte
|
---|
| 233 | .rgbBlue = ((.rgbBlue * alpha) >> 8) As Byte
|
---|
| 234 | End With
|
---|
| 235 | End If
|
---|
| 236 | Next
|
---|
| 237 | Next
|
---|
| 238 | #endif
|
---|
| 239 | pEndBufferedPaint(hpb, TRUE)
|
---|
| 240 | End If
|
---|
| 241 | EndPaint(e.HWnd, ps)
|
---|
| 242 | e.Handled = True
|
---|
| 243 | Else
|
---|
| 244 | e.Handled = False
|
---|
| 245 | End If
|
---|
| 246 | End Sub
|
---|
| 247 |
|
---|
| 248 | Sub ControlProcess()
|
---|
| 249 | Dim buildCmd[7] As PCTSTR
|
---|
| 250 | buildCmd[0] = "build_basic_static_library(32bit - debug - unicode).bat"
|
---|
| 251 | buildCmd[1] = "build_basic_static_library(32bit - debug).bat"
|
---|
| 252 | buildCmd[2] = "build_basic_static_library(32bit - release - unicode).bat"
|
---|
| 253 | buildCmd[3] = "build_basic_static_library(32bit - release).bat"
|
---|
| 254 | buildCmd[4] = "build_basic_static_library(64bit - debug - unicode).bat"
|
---|
| 255 | buildCmd[5] = "build_basic_static_library(64bit - debug).bat"
|
---|
| 256 | buildCmd[6] = "build_basic_static_library(64bit - release - unicode).bat"
|
---|
| 257 | buildCmd[7] = "build_basic_static_library(64bit - release).bat"
|
---|
| 258 | Dim pathBase = "P:\PROGRAMS\ablib\ab5.0\ablib\build_batch\"
|
---|
| 259 | Dim hProcess[7] As HANDLE
|
---|
| 260 | Dim hPipe[7] As HANDLE
|
---|
| 261 | Dim i As Long
|
---|
| 262 | For i = 0 To 7
|
---|
| 263 | CreateBuildProcess(hProcess[i], hPipe[i], pathBase, buildCmd[i])
|
---|
| 264 | Next
|
---|
| 265 | Dim buf[4095] As CHAR
|
---|
| 266 | For i = 0 To 7
|
---|
| 267 | WaitForSingleObject(hProcess[i], INFINITE)
|
---|
| 268 | Dim readSize As DWord
|
---|
| 269 | ReadFile(hPipe[i], buf, Len(buf), VarPtr(readSize), ByVal 0)
|
---|
| 270 | Dim s = New String(buf, readSize As Long)
|
---|
| 271 | edit[i].SendMessage(WM_SETTEXT, 0, ToTCStr(s) As LPARAM)
|
---|
| 272 | CloseHandle(hProcess[i])
|
---|
| 273 | CloseHandle(hPipe[i])
|
---|
| 274 | Next
|
---|
| 275 | End Sub
|
---|
| 276 |
|
---|
| 277 | Sub CreateBuildProcess(ByRef hProcess As HANDLE, ByRef hPipeOutput As HANDLE, cmdPath As String, cmdLine As PCSTR)
|
---|
| 278 | Dim hPipeRead As HANDLE, hPipeWrite As HANDLE
|
---|
| 279 | Dim sa As SECURITY_ATTRIBUTES
|
---|
| 280 | sa.nLength = Len(sa)
|
---|
| 281 | sa.lpSecurityDescriptor = 0
|
---|
| 282 | sa.bInheritHandle = TRUE
|
---|
| 283 | If CreatePipe(hPipeRead, hPipeWrite, VarPtr(sa), 0) = FALSE Then
|
---|
| 284 | ThrowWithLastError()
|
---|
| 285 | End If
|
---|
| 286 | Dim si As STARTUPINFO
|
---|
| 287 | Dim pi As PROCESS_INFORMATION
|
---|
| 288 | si.cb = Len(si)
|
---|
| 289 | si.dwFlags = STARTF_USESTDHANDLES
|
---|
| 290 | si.hStdInput = GetStdHandle(STD_INPUT_HANDLE)
|
---|
| 291 | si.hStdOutput = hPipeWrite
|
---|
| 292 | si.hStdError = hPipeWrite
|
---|
| 293 | If CreateProcess(0, ToTCStr(Ex"\q" & cmdPath & cmdLine & Ex"\q"), ByVal 0, ByVal 0, TRUE, CREATE_NO_WINDOW, 0, ToTCStr(cmdPath), si, pi) = FALSE Then
|
---|
| 294 | ThrowWithLastError()
|
---|
| 295 | End If
|
---|
| 296 | CloseHandle(pi.hThread)
|
---|
| 297 | hPipeOutput = hPipeRead
|
---|
| 298 | hProcess = pi.hProcess
|
---|
| 299 | End Sub
|
---|
| 300 |
|
---|
| 301 | edit As List<EditBox>
|
---|
| 302 | thread As Thread
|
---|
| 303 | hfont As HFONT
|
---|
| 304 | useDwm As Boolean
|
---|
| 305 | End Class
|
---|
| 306 |
|
---|
| 307 | Control.Initialize(GetModuleHandle(0))
|
---|
| 308 |
|
---|
| 309 | Dim f = New MyForm
|
---|
| 310 | Application.Run(f)
|
---|