Imports System.Runtime.InteropServices
Imports Microsoft.Win32
Module GetFont
' API declarations
Private Declare Auto Function GetVersionEx Lib "kernel32.dll" _
(<MarshalAs(UnmanagedType.Struct)> ByRef osinfo As _
OSVERSIONINFOEX) As Int32
' Structure definition
<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Auto)> _
Private Structure OSVERSIONINFOEX
Public dwOSVersionInfoSize As Int32
Public dwMajorVersion As Int32
Public dwMinorVersion As Int32
Public dwBuildNumber As Int32
Public dwPlatformId As Int32
<VBFixedString(128), MarshalAs( _
UnmanagedType.ByValTStr, SizeConst:=128)> _
Public szCSDVersion As String
Public wServicePackMajor As Int16
Public wServicePackMinor As Int16
Public wSuiteMask As Int16
Public wProductType As Byte
Public wReserved As Byte
End Structure
' Useful constants
Private Const VER_PLATFORM_WIN32s As Int32 = &H0
Private Const VER_PLATFORM_WIN32_WINDOWS As Int32 = &H1
Private Const VER_PLATFORM_WIN32_NT As Int32 = &H2
Private Const VER_NT_WORKSTATION As Int32 = &H1
Private Const VER_NT_SERVER As Int32 = &H3
' Terminal server in remote admin mode
Private VER_SUITE_SINGLEUSERTS As Int32 = &H100&
Private Const VER_SUITE_PERSONAL As Int32 = &H200&
Public Enum WindowsVersion
Undetermined_OS = 0
Obsolete_OS = 1
Windows_98 = 2
Windows_98_SE = 3
Windows_Me = 4
Windows_NT4_Workstation = 5
Windows_NT4_Server = 6
Windows_2000_Pro = 7
Windows_2000_Server = 8
Windows_XP_HomeEdition = 9
Windows_XP_Pro = 10
Windows_Net_Server = 11
End Enum
Public Function GetFontFileName(ByVal FontName$) As String
Dim sAns As String
Dim sErr As String = ""
Dim mykey As String
Dim FileName$ = ""
'Undetermined_OS = 0
'Obsolete_OS = 1
'Windows_98 = 2
'Windows_98_SE = 3
'Windows_Me = 4
'Windows_NT4_Workstation = 5
'Windows_NT4_Server = 6
'Windows_2000_Pro = 7
'Windows_2000_Server = 8
'Windows_XP_HomeEdition = 9
'Windows_XP_Pro = 10
'Windows_Net_Server = 11
'If (getOSVer().ToString()) Then
If (getOSVer() > 4) Then
mykey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts"
Else
mykey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Fonts"
End If
sAns = RegValue(Microsoft.Win32.RegistryHive.LocalMachine, _
mykey, _
FontName$, sErr)
If sAns <> "" Then
Return sAns
Else
'ShowMessage("This error occurred: " & sErr)
sAns = RegValue(Microsoft.Win32.RegistryHive.LocalMachine, _
mykey, _
FontName$ & " (TrueType)", sErr)
If sAns <> "" Then
Return sAns
Else
sAns = RegValue(Microsoft.Win32.RegistryHive.LocalMachine, _
mykey, _
FontName$ & " (All res)", sErr)
If sAns <> "" Then
Return sAns
Else
Return ""
End If
End If
End If
End Function
Public Function getOSVer() As WindowsVersion
Dim osv As OSVERSIONINFOEX
osv.dwOSVersionInfoSize = Marshal.SizeOf(osv)
If GetVersionEx(osv) = 1 Then
Select Case osv.dwPlatformId
Case Is = VER_PLATFORM_WIN32s 'windows 3.x
Return WindowsVersion.Obsolete_OS
Case Is = VER_PLATFORM_WIN32_WINDOWS
Select Case osv.dwMinorVersion
Case Is = 0 'win 95
Return WindowsVersion.Obsolete_OS
Case Is = 10
If InStr(UCase(osv.szCSDVersion), "A") > 0 Then
Return WindowsVersion.Windows_98_SE
Else
Return WindowsVersion.Windows_98
End If
Case Is = 90
Return WindowsVersion.Windows_Me
End Select
Case Is = VER_PLATFORM_WIN32_NT
Select Case osv.dwMajorVersion
Case Is = 3 'win nt 3.x
Return WindowsVersion.Obsolete_OS
Case Is = 4
If osv.wProductType = VER_NT_WORKSTATION Then
Return WindowsVersion.Windows_NT4_Workstation
Else
Return WindowsVersion.Windows_NT4_Server
End If
Case Is = 5
Select Case osv.dwMinorVersion
Case Is = 0 'win 2000
Select Case osv.wProductType
Case Is = VER_NT_WORKSTATION
Return WindowsVersion.Windows_2000_Pro
Case Is = VER_NT_SERVER
Return WindowsVersion.Windows_2000_Server
End Select
Case Is = 1 'win XP
If osv.wSuiteMask = VER_SUITE_PERSONAL Or osv.wSuiteMask = VER_SUITE_PERSONAL + VER_SUITE_SINGLEUSERTS Then
Return WindowsVersion.Windows_XP_HomeEdition
Else
Return WindowsVersion.Windows_XP_Pro
End If
Case Is = 2 '.Net server
Return WindowsVersion.Windows_Net_Server
End Select
End Select
End Select
End If
End Function
' Registery Part
Public Function RegValue(ByVal Hive As RegistryHive, ByVal Key As String, ByVal ValueName As String, Optional ByRef ErrInfo As String = "") As String
'DEMO USAGE
'Dim sAns As String
'Dim sErr As String = ""
'sAns = RegValue(RegistryHive.LocalMachine, _
' "SOFTWARE\Microsoft\Windows\CurrentVersion", _
' "ProgramFilesDir", sErr)
'If sAns <> "" Then
' Debug.WriteLine("File Name = " & sAns)
'Else
' Debug.WriteLine("This error occurred: " & sErr)
'End If
Dim objParent As RegistryKey
Dim objSubkey As RegistryKey
Dim sAns As String
Select Case Hive
Case RegistryHive.ClassesRoot
objParent = Registry.ClassesRoot
Case RegistryHive.CurrentConfig
objParent = Registry.CurrentConfig
Case RegistryHive.CurrentUser
objParent = Registry.CurrentUser
Case RegistryHive.DynData
objParent = Registry.DynData
Case RegistryHive.LocalMachine
objParent = Registry.LocalMachine
Case RegistryHive.PerformanceData
objParent = Registry.PerformanceData
Case RegistryHive.Users
objParent = Registry.Users
End Select
Try
objSubkey = objParent.OpenSubKey(Key)
'if can't be found, object is not initialized
If Not objSubkey Is Nothing Then
sAns = (objSubkey.GetValue(ValueName))
End If
Catch ex As Exception
ErrInfo = ex.Message
Finally
'if no error but value is empty, populate errinfo
If ErrInfo = "" And sAns = "" Then
ErrInfo = _
"No value found for requested registry key"
End If
End Try
Return sAns
End Function
End Module
Submit an article or tip