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)
|
---|