Public Structure ThemeInfo
Private Declare Unicode Function GetCurrentThemeName Lib "uxtheme.dll" ( _
ByVal pszThemeFileName As String, _
ByVal dwMaxNameChars As Int32, _
ByVal pszColorBuff As String, _
ByVal cchMaxColorChars As Int32, _
ByVal pszSizeBuff As String, _
ByVal cchMaxSizeChars As Int32 _
) As Int32
Private Const S_OK As Int32 = &H0
Private m_FileName As String
Private m_ColorSchemeName As String
Private m_SizeName As String
Public Property FileName() As String
Get
Return m_FileName
End Get
Set(ByVal Value As String)
m_FileName = Value
End Set
End Property
Public Property ColorSchemeName() As String
Get
Return m_ColorSchemeName
End Get
Set(ByVal Value As String)
m_ColorSchemeName = Value
End Set
End Property
Public Property SizeName() As String
Get
Return m_SizeName
End Get
Set(ByVal Value As String)
m_SizeName = Value
End Set
End Property
Public Overrides Function ToString() As String
Return _
"FileName={" & Me.FileName & _
"} ColorSchemeName={" & Me.ColorSchemeName & _
"} SizeName={" & Me.SizeName & "}"
End Function
Public Shared ReadOnly Property CurrentTheme() As ThemeInfo
Get
Dim ti As New ThemeInfo()
Const BufferLength As Int32 = 256
ti.FileName = Strings.Space(BufferLength)
ti.ColorSchemeName = ti.FileName
ti.SizeName = ti.FileName
If _
GetCurrentThemeName( _
ti.FileName, _
BufferLength, _
ti.ColorSchemeName, _
BufferLength, _
ti.SizeName, _
BufferLength _
) = S_OK _
Then
ti.FileName = NullTrim(ti.FileName)
ti.ColorSchemeName = NullTrim(ti.ColorSchemeName)
ti.SizeName = NullTrim(ti.SizeName)
Return ti
Else
Const Message As String = _
"An error occured when attempting to get theme info."
Throw New Exception(Message)
End If
End Get
End Property
Private Shared Function NullTrim(ByVal Text As String) As String
Return _
Strings.Left( _
Text, _
Strings.InStr(Text, ControlChars.NullChar) - 1 _
)
End Function
End Structure