I started with some aero project but I stucked in part when I need to change a text font. I know how to change text color, but how to change a text font, and text size? Here is full code of example:
Code: Select all
#include once "windows.bi"
#Include "win/uxtheme.bi"
Dim Shared As HMODULE hModuleDwmApi, hModuleUxtheme
hModuleDwmApi = LoadLibrary( "dwmapi.dll" )
hModuleUxtheme = LoadLibrary( "uxtheme.dll" )
Type DTTOPTS
dwSize As Dword
dwFlags As Dword
crText As COLORREF
crBorder As COLORREF
crShadow As COLORREF
iTextShadowType As Integer
ptShadowOffset As Point
iBorderSize As Integer
iFrontPropIf As Integer
iColoerPropId As Integer
iStateId As Integer
fApplyOverlay As Boolean
iGlowSize As Integer
pfnDrawTextCallback As Integer
lParam As LPARAM
End Type
#Define DTT_TEXTCOLOR 1
#Define DTT_SHADOWTYPE 8
#Define DTT_COMPOSITED 8192
#Define DTT_GLOWSIZE 2048
#Define TST_CONTINUOUS 2
#Define TMT_MSGBOXFONT 805
#Define TMT_CAPTIONFONT 801
#Define WP_CAPTION 1
#Define CS_ACTIVE 1
Dim Shared DrawThemeTextEx As Function(byval as HTHEME, byval as HDC, byval as integer, byval as integer, byval as LPCWSTR, byval as integer, byval as DWORD, byval as RECT Ptr, byval as DTTOPTS ptr) as HRESULT
Dim Shared DwmExtendFrameIntoClientArea As Function( Byval As HWND, Byval As MARGINS Ptr ) As HRESULT
DrawThemeTextEx = GetProcAddress( hModuleUxTheme, "DrawThemeTextEx" )
DwmExtendFrameIntoClientArea = GetProcAddress( hModuleDwmApi, "DwmExtendFrameIntoClientArea" )
Dim Shared As HFONT hFont
Dim Shared As HTHEME hTheme
Declare Function WinMain( ByVal hInstance As HINSTANCE, _
ByVal hPrevInstance As HINSTANCE, _
szCmdLine As String, _
ByVal iCmdShow As Integer ) As Integer
End WinMain( GetModuleHandle( null ), null, Command$, SW_NORMAL )
Enum FontOptionsEnum
Bold = &b1
Italic = &b10
Underline = &b100
StrikeThrough = &b1000
AntiAliased = &b10000
End Enum
Function MakeFont( Byval FontName As String = "Arial", _
Byval FontSize As Uinteger = 12, _
Byval FontOptions As Uinteger = 0 _
) As HFONT
Dim nHeight As Uinteger
Dim nWidth As Uinteger
Dim nEscapement As Uinteger
Dim nOrientation As Uinteger
Dim fnWeight As Uinteger
Dim fdwItalic As Uinteger
Dim fdwUnderline As Uinteger
Dim fdwStrikeOut As Uinteger
Dim fdwCharSet As Uinteger
Dim fdwOutputPrecision As Uinteger
Dim fdwClipPrecision As Uinteger
Dim fdwQuality As Uinteger
Dim fdwPitchAndFamily As Uinteger
Dim hFont As HFONT
Dim hDC As HDC
hDC = GetDC(HWND_DESKTOP)
nHeight = -MulDiv(FontSize, GetDeviceCaps(hDC, LOGPIXELSY), 72)' "pt" sized
nWidth = 0
ReleaseDC HWND_DESKTOP, hDC
nEscapement = NULL
nOrientation = NULL
If FontOptions And Bold Then fnWeight = 700 Else fnWeight = 100
If FontOptions And Italic Then fdwItalic = TRUE
If FontOptions And Underline Then fdwUnderline = TRUE
If FontOptions And StrikeThrough Then fdwStrikeOut = TRUE
fdwQuality = ANTIALIASED_QUALITY
fdwCharSet = NULL
fdwOutputPrecision = NULL
fdwClipPrecision = NULL
fdwQuality = NULL
fdwPitchAndFamily = NULL
hFont = CreateFont( _
nHeight, _
nWidth, _
nEscapement, _
nOrientation, _
fnWeight, _
fdwItalic, _
fdwUnderline, _
fdwStrikeOut, _
fdwCharSet, _
fdwOutputPrecision, _
fdwClipPrecision, _
fdwQuality, _
fdwPitchAndFamily, _
Strptr(FontName) _
)
Return hFont
End Function
Function WndProc( ByVal hWnd As HWND, _
ByVal message As UINT, _
ByVal wParam As WPARAM, _
ByVal lParam As LPARAM ) As LRESULT
Function = 0
Select Case( message )
Case WM_CREATE
Dim margs As MARGINS
margs.cxLeftWidth = -1
margs.cxRightWidth = -1
margs.cyTopHeight = -1
margs.cyBottomHeight = -1
DwmExtendFrameIntoClientArea( hWnd, @margs )
hTheme = OpenThemeData(0, "CompositedWindow::Window")
Return TRUE
Case WM_ERASEBKGND
Dim As HDC dc = Cast(HDC, wParam)
Dim As RECT rcClient, rcText
GetClientRect(hWnd, @rcClient)
FillRect(dc, @rcClient, CreateSolidBrush(BGR(0, 0, 0)))
CopyRect(@rcText, @rcClient)
Dim As HDC dcMem
Dim As HBITMAP bmp
Dim As BITMAPINFO dib
dcMem = CreateCompatibleDC(dc)
With dib.bmiHeader
.biSize = SizeOf(BITMAPINFOHEADER)
.biWidth = rcText.right
.biHeight = -rcText.bottom
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
bmp = CreateDIBSection(dc, @dib, DIB_RGB_COLORS, NULL, NULL, 0)
SelectObject(dcMem, bmp)
Dim As DTTOPTS dto
Dim As RECT rcText2
Const As UINT uFormat = DT_SINGLELINE Or DT_CENTER Or DT_VCENTER
CopyRect(@rcText2, @rcText)
With dto
.dwSize = SizeOf(DTTOPTS)
.dwFlags = DTT_COMPOSITED Or DTT_GLOWSIZE Or DTT_TEXTCOLOR
.iGlowSize = 10
.crText = BGR(0, 32, 64)
End With
hFont = MakeFont("Courier New", 20)
SelectObject(dcMem, hFont)
DrawText(dcMem, @"hey", -1, @rcText2, DT_TABSTOP)
DrawThemeTextEx(hTheme, dcMem, WP_CAPTION, CS_ACTIVE, "Hello, World!", -1, _
uFormat, @rcText2, @dto)
BitBlt(dc, rcText.left, rcText.top, rcText.right-rcText.left, rcText.bottom-rcText.top, _
dcMem, 0, 0, SRCCOPY)
Return TRUE
Case WM_KEYDOWN
If( LoByte( wParam ) = 27 ) Then
PostMessage( hWnd, WM_CLOSE, 0, 0 )
End If
Case WM_DESTROY
PostQuitMessage( 0 )
Exit Function
End Select
Function = DefWindowProc( hWnd, message, wParam, lParam )
End Function
Function WinMain( ByVal hInstance As HINSTANCE, _
ByVal hPrevInstance As HINSTANCE, _
szCmdLine As String, _
ByVal iCmdShow As Integer ) As Integer
Dim wMsg As MSG
Dim wcls As WNDCLASS
Dim szAppName As String
Dim hWnd As HWND
Function = 0
szAppName = "HelloWin"
With wcls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = @WndProc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = hInstance
.hIcon = LoadIcon( NULL, IDI_APPLICATION )
.hCursor = LoadCursor( NULL, IDC_ARROW )
.lpszMenuName = NULL
.lpszClassName = StrPtr( szAppName )
End With
If( RegisterClass( @wcls ) = FALSE ) Then
MessageBox( null, "Failed to register wcls!", szAppName, MB_ICONERROR )
Exit Function
End If
hWnd = CreateWindowEx( 0, _
szAppName, _
"FreeBASIC Glowing Text Example", _
WS_OVERLAPPEDWINDOW, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
CW_USEDEFAULT, _
NULL, _
NULL, _
hInstance, _
NULL )
ShowWindow( hWnd, iCmdShow )
UpdateWindow( hWnd )
While( GetMessage( @wMsg, NULL, 0, 0 ) <> FALSE )
TranslateMessage( @wMsg )
DispatchMessage( @wMsg )
Wend
Function = wMsg.wParam
End Function
Any idea?