Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/wsfont/fm.bas

BASIC Source File | 1995-05-09 | 7.4 KB | 240 lines

Option Explicit
Option Compare Text
Global MoveBasic%
Global TestFont$
Global CRLF$
Global ActiveC As ListBox
Type Logfont
  lfHeight As Integer
  lfWidth As Integer
  lfEscapement As Integer
  lfOrientation As Integer
  lfWeight As Integer
  lfItalic As String * 1
  lfUnderline As String * 1
  lfStrikeOut As String * 1
  lfCharSet As String * 1
  lfOutPrecision As String * 1
  lfClipPrecision As String * 1
  lfQuality As String * 1
  lfPitchAndFamily As String * 1
  lfFaceName As String * 32
End Type

Type TextMetric
  tmHeight As Integer
  tmAscent As Integer
  tmDescent As Integer
  tmInternalLeading As Integer
  tmExternalLeading As Integer
  tmAveCharWidth As Integer
  tmMaxCharWidth As Integer
  tmWeight As Integer
  tmItalic As String * 1
  tmUnderlined As String * 1
  tmStruckOut As String * 1
  tmFirstChar As String * 1
  tmLastChar As String * 1
  tmDefaultChar As String * 1
  tmBreakChar As String * 1
  tmPitchAndFamily As String * 1
  tmCharSet As String * 1
  tmOverhang As Integer
  tmDigitizedAspectX As Integer
  tmDigitizedAspectY As Integer
End Type

Global TM As TextMetric
Global lf As Logfont
Global LfArray(255) As Logfont
Global TMArray(255) As TextMetric
Global pFonts() As String
Declare Function EnumFonts% Lib "GDI" (ByVal hDC%, ByVal lpFaceName As Any, ByVal lpFontFUnc&, ByVal lpData&)
'Declare Function GetObject% Lib "GDI" (ByVal hObject%, ByVal nCount%, ByVal lpObject&)

'Declares for INI file routines
Declare Function WritePrivateProfileString% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString As Any, ByVal lplFileName$)
Declare Function WriteProfileString% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString As Any)
Declare Function GetProfileInt% Lib "KERNEL" (ByVal lpAppName$, ByVal lpKeyName$, ByVal nDefault%)
Declare Function GetPrivateProfileInt% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal nDefault%, ByVal lpFilename$)
Declare Function GetPrivateProfileString% Lib "KERNEL" (ByVal lpApplicationName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpFilename$)
Declare Function GetProfileString% Lib "KERNEL" (ByVal lpAppName$, ByVal lpKeyName As Any, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
Declare Function AddFontResource% Lib "GDI" (ByVal lpFilename As Any)
Declare Function RemoveFontResource% Lib "GDI" (ByVal lpFilename As Any)
Declare Function SendMessage% Lib "USER" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%, lParam As Any)
Const WM_FONTCHANGE = &H1D
Const WM_WININICHANGE = &H1A
'Declares for GetSystemDir
Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer

Sub BroadcastIniChange ()
Dim y%
y% = SendMessage(&H0, WM_FONTCHANGE, 0, 0)'tell other apps that font list has changed
y% = SendMessage(&H0, WM_WININICHANGE, 0, 0)'tell other apps that WIN.INI has changed

End Sub

Sub DeletePrivIni (pApp$, pkey$, pFile$)
Dim X%
X% = WritePrivateProfileString%(pApp$, pkey$, 0&, pFile$)
End Sub

Sub DeleteWinIni (pApp$, pkey$)
Dim X%
X% = WriteProfileString%(pApp$, pkey$, 0&)
End Sub

Function Exists% (F$)
'  * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'  returns 0 if file not found, or if error in file spec,
'  otherwise returns -1
'  * * * * * * * * * * * * * * * * * * * * * * * * * * * *
On Error Resume Next
Exists% = True
If Len(Dir$(F$)) = 0 Then Exists% = False
On Error GoTo 0
End Function

Function GetPrivINI$ (pApp$, pkey$, pDefault$, pFile$)
Dim X%
Dim ret As String * 1024
X% = GetPrivateProfileString%(pApp$, pkey$, pDefault$, ret, Len(ret), pFile$)
If X% > 0 Then GetPrivINI$ = Left$(ret, X%)
End Function

Function GetPrivIniInt% (pApp$, pkey$, pDefault%, pFile$)
GetPrivIniInt% = GetPrivateProfileInt%(pApp$, pkey$, pDefault%, pFile$)
End Function

Function GetSystemDir$ ()
Dim Sys As String * 256, X%
X = GetSystemDirectory(Sys, Len(Sys))
'X = InStr(1, Sys, Chr$(0))
GetSystemDir$ = Left$(Sys, InStr(Sys, Chr$(0)) - 1) + "\"
End Function

