#strict

Function WndProc(hwnd As HWND, msg As DWord, wp As WPARAM, lp As LPARAM) As LRESULT
	If msg = WM_DESTROY Then
		PostQuitMessage(0)
		WndProc = 0
	Else
		WndProc = DefWindowProc(hwnd, msg, wp, lp)
	End If
End Function

Function CreateButton(hinst As HINSTANCE, hwndParent As HWND, id As Long, hfont As HFONT) As HWND
	Dim title As String
	title = "ボタン" + Str$(id)
	CreateButton = CreateWindowEx(
		WS_EX_APPWINDOW, "BUTTON", StrPtr(title),
		WS_CHILD Or WS_VISIBLE Or BS_PUSHBUTTON,
		20, 50 * id - 30, 100, 40,
		hwndParent, id As HMENU, hinst, 0)
	If CreateButton <> 0 Then
		SendMessage(CreateButton, WM_SETFONT, hfont As WPARAM, 0)
	End If
End Function

Sub FailedToActivate()
	Dim msg As String
	msg = "アクティベート失敗: " + Hex$(GetLastError())
	MessageBox(hwnd, StrPtr(msg), 0, MB_OK)
End Sub

Dim ac As ACTCTX, hActCtx As HANDLE
With ac
	.cbSize = Len(ac)
	.lpSource = "XPThemes.manifest"
End With
hActCtx = CreateActCtx(ac)

Dim wcx As WNDCLASSEX
With wcx
	.cbSize = Len(wcx)
	.style = CS_HREDRAW Or CS_VREDRAW
	.lpfnWndProc = AddressOf(WndProc)
	.cbClsExtra = 0
	.cbWndExtra = 0
	.hInstance = GetModuleHandle(0)
	.hIcon = LoadImage(0, IDI_APPLICATION As *Byte, IMAGE_ICON, 0, 0, LR_SHARED) As HICON
	.hCursor = LoadImage(0, IDC_ARROW As *Byte, IMAGE_CURSOR, 0, 0, LR_SHARED) As HCURSOR
	.hbrBackground = (COLOR_3DFACE + 1) As HBRUSH
	.lpszMenuName = 0
	.lpszClassName = "ACTest window"
End With
If RegisterClassEx(wcx) = 0 Then
	ExitProcess(-1)
End If

Dim hwnd As HWND
hwnd = CreateWindowEx(
	0, wcx.lpszClassName, "ACTest", WS_OVERLAPPEDWINDOW,
	CW_USEDEFAULT, CW_USEDEFAULT, 160, 320,
	0, 0, wcx.hInstance, 0)
If hwnd = 0 Then
	ExitProcess(-1)
End If

Dim ncm As NONCLIENTMETRICS
ncm.cbSize = 340 'Len(ncm)
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, ncm.cbSize, VarPtr(ncm), 0)

Dim hfnt As HFONT
hfnt = CreateFontIndirect(ncm.lfMessageFont)

Dim cookie As ULONG_PTR

CreateButton(wcx.hInstance, hwnd, 1, hfnt)

If ActivateActCtx(hActCtx, cookie) = FALSE Then FailedToActivate()
CreateButton(wcx.hInstance, hwnd, 2, hfnt)
DeactivateActCtx(0, cookie)

CreateButton(wcx.hInstance, hwnd, 3, hfnt)

If ActivateActCtx(hActCtx, cookie) = FALSE Then FailedToActivate()
CreateButton(wcx.hInstance, hwnd, 4, hfnt)
DeactivateActCtx(0, cookie)

CreateButton(wcx.hInstance, hwnd, 5, hfnt)

ShowWindow(hwnd, SW_SHOW)

Dim msg As MSG, ret As Long
Do
	ret = GetMessage(msg, 0, 0, 0)
	If ret = 0 Or ret = -1 Then Exit Do
	TranslateMessage(msg)
	DispatchMessage(msg)
Loop
DeleteObject(hfnt)
ReleaseActCtx(hActCtx)
ExitProcess(msg.wParam As Long)

Type ACTCTX
	cbSize As DWord
	dwFlags As DWord
	lpSource As *Byte
	wProcessorArchitecture As Word
	wLangId As DWord 'LANGID
	lpAssemblyDirectory As *Byte
	lpResourceName As *Byte
	lpApplicationName As *Byte
	hModule As HINSTANCE
End Type

Declare Function CreateActCtx Lib "kernel32" Alias "CreateActCtxA" (ByRef actctx As ACTCTX) As HANDLE
Declare Function ActivateActCtx Lib "kernel32" (hActCtx As HANDLE, ByRef cookie As ULONG_PTR) As BOOL
Declare Function DeactivateActCtx Lib "kernel32" (dwFlags As DWord, cookie As ULONG_PTR) As BOOL
Declare Sub ReleaseActCtx Lib "kernel32" (hActCtx As HANDLE)

Type NONCLIENTMETRICS
	cbSize As DWord
	iBorderWidth As Long
	iScrollWidth As Long
	iScrollHeight As Long
	iCaptionWidth As Long
	CaptionHeight As Long
	lfCaptionFont As LOGFONT
	iSmCaptionWidth As Long
	iSmCaptionHeight As Long
	lfSmCaptionFont As LOGFONT
	iMenuWidth As Long
	iMenuHeight As Long
	lfMenuFont As LOGFONT
	lfStatusFont As LOGFONT
	lfMessageFont As LOGFONT
	iPaddedBorderWidth As Long
End Type