Date: 02-16-2022
Return to Index
created by gbSnippets
'Credit Chris(H)
Function MakeFont(ByVal fName As String, ByVal ptSize As Long, _
Opt ByVal attr As String) As Dword
'--------------------------------------------------------------------
' Create a desired font and return its handle.
' attr = "biu" for bold, italic, and underlined (any order)
'--------------------------------------------------------------------
Local hDC As Dword, CharSet As Long, CyPixels As Long
Local Bold, italic, uLine As Long
If Len(attr) Then
If InStr(LCase$(attr), "b") Then Bold = %FW_BOLD
If InStr(LCase$(attr), "i") Then italic = 1
If InStr(LCase$(attr), "u") Then uLine = 1
End If
hDC = GetDC(%HWND_Desktop)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
ReleaseDC %HWND_Desktop, hDC
PtSize = 0 - (ptSize * CyPixels) \ 72
Function = CreateFont(ptSize, 0, 0, 0, Bold, italic, uLine, _
%FALSE, CharSet, %OUT_TT_PRECIS, _
%CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
%FF_DONTCARE , ByCopy fName)
End Function
'Compilable Example: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Include "Win32API.inc"
'--------------------------------------------------------------------------------
Function MakeFont(ByVal fName As String, ByVal ptSize As Long, _
Opt ByVal attr As String) As Dword
'--------------------------------------------------------------------
' Create a desired font and return its handle.
' attr = "biu" for bold, italic, and underlined (any order)
'--------------------------------------------------------------------
Local hDC As Dword, CharSet As Long, CyPixels As Long
Local Bold, italic, uLine As Long
If Len(attr) Then
If InStr(LCase$(attr), "b") Then Bold = %FW_BOLD
If InStr(LCase$(attr), "i") Then italic = 1
If InStr(LCase$(attr), "u") Then uLine = 1
End If
hDC = GetDC(%HWND_Desktop)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
ReleaseDC %HWND_Desktop, hDC
PtSize = 0 - (ptSize * CyPixels) \ 72
Function = CreateFont(ptSize, 0, 0, 0, Bold, italic, uLine, _
%FALSE, CharSet, %OUT_TT_PRECIS, _
%CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
%FF_DONTCARE , ByCopy fName)
End Function
'--------------------------------------------------------
CallBack Function CBProc
Local PS As PAINTSTRUCT
Local hDC, hbmp As Dword
Static hfont1, hfont2 As Dword
Local halignment As Dword
Local r As rect
Static s As String
Select Case As Long CbMsg
Case %WM_InitDialog
hfont1 = makefont("Courier New", 12, "")
hfont2 = makefont("Arial", 24, "I")
s = "hello"
'
Case %WM_Paint
hDC = beginpaint(Cb.Hndl, PS)
getclientrect Cb.Hndl, r
fillrect hdc, r, getstockobject(%white_brush)
hbmp = createcompatiblebitmap(hdc, r.nright, r.nbottom)
hbmp = selectobject(hdc, hbmp)
halignment = SetTextAlign(hDC, %TA_BASELINE Or %TA_NOUPDATECP)
hfont1 = selectobject(hDC, hfont1)
textout hdc, 10, 30, ByVal StrPtr(s), Len(s)
hfont1 = selectobject(hDC, hfont1)
hfont2 = selectobject(hDC, hfont2)
textout hdc, 60, 30, ByVal StrPtr(s), Len(s)
hfont2 = selectobject(hDC, hfont2)
hbmp = selectobject(hdc, hbmp)
deleteobject(hbmp)
endpaint Cb.Hndl, PS
End Select
End Function
'--------------------------------------------------------
Function PBMain As Long
Local hDlg As Dword
Dialog New Pixels, 0, "Test", _
0, 0, 145, 50, _
%WS_SysMenu Or %WS_ThickFrame Or %DS_Center, _
To hDlg
Dialog Show Modal hDlg, Call CBProc
End Function
'gbs_00856
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm