Add32Font, Add16Font,AddNTFont

Private Sub Add32Font(Filename As String)
  #If Win32 Then
    Dim lResult As Long
    Dim strFontPath As String, strFontname As String
    Dim hKey As Long
  
    'This is the font name and path
  
    strFontPath = Space$(MAX_PATH)
    strFontname = Filename
    
    If NT Then
      'Windows NT - Call and get the path to the
      '\windows\system directory
      lResult = GetWindowsDirectory(strFontPath, _
        MAX_PATH)
      If lResult <> 0 Then Mid$(strFontPath, _
        lResult + 1, 1) = "\"
      strFontPath = RTrim$(strFontPath)
    Else
      'Win95 - Call and get the path to the
      '\windows\fonts directory
      lResult = GetWindowsDirectory(strFontPath, _
        MAX_PATH)
      If lResult <> 0 Then Mid$(strFontPath, _
        lResult + 1) = "\fonts\"
      strFontPath = RTrim$(strFontPath)
    End If
      
    'This Actually adds the font to the system's available
    'fonts for this windows session
    lResult = AddFontResource(strFontPath + strFontname)
    ' If lResult = 0 Then MsgBox "Error Occured " & _
      "Calling AddFontResource"
    
    'Write the registry value to permanently install the
    'font
    lResult = RegOpenKey(HKEY_LOCAL_MACHINE, _
      "software\microsoft\windows\currentversion\" & _
      "fonts", hKey)
    lResult = RegSetValueEx(hKey, "Proscape Font " & strFontname & _
      " (TrueType)", 0, REG_SZ, ByVal strFontname, _
      Len(strFontname))
    lResult = RegCloseKey(hKey)
    
    'This call broadcasts a message to let all top-level
    'windows know that a font change has occured so they
    'can reload their font list
    lResult = PostMessage(HWND_BROADCAST, WM_FONTCHANGE, _
      0, 0)
  
    ' MsgBox "Font Added!"
  #End If
End Sub

Private Function NT() As Boolean
  #If Win32 Then
    Dim lResult As Long
    Dim vi As OSVERSIONINFO
    
    vi.dwOSVersionInfoSize = Len(vi)
    lResult = GetVersionEx(vi)
    
    If vi.dwPlatformId And VER_PLATFORM_WIN32_NT Then
      NT = True
    Else
      NT = False
    End If
  #End If
  
End Function
Public Sub Add16Font(Filename As String)
  #If Win16 Then
    On Error Resume Next
    Dim sName As String, sFont As String, sDir As String, I As Integer
Dim r as Long
  
    ' Windows' System directory
    sDir = GetWinSysDir()
    
    ' Name of font resource file
    I = InStr(Filename, ".")
    If I > 0 Then
      sFont = Left(Filename, I - 1) + ".fot"
    Else
      sFont = Filename + ".fot"
    End If
    sFont = sDir & "\" & sFont
    Kill sDir & "\" & sFont
    
    sName = "Font " & Filename & " (True Type)"
    r = CreateScalableFontResource%(0, sFont, Filename, sDir)  '
Create the font resource file
    r = AddFontResource(sFont)                  ' Add
resource to Windows font table
    r = WriteProfileString("Fonts", sName, sFont)        ' Make
changes to WIN.INI to reflect new font
    r = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0&)    ' Let
other applications know of the change:
  #End If
  
End Sub

Function GetWinSysDir() As String
  #If Win16 Then
    ' returns Windows System directory
    Dim Buffer As String * 254, r As Integer, sDir As String
  
    r = GetSystemDirectory(Buffer, 254)
    sDir = Left(Buffer, r)
  
    If Right(sDir, 1) = "\" Then sDir = Left(sDir, Len(sDir) - 1)
    GetWinSysDir = sDir
  #End If
  
End Function

Function GetWinDir() As String
  #If Win32 Then
    ' returns Windows directory
    Dim Buffer As String * 254, r As Long, sDir As String
  
    r = GetWindowsDirectory(Buffer, 254)
    sDir = Left(Buffer, r)
  
    If Right(sDir, 1) = "\" Then sDir = Left(sDir, Len(sDir) - 1)
    GetWinDir = sDir
  #End If
  
End Function
Public Function Reverse(Text As String) As String
  On Error Resume Next
  Dim I%, mx%, result$
  mx = Len(Text)
  For I = mx To 1 Step -1
    result = result + Mid$(Text, I, 1)
  Next
  Reverse = result
End Function
Upload
Upload