Function GetWinINI$ (pApp$, pkey$, pDefault$)
Dim X%
Dim ret As String * 1024
X% = GetProfileString%(pApp$, pkey$, pDefault$, ret, Len(ret))
If X% > 0 Then GetWinINI$ = Left$(ret, X%)
End Function

Function GetWinIniInt% (pApp$, pkey$, pDefault%)
GetWinIniInt% = GetProfileInt%(pApp$, pkey$, pDefault%)
End Function

Function HIWORD% (LongVal&)
HIWORD% = LongVal& \ 65536 ' (note: '\', not '/')
End Function

Function Install% (fName$)
Dim ret As String * 255
Dim test$, y%
test$ = GetPrivINI$("fonts", fName$, "uh-oh", "WSFONTS.INI")
If test$ = "uh-oh" Then MsgBox "can't install " & fName$: Exit Function
y% = AddFontResource(test$)   '  remove font resource for this file
If y% <> 0 Then
   PutWinIni "fonts", fName$, test$
   DeletePrivIni "fonts", fName$, "WSFONTS.INI"
Else
   MsgBox "Couldn't install font."
End If
Install% = True
End Function

Function ListPrivateIniEntries$ (pApp$, pFile$)
Dim X%
Dim ret As String * 4096
X% = GetPrivateProfileString%(pApp$, 0&, "", ret, Len(ret), pFile$)
If X% > 0 Then ListPrivateIniEntries$ = Left$(ret, X%)
End Function

Function ListWinIniEntries$ (pApp$)
Dim X%
Dim ret As String * 4096
X% = GetProfileString%(pApp$, 0&, "", ret, Len(ret))
If X% > 0 Then ListWinIniEntries$ = Left$(ret, X%)
End Function

Function LoWord% (LongVal&)
LoWord% = LongVal& And 65535
End Function

Sub PutPrivIni (pApp$, pkey$, pString$, pFile$)
Dim X%
X% = WritePrivateProfileString%(pApp$, pkey$, pString$, pFile$)
End Sub

Sub PutWinIni (pApp$, pkey$, pString$)
Dim X%
X% = WriteProfileString%(pApp$, pkey$, pString$)
End Sub

Function ReadFontInfo$ (ByVal F$)
Dim fh%, A$, B$, lf%, X%, re%, test$
fh% = FreeFile
F$ = UCase$(F$)

If Not InStr(F$, "\") Then F$ = GetSystemDir$() & F$
If Not InStr(F$, "FOT") > 0 Then ReadFontInfo$ = F$: Exit Function
If Not Exists%(F$) Then MsgBox "Can't find" + F$
lf% = FileLen(F$)
' Debug.Print F$; lf%
Dim GetStuff As String * 5000
Open F$ For Input As fh%
On Error Resume Next
GetStuff = Input$(lf%, #fh%)
B$ = Left$(GetStuff, lf%)
On Error GoTo 0
Close fh%
If Len(B$) < 260 Then MsgBox "Can't read " & F$: Exit Function
B$ = Right$(B$, 260)
For X% = 1 To Len(B$)
   test$ = Mid$(B$, X%, 1)
   If Asc(test$) > 31 And Asc(test$) < 127 Then
      A$ = A$ + Mid$(B$, X%, 1)
   End If
   If Asc(test$) = 0 Then A$ = A$ + "|"
Next
'trim v|'s
X% = InStr(A$, "v|")
Do While X%
   A$ = Mid$(A$, X% + 2)
   X% = InStr(A$, "v|")
Loop
'TRIM LEADERS
If X% > 0 Then A$ = Mid$(A$, X% + 2)
Do While Left$(A$, 1) = "|"
   A$ = Mid$(A$, 2)
Loop
'trim trailers
Do While Right$(A$, 1) = "|"
A$ = Left$(A$, Len(A$) - 1)
Loop
'should now read
ReadFontInfo$ = A$
End Function

Function UninStall% (ByVal fName$)
Dim ret As String * 255
Dim test$, y%
test$ = GetWinINI$("fonts", fName$, "uh-oh")
If test$ = "uh-oh" Then MsgBox "Can't uninstall " & fName$: Exit Function
y% = RemoveFontResource(test$)   '  remove font resource for this file
PutPrivIni "fonts", fName$, test$, "WSFONTS.INI"
DeleteWinIni "fonts", fName$
UninStall% = True
End Function

Function UnsignedInt& (AA$)
'   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
'   Convert string to unsigned int
'   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Dim Value&
Value& = Asc(Right$(AA$, 1)) * 256&
Value& = Value& + Asc(Left$(AA$, 1))
UnsignedInt& = Value&
End Function