Make Font

Category: Fonts

Date: 03-28-2012

Return to Index


 
'Credit Chris(H)
 
 
Function MakeFont(ByVal fName As String, ByVal ptSize As Long, _
                  Opt ByVal attr As StringAs 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:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Include "Win32API.inc"
'--------------------------------------------------------------------------------
 
Function MakeFont(ByVal fName As String, ByVal ptSize As Long, _
      Opt ByVal attr As StringAs 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


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm