source: trunk/ab5.0/ablib/TestCase/UI_Sample/ParallelBuild.ab

Last change on this file was 696, checked in by イグトランス (egtra), 11 years ago

サンプルプログラムParallelBuid追加

File size: 10.5 KB
Line 
1/*
2ParallelBuild.ab
3ビルドバッチ8つを同時実行、1つのウィンドウに8つエディットボックスを並べて、そこへ結果を出力します。
4
5ほか、特徴的な点
6Windows.UIでのコントロール(エディットボックス)のサブクラス化
7DWM下におけるGDIを用いた半透明描画 (BufferedPaint系関数の使用)
8DWM下におけるタイトルバー上のアイコン・文字列の非表示
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
17Imports ActiveBasic.Windows
18Imports ActiveBasic.Windows.UI
19Imports System.Collections.Generic
20Imports System.IO
21Imports System.Threading
22
23TypeDef HPAINTBUFFER = HANDLE
24
25Const Enum BP_BUFFERFORMAT
26    BPBF_COMPATIBLEBITMAP = 0
27    BPBF_DIB = 1
28    BPBF_TOPDOWNDIB = 2
29    BPBF_TOPDOWNMONODIB = 3
30End Enum
31
32Const BPBF_COMPOSITED = BPBF_TOPDOWNDIB
33
34Type BP_PAINTPARAMS
35    cbSize As DWord
36    dwFlags As DWord
37    prcExclude As *RECT
38    pBlendFunction As VoidPtr '*BLENDFUNCTION
39End Type
40
41Type MARGINS
42    cxLeftWidth As Long
43    cxRightWidth As Long
44    cyTopHeight As Long
45    cyBottomHeight As Long
46End Type
47
48Const Enum WINDOWTHEMEATTRIBUTETYPE
49    WTA_NONCLIENT = 1
50End Enum
51
52Type WTA_OPTIONS
53    dwFlags As DWord
54    dwMask As DWord
55End Type
56
57Const WTNCA_NODRAWCAPTION = 1
58Const WTNCA_NODRAWICON = 2
59
60'API宣言ここまで
61
62TypeDef PDwmExtendFrameIntoClientArea = *Function(hwnd As HWND, ByRef MarInset As MARGINS) As HRESULT
63TypeDef PSetWindowThemeAttribute = *Function(hwnd As HWND, eAttribute As WINDOWTHEMEATTRIBUTETYPE, ByRef pvAttribute As Any, cbAttribute As DWord) As HRESULT
64TypeDef PDwmIsCompositionEnabled = *Function(ByRef fEnabled As BOOL) As HRESULT
65TypeDef PBeginBufferedPaint = *Function(hdcTarget As HDC, ByRef rcTarget As RECT, dwFormat As BP_BUFFERFORMAT, pPaintParams As *BP_PAINTPARAMS, ByRef hdc As HDC) As HPAINTBUFFER
66TypeDef PBufferedPaintSetAlpha = *Function(hBufferedPaint As HPAINTBUFFER, ByRef rc As RECT, alpha As DWord) As HRESULT
67TypeDef PBufferedPaintInit = *Function() As HRESULT
68TypeDef PGetBufferedPaintBits = *Function(hBufferedPaint As HPAINTBUFFER, ByRef pbBuffer As *RGBQUAD, ByRef cxRow As Long) As HRESULT
69TypeDef PEndBufferedPaint = *Function(hBufferedPaint As HPAINTBUFFER, fUpdateTarget As BOOL) As HRESULT
70
71Const BorderWidth = 6
72
73'コメントアウトを外すと、エディットボックス部分が不透明になる。
74'#define OPAQUE_EDITBOX
75
76Class MyForm
77    Inherits Form
78Public
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
134Private
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
305End Class
306
307Control.Initialize(GetModuleHandle(0))
308
309Dim f = New MyForm
310Application.Run(f)
Note: See TracBrowser for help on using the repository browser.