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

/*
ParallelBuild.ab
ビルドバッチ8つを同時実行、1つのウィンドウに8つエディットボックスを並べて、そこへ結果を出力します。

ほか、特徴的な点
Windows.UIでのコントロール（エディットボックス）のサブクラス化
DWM下におけるGDIを用いた半透明描画 (BufferedPaint系関数の使用)
DWM下におけるタイトルバー上のアイコン・文字列の非表示
*/

#require <Classes/ActiveBasic/Windows/UI/Form.ab>
#require <Classes/ActiveBasic/Windows/UI/EditBox.ab>
#require <Classes/ActiveBasic/Windows/UI/Application.ab>

#resource "UI_Sample.rc"

Imports ActiveBasic.Windows
Imports ActiveBasic.Windows.UI
Imports System.Collections.Generic
Imports System.IO
Imports System.Threading

TypeDef HPAINTBUFFER = HANDLE

Const Enum BP_BUFFERFORMAT
    BPBF_COMPATIBLEBITMAP = 0
    BPBF_DIB = 1
    BPBF_TOPDOWNDIB = 2
    BPBF_TOPDOWNMONODIB = 3
End Enum

Const BPBF_COMPOSITED = BPBF_TOPDOWNDIB

Type BP_PAINTPARAMS
    cbSize As DWord
    dwFlags As DWord
    prcExclude As *RECT
    pBlendFunction As VoidPtr '*BLENDFUNCTION
End Type

Type MARGINS
    cxLeftWidth As Long
    cxRightWidth As Long
    cyTopHeight As Long
    cyBottomHeight As Long
End Type

Const Enum WINDOWTHEMEATTRIBUTETYPE
    WTA_NONCLIENT = 1
End Enum

Type WTA_OPTIONS
    dwFlags As DWord
    dwMask As DWord
End Type

Const WTNCA_NODRAWCAPTION = 1
Const WTNCA_NODRAWICON = 2

'API宣言ここまで

TypeDef PDwmExtendFrameIntoClientArea = *Function(hwnd As HWND, ByRef MarInset As MARGINS) As HRESULT
TypeDef PSetWindowThemeAttribute = *Function(hwnd As HWND, eAttribute As WINDOWTHEMEATTRIBUTETYPE, ByRef pvAttribute As Any, cbAttribute As DWord) As HRESULT
TypeDef PDwmIsCompositionEnabled = *Function(ByRef fEnabled As BOOL) As HRESULT
TypeDef PBeginBufferedPaint = *Function(hdcTarget As HDC, ByRef rcTarget As RECT, dwFormat As BP_BUFFERFORMAT, pPaintParams As *BP_PAINTPARAMS, ByRef hdc As HDC) As HPAINTBUFFER
TypeDef PBufferedPaintSetAlpha = *Function(hBufferedPaint As HPAINTBUFFER, ByRef rc As RECT, alpha As DWord) As HRESULT
TypeDef PBufferedPaintInit = *Function() As HRESULT
TypeDef PGetBufferedPaintBits = *Function(hBufferedPaint As HPAINTBUFFER, ByRef pbBuffer As *RGBQUAD, ByRef cxRow As Long) As HRESULT
TypeDef PEndBufferedPaint = *Function(hBufferedPaint As HPAINTBUFFER, fUpdateTarget As BOOL) As HRESULT

Const BorderWidth = 6

'コメントアウトを外すと、エディットボックス部分が不透明になる。
'#define OPAQUE_EDITBOX

Class MyForm
    Inherits Form
