home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / code / various / ttsetup / ttsetup.bas next >
Encoding:
BASIC Source File  |  1994-09-04  |  1.6 KB  |  33 lines
  1. Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) As Integer
  2. Declare Function CreateScalableFontResource% Lib "GDI" (ByVal fHidden%, ByVal lpszResourceFile$, ByVal lpszFontFile$, ByVal lpszCurrentPath$)
  3. Declare Function AddFontResource Lib "GDI" (ByVal lpFilename As Any) As Integer
  4. Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
  5.  
  6. '  This sub installs a TrueType font and makes it available to
  7. '  all Windows apps to use. Also adds it to WIN.INI so on next
  8. '  boot up the font is also loaded.
  9. '
  10. '  FontName$ is the name that appears in the application font menu.
  11. '  FontFileName$ is the actual font name.  (i.e. something.ttf)
  12. '  WindSysDir$ is the Windows system directory. (i.e. C:\WINDOWS\SYSTEM)
  13. '
  14. '  YOU MUST COPY THE FONT FILE TO WINDOWS DIRECTORY BEFORE CALLING THE SUB!
  15. '
  16. '  For examples on how you can get the Windows system directory and copying
  17. '  a copy see Setup Wizard examples in your VB directory.
  18. '
  19. Sub Install_TTF (FontName$, FontFileName$, WindSysDir$)
  20.     Dim Ret%, Res&, FontPath$, FontRes$
  21.     Const WM_FONTCHANGE = &H1D
  22.     Const HWND_BROADCAST = &HFFFF
  23.  
  24.     FontPath$ = WindSysDir$ + "\" + FontFileName$
  25.     FontRes$ = Left$(FontPath$, Len(FontPath$) - 3) + "FOT"
  26.  
  27.     Ret% = CreateScalableFontResource(0, FontRes$, FontFileName$, WindSysDir$)
  28.     Ret% = AddFontResource(FontRes$)
  29.     Res& = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
  30.     Ret% = WriteProfileString("fonts", FontName + " (TrueType)", FontRes$)
  31. End Sub
  32.  
  33.