Public
    Sub MyForm()
        AddResize(AddressOf(onResize))
        AddPaintBackground(AddressOf(onPaintBackground))
        AddMessageEvent(WM_CTLCOLORSTATIC, AddressOf(onCtlColorEditBox))
        AddMessageEvent(WM_DWMCOMPOSITIONCHANGED, AddressOf(onCompositionChanged))
        edit = New List<EditBox>

        CreateForm()

        Text = "ParallelBuild"

        Dim hdc = GetDC()
        hfont = CreateFont(-MulDiv(9, GetDeviceCaps(hdc, LOGPIXELSY), 72), 0, 0, 0,
            FW_DONTCARE, FALSE, FALSE, FALSE, SHIFTJIS_CHARSET, OUT_DEFAULT_PRECIS,
            CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, FIXED_PITCH, "ＭＳ ゴシック")
        ReleaseDC(hdc)
        Dim wpFont = hfont As WPARAM

        Dim i As Long
        For i = 0 To 7
            Dim e = New EditBox
            e.AddMessageEvent(WM_PAINT, AddressOf(onPaintEditBox))
            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)
            e.SendMessage(WM_SETFONT, wpFont, 0)
            e.BeginSubclass()
            edit.Add(e)
        Next

        thread = New Thread(AddressOf(ControlProcess))
        thread.Start()

        hmodUxTheme = LoadLibrary("uxtheme")
        hmodDwmApi = LoadLibrary("dwmapi")

        If hmodUxTheme <> 0 Then
            pSetWindowThemeAttribute = GetProcAddress(hmodUxTheme, ToMBStr("SetWindowThemeAttribute")) As PSetWindowThemeAttribute
            pBufferedPaintUnInit = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintUnInit")) As PBufferedPaintInit
            pBeginBufferedPaint = GetProcAddress(hmodUxTheme, ToMBStr("BeginBufferedPaint")) As PBufferedPaintInit
            pBufferedPaintSetAlpha = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintSetAlpha")) As PBufferedPaintSetAlpha
            pEndBufferedPaint = GetProcAddress(hmodUxTheme, ToMBStr("EndBufferedPaint")) As PEndBufferedPaint
            pGetBufferedPaintBits = GetProcAddress(hmodUxTheme, ToMBStr("GetBufferedPaintBits")) As PGetBufferedPaintBits
            Dim pBufferedPaintInit = GetProcAddress(hmodUxTheme, ToMBStr("BufferedPaintInit")) As PBufferedPaintInit
            If pBufferedPaintInit <> 0 Then
                Dim hr = pBufferedPaintInit()
                If FAILED(hr) Then Debug
            End If
        End If

        If hmodDwmApi <> 0 Then
            pDwmIsCompositionEnabled = GetProcAddress(hmodDwmApi, ToMBStr("DwmIsCompositionEnabled")) As PDwmIsCompositionEnabled
            pDwmExtendFrameIntoClientArea = GetProcAddress(hmodDwmApi, ToMBStr("DwmExtendFrameIntoClientArea")) As PDwmExtendFrameIntoClientArea
            SendMessage(WM_DWMCOMPOSITIONCHANGED)
        End If
    End Sub

Private
    hmodUxTheme As HMODULE
    hmodDwmApi As HMODULE
    pDwmIsCompositionEnabled As PDwmIsCompositionEnabled
    pDwmExtendFrameIntoClientArea As PDwmExtendFrameIntoClientArea
    pSetWindowThemeAttribute As PSetWindowThemeAttribute
    pBufferedPaintUnInit As PBufferedPaintInit
    pBeginBufferedPaint As PBeginBufferedPaint
    pBufferedPaintSetAlpha As PBufferedPaintSetAlpha
    pEndBufferedPaint As PEndBufferedPaint
    pGetBufferedPaintBits As PGetBufferedPaintBits

    Sub onCompositionChanged(sender As Object, e As MessageArgs)
        e.Handled = True
        useDwm = False
        If pDwmIsCompositionEnabled <> 0 Then
            Dim enabled As BOOL
            If SUCCEEDED(pDwmIsCompositionEnabled(enabled)) And enabled Then
                useDwm = True
                'クライアント領域全体にガラス効果をかける。
                Dim m = [-1, 0, 0, 0] As MARGINS
                pDwmExtendFrameIntoClientArea(This, m)
                'タイトルバーのアイコン・文字列を消す。
                Dim wo As WTA_OPTIONS
                wo.dwFlags = WTNCA_NODRAWCAPTION Or WTNCA_NODRAWICON
                wo.dwMask = WTNCA_NODRAWCAPTION Or WTNCA_NODRAWICON
                pSetWindowThemeAttribute(hwnd, WTA_NONCLIENT, wo, Len(wo))
            End If
        End If
        Invalidate()
    End Sub

    Sub onDestroy(sender As Object, e As Args)
        DeleteObject(hfont)
        pBufferedPaintUnInit()
        If hmodUxTheme <> 0 Then
            FreeLibrary(hmodUxTheme)
        End If
        If hmodDwmApi <> 0 Then
            FreeLibrary(hmodDwmApi)
        End If
    End Sub

    Sub onResize(sender As Object, e As ResizeArgs)
        Dim i As Long
        For i = 0 To 7
            Dim t = edit[i]
            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)
        Next
    End Sub

    Sub onPaintBackground(sender As Object, e As PaintBackgroundArgs)
        If useDwm Then
            Dim hdc = e.Handle
            SetBkColor(hdc, 0)
            ExtTextOut(hdc, 0, 0, ETO_OPAQUE, ClientRect, "", 0, 0)
        End If
    End Sub

    Static Const backgroundColor = RGB(255, 255, 255)
    Static Const textColor = RGB(0, 0, 0)

    Sub onCtlColorEditBox(sender As Object, e As MessageArgs)
        Dim hdc = e.WParam As HDC
        SetTextColor(hdc, textColor)
        SetBkColor(hdc, backgroundColor)
        e.LResult = GetStockObject(NULL_BRUSH) As LRESULT
        e.Handled = True
    End Sub

    Sub onPaintEditBox(sender As Object, e As MessageArgs)
        Dim alpha = &hcc As DWord
        Dim i As Long, j As Long
        If useDwm Then
            Dim edit = sender As EditBox
            Dim ps As PAINTSTRUCT
            BeginPaint(e.HWnd, ps)
            Dim hdcMem As HDC
            Dim hpb = pBeginBufferedPaint(ps.hdc, ps.rcPaint, BPBF_TOPDOWNDIB, 0, hdcMem)
            If hpb <> 0 Then
                FillRect(hdcMem, ps.rcPaint, GetStockObject(WHITE_BRUSH) As HBRUSH)
                edit.DefWndProc(WM_PRINTCLIENT, hdcMem As WPARAM, PRF_CLIENT)
#ifdef OPAQUE_EDITBOX
                pBufferedPaintSetAlpha(hpb, ps.rcPaint, 255)
#else
                Dim cxRow As Long
                Dim p As *RGBQUAD
                pGetBufferedPaintBits(hpb, p, cxRow)
                Dim pdw = p As *DWord
                For i = 0 To ELM(ps.rcPaint.bottom - ps.rcPaint.top)
                    For j = 0 To ELM(ps.rcPaint.right - ps.rcPaint.left)
                        Dim rgb = pdw[i * cxRow + j] And &h00ffffff
                        If rgb = textColor Then 'ClearType下で試すと、rgb <> backgroundColorよりこのほうが綺麗。
                            pdw[i * cxRow + j] Or= &hff000000
                        Else
                            With p[i * cxRow + j]
                                .rgbReserved = alpha As Byte
                                .rgbRed = ((.rgbRed * alpha) >> 8) As Byte
                                .rgbGreen = ((.rgbGreen * alpha) >> 8) As Byte
                                .rgbBlue = ((.rgbBlue * alpha) >> 8) As Byte
                            End With
                        End If
                    Next
                Next
#endif
                pEndBufferedPaint(hpb, TRUE)
            End If
            EndPaint(e.HWnd, ps)
            e.Handled = True
        Else
            e.Handled = False
        End If
    End Sub

    Sub ControlProcess()
        Dim buildCmd[7] As PCTSTR
        buildCmd[0] = "build_basic_static_library(32bit - debug - unicode).bat"
        buildCmd[1] = "build_basic_static_library(32bit - debug).bat"
        buildCmd[2] = "build_basic_static_library(32bit - release - unicode).bat"
        buildCmd[3] = "build_basic_static_library(32bit - release).bat"
        buildCmd[4] = "build_basic_static_library(64bit - debug - unicode).bat"
        buildCmd[5] = "build_basic_static_library(64bit - debug).bat"
        buildCmd[6] = "build_basic_static_library(64bit - release - unicode).bat"
        buildCmd[7] = "build_basic_static_library(64bit - release).bat"
        Dim pathBase = "P:\PROGRAMS\ablib\ab5.0\ablib\build_batch\"
        Dim hProcess[7] As HANDLE
        Dim hPipe[7] As HANDLE
        Dim i As Long
        For i = 0 To 7
            CreateBuildProcess(hProcess[i], hPipe[i], pathBase, buildCmd[i])
        Next
        Dim buf[4095] As CHAR
        For i = 0 To 7
            WaitForSingleObject(hProcess[i], INFINITE)
            Dim readSize As DWord
            ReadFile(hPipe[i], buf, Len(buf), VarPtr(readSize), ByVal 0)
            Dim s = New String(buf, readSize As Long)
            edit[i].SendMessage(WM_SETTEXT, 0, ToTCStr(s) As LPARAM)
            CloseHandle(hProcess[i])
            CloseHandle(hPipe[i])
        Next
    End Sub

    Sub CreateBuildProcess(ByRef hProcess As HANDLE, ByRef hPipeOutput As HANDLE, cmdPath As String, cmdLine As PCSTR)
        Dim hPipeRead As HANDLE, hPipeWrite As HANDLE
        Dim sa As SECURITY_ATTRIBUTES
        sa.nLength = Len(sa)
        sa.lpSecurityDescriptor = 0
        sa.bInheritHandle = TRUE
        If CreatePipe(hPipeRead, hPipeWrite, VarPtr(sa), 0) = FALSE Then
            ThrowWithLastError()
        End If
        Dim si As STARTUPINFO
        Dim pi As PROCESS_INFORMATION
        si.cb = Len(si)
        si.dwFlags = STARTF_USESTDHANDLES
        si.hStdInput = GetStdHandle(STD_INPUT_HANDLE)
        si.hStdOutput = hPipeWrite
        si.hStdError = hPipeWrite
        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
            ThrowWithLastError()
        End If
        CloseHandle(pi.hThread)
        hPipeOutput = hPipeRead
        hProcess = pi.hProcess
    End Sub

    edit As List<EditBox>
    thread As Thread
    hfont As HFONT
    useDwm As Boolean
End Class

Control.Initialize(GetModuleHandle(0))

Dim f = New MyForm
Application.Run(f)