File: Microsoft\VisualBasic\Information.vb
Web Access
Project: src\src\libraries\Microsoft.VisualBasic.Core\src\Microsoft.VisualBasic.Core.vbproj (Microsoft.VisualBasic.Core)
' Licensed to the .NET Foundation under one or more agreements.
' The .NET Foundation licenses this file to you under the MIT license.
 
Imports System
Imports Microsoft.VisualBasic.CompilerServices
Imports Microsoft.VisualBasic.CompilerServices.ExceptionUtils
Imports Microsoft.VisualBasic.CompilerServices.Utils
 
Namespace Microsoft.VisualBasic
 
    Public Module Information
 
        'QBColorTable below consists of :
        '&H0I,       '   0 - black
        '&H800000I,  '   1 - blue
        '&H8000I,    '   2 - green
        '&H808000I,  '   3 - cyan
        '&H80I,      '   4 - red
        '&H800080I,  '   5 - magenta
        '&H8080I,    '   6 - yellow
        '&HC0C0C0I,  '   7 - white
        '&H808080I,  '   8 - gray
        '&HFF0000I,  '   9 - light blue
        '&HFF00I,    '  10 - light green
        '&HFFFF00I,  '  11 - light cyan
        '&HFFI,      '  12 - light red
        '&HFF00FFI,  '  13 - light magenta
        '&HFFFFI,    '  14 - light yellow
        '&HFFFFFFI,  '  15 - bright white
        Private ReadOnly QBColorTable() As Integer = {&H0I, &H800000I, &H8000I, &H808000I,
                                                        &H80I, &H800080I, &H8080I,
                                                        &HC0C0C0I, &H808080I, &HFF0000I,
                                                        &HFF00I, &HFFFF00I, &HFFI,
                                                        &HFF00FFI, &HFFFFI, &HFFFFFFI}
        Friend Const COMObjectName As String = "__ComObject"
 
        '============================================================================
        ' Error functions.
        '============================================================================
        Public Function Err() As ErrObject
 
            Dim oProj As ProjectData
            oProj = ProjectData.GetProjectData()
 
            If oProj.m_Err Is Nothing Then
                oProj.m_Err = New ErrObject
            End If
            Err = oProj.m_Err
 
        End Function
 
        Public Function Erl() As Integer
            Dim oProj As ProjectData
            oProj = ProjectData.GetProjectData()
            Erl = oProj.m_Err.Erl
        End Function
 
        Public Function IsArray(ByVal VarName As Object) As Boolean
 
            If VarName Is Nothing Then
                Return False
            End If
 
            Return (TypeOf VarName Is System.Array)
 
        End Function
 
        Public Function IsDate(ByVal Expression As Object) As Boolean
 
            If Expression Is Nothing Then
                Return False
            End If
 
            If TypeOf Expression Is Date Then
 
                Return True
 
            Else
                Dim stringExpression As String = TryCast(Expression, String)
 
                If stringExpression IsNot Nothing Then
                    Dim convertedDate As DateTime
 
                    Return Conversions.TryParseDate(stringExpression, convertedDate)
                End If
            End If
 
            Return False
 
        End Function
 
        Public Function IsDBNull(ByVal Expression As Object) As Boolean
 
            If Expression Is Nothing Then
                Return False
 
            ElseIf TypeOf Expression Is System.DBNull Then
                Return True
 
            Else
                Return False
 
            End If
 
        End Function
 
        Public Function IsNothing(ByVal Expression As Object) As Boolean
 
            Return (Expression Is Nothing)
 
        End Function
 
        Public Function IsError(ByVal Expression As Object) As Boolean
 
            If Expression Is Nothing Then
                Return False
            End If
 
            Return (TypeOf Expression Is Exception)
 
        End Function
 
        Public Function IsReference(ByVal Expression As Object) As Boolean
 
            Return Not (TypeOf Expression Is System.ValueType)
 
        End Function
 
        Public Function LBound(ByVal Array As System.Array, Optional ByVal Rank As Integer = 1) As Integer
 
            If (Array Is Nothing) Then
                Throw VbMakeException(New ArgumentNullException(NameOf(Array)), vbErrors.OutOfBounds)
 
            ElseIf (Rank < 1) OrElse (Rank > Array.Rank) Then
                Throw New RankException(SR.Format(SR.Argument_InvalidRank1, NameOf(Rank)))
 
            End If
 
            Return Array.GetLowerBound(Rank - 1)
 
        End Function
 
        Public Function UBound(ByVal Array As System.Array, Optional ByVal Rank As Integer = 1) As Integer
 
            If (Array Is Nothing) Then
                Throw VbMakeException(New ArgumentNullException(NameOf(Array)), vbErrors.OutOfBounds)
 
            ElseIf (Rank < 1) OrElse (Rank > Array.Rank) Then
                Throw New RankException(SR.Format(SR.Argument_InvalidRank1, NameOf(Rank)))
 
            End If
 
            Return Array.GetUpperBound(Rank - 1)
 
        End Function
 
        Friend Function TypeNameOfCOMObject(ByVal VarName As Object, ByVal bThrowException As Boolean) As String
 
            Dim Result As String = COMObjectName
 
#If TARGET_WINDOWS Then
            Dim pTypeInfo As UnsafeNativeMethods.ITypeInfo = Nothing
            Dim hr As Integer
            Dim ClassName As String = Nothing
            Dim DocString As String = Nothing
            Dim HelpContext As Integer
            Dim HelpFile As String = Nothing
 
 
            Do
                Dim pProvideClassInfo As UnsafeNativeMethods.IProvideClassInfo = TryCast(VarName, UnsafeNativeMethods.IProvideClassInfo)
 
                If pProvideClassInfo IsNot Nothing Then
                    Try
                        pTypeInfo = pProvideClassInfo.GetClassInfo()
                        hr = pTypeInfo.GetDocumentation(-1, ClassName, DocString, HelpContext, HelpFile)
                        If hr >= 0 Then
                            Result = ClassName
                            Exit Do
                        End If
                        pTypeInfo = Nothing
                    Catch ex As StackOverflowException
                        Throw ex
                    Catch ex As OutOfMemoryException
                        Throw ex
                    Catch
                        'Ignore the error
                    End Try
                End If
 
                Dim pDispatch As UnsafeNativeMethods.IDispatch = TryCast(VarName, UnsafeNativeMethods.IDispatch)
 
                If pDispatch IsNot Nothing Then
                    ' Try using IDispatch 
                    hr = pDispatch.GetTypeInfo(0, UnsafeNativeMethods.LCID_US_ENGLISH, pTypeInfo)
                    If hr >= 0 Then
                        hr = pTypeInfo.GetDocumentation(-1, ClassName, DocString, HelpContext, HelpFile)
                        If hr >= 0 Then
                            Result = ClassName
                            Exit Do
                        End If
                    End If
                End If
 
            Loop While (False)
#End If
 
 
            If Result.Chars(0) = "_"c Then
                Result = Result.Substring(1)
            End If
 
            Return Result
        End Function
 
        Public Function QBColor(ByVal Color As Integer) As Integer
            If (Color And &HFFF0I) <> 0 Then
                Throw New ArgumentException(SR.Format(SR.Argument_InvalidValue1, NameOf(Color)), NameOf(Color))
            End If
 
            Return QBColorTable(Color)
        End Function
 
        Public Function RGB(ByVal Red As Integer, ByVal Green As Integer, ByVal Blue As Integer) As Integer
            If (Red And &H80000000I) <> 0 Then
                Throw New ArgumentException(SR.Format(SR.Argument_InvalidValue1, NameOf(Red)), NameOf(Red))
            ElseIf (Green And &H80000000I) <> 0 Then
                Throw New ArgumentException(SR.Format(SR.Argument_InvalidValue1, NameOf(Green)), NameOf(Green))
            ElseIf (Blue And &H80000000I) <> 0 Then
                Throw New ArgumentException(SR.Format(SR.Argument_InvalidValue1, NameOf(Blue)), NameOf(Blue))
            End If
 
            ' VB2 treats any value > 255 as 255
 
            If (Red > 255) Then
                Red = &HFFI
            End If
 
            If (Green > 255) Then
                Green = &HFFI
            End If
 
            If (Blue > 255) Then
                Blue = &HFFI
            End If
 
            Return ((Blue * &H10000I) + (Green * &H100I) + Red)
        End Function
 
        Public Function VarType(ByVal VarName As Object) As VariantType
            If VarName Is Nothing Then
                Return VariantType.Object
            End If
 
            Return VarTypeFromComType(VarName.GetType())
        End Function
 
        Friend Function VarTypeFromComType(ByVal typ As System.Type) As VariantType
            If typ Is Nothing Then
                Return VariantType.Object
            End If
 
            If typ.IsArray() Then
 
                typ = typ.GetElementType()
                If typ.IsArray Then
                    Return CType(VariantType.Array Or VariantType.Object, VariantType)
                End If
 
                Dim result As VariantType = VarTypeFromComType(typ)
                If (result And VariantType.Array) <> 0 Then
                    'Element type is also an array, so just return "array of objects"
                    Return CType(VariantType.Array Or VariantType.Object, VariantType)
                End If
                Return CType(result Or VariantType.Array, VariantType)
 
            ElseIf typ.IsEnum() Then
                typ = System.Enum.GetUnderlyingType(typ)
            End If
 
            If typ Is Nothing Then
                Return VariantType.Empty
            End If
 
            Select Case Type.GetTypeCode(typ)
 
                Case TypeCode.String
                    Return VariantType.String
                Case TypeCode.Int32
                    Return VariantType.Integer
                Case TypeCode.Int16
                    Return VariantType.Short
                Case TypeCode.Int64
                    Return VariantType.Long
                Case TypeCode.Single
                    Return VariantType.Single
                Case TypeCode.Double
                    Return VariantType.Double
                Case TypeCode.DateTime
                    Return VariantType.Date
                Case TypeCode.Boolean
                    Return VariantType.Boolean
                Case TypeCode.Decimal
                    Return VariantType.Decimal
                Case TypeCode.Byte
                    Return VariantType.Byte
                Case TypeCode.Char
                    Return VariantType.Char
                Case TypeCode.DBNull
                    Return VariantType.Null
 
            End Select
 
            If (typ Is GetType(System.Reflection.Missing)) OrElse
               (typ Is GetType(System.Exception)) OrElse
               (typ.IsSubclassOf(GetType(System.Exception))) Then
                Return VariantType.Error
            ElseIf typ.IsValueType() Then
                Return VariantType.UserDefinedType
            Else
                Return VariantType.Object
            End If
 
        End Function
 
        Friend Function IsOldNumericTypeCode(ByVal TypCode As System.TypeCode) As Boolean
 
            Select Case TypCode
 
                Case TypeCode.Int16,
                     TypeCode.Int32,
                     TypeCode.Int64,
                     TypeCode.Single,
                     TypeCode.Double,
                     TypeCode.Boolean,
                     TypeCode.Decimal,
                     TypeCode.Byte
                    Return True
 
                Case Else
                    Return False
 
            End Select
 
        End Function
 
        Public Function IsNumeric(ByVal Expression As Object) As Boolean
 
            Dim valueInterface As IConvertible
            Dim valueTypeCode As TypeCode
 
            valueInterface = TryCast(Expression, IConvertible)
 
            If valueInterface Is Nothing Then
                Dim charArray As Char() = TryCast(Expression, Char())
 
                If charArray IsNot Nothing Then
                    Expression = CStr(charArray)
                Else
                    Return False
                End If
            End If
 
            valueTypeCode = valueInterface.GetTypeCode()
 
            If (valueTypeCode = TypeCode.String) OrElse (valueTypeCode = TypeCode.Char) Then
 
                'Convert to double, exception thrown if not a number
                Dim dbl As Double
                Dim i64Value As Int64
                Dim value As String
 
                value = valueInterface.ToString(Nothing)
 
                Try
                    If IsHexOrOctValue(value, i64Value) Then
                        Return True
                    End If
                Catch ex As StackOverflowException
                    Throw ex
                Catch ex As OutOfMemoryException
                    Throw ex
                Catch
                    Return False
                End Try
 
                Return DoubleType.TryParse(value, dbl)
 
            End If
 
            Return IsOldNumericTypeCode(valueTypeCode)
 
        End Function
 
        Friend Function OldVBFriendlyNameOfTypeName(ByVal typename As String) As String
            Dim ArraySuffix As String = Nothing
            Dim Name As String
            Dim LastChar As Integer = typename.Length - 1
 
            If typename.Chars(LastChar) = "]"c Then
                Dim pos As Integer
                pos = typename.IndexOf("["c)
                If pos + 1 = LastChar Then
                    ArraySuffix = "()"
                Else
                    ArraySuffix = typename.Substring(pos, LastChar - pos + 1).Replace("["c, "("c).Replace("]"c, ")"c)
                End If
                typename = typename.Substring(0, pos)
            End If
 
            Name = OldVbTypeName(typename)
            If Name Is Nothing Then
                Name = typename
            End If
 
            If ArraySuffix Is Nothing Then
                Return Name
            End If
            Return Name & AdjustArraySuffix(ArraySuffix)
 
        End Function
 
        Public Function TypeName(ByVal VarName As Object) As String
 
            Dim Result As String
            Dim bIsArray As Boolean
            Dim typ As System.Type
            Dim ArrayType As System.Type
 
            If VarName Is Nothing Then
                Return "Nothing"
            End If
 
            typ = VarName.GetType()
 
            If typ.IsArray Then
                bIsArray = True
                ArrayType = typ
                typ = ArrayType.GetElementType()
            End If
 
            If typ.IsEnum() Then
 
                Result = typ.Name
                GoTo UnmangleName
 
            Else
                Dim tc As TypeCode
 
                tc = Type.GetTypeCode(typ)
 
                Select Case tc
 
                    Case TypeCode.DBNull : Result = "DBNull"
                    Case TypeCode.Int16 : Result = "Short"
                    Case TypeCode.Int32 : Result = "Integer"
                    Case TypeCode.Single : Result = "Single"
                    Case TypeCode.Double : Result = "Double"
                    Case TypeCode.DateTime : Result = "Date"
                    Case TypeCode.String : Result = "String"
                    Case TypeCode.Boolean : Result = "Boolean"
                    Case TypeCode.Decimal : Result = "Decimal"
                    Case TypeCode.Byte : Result = "Byte"
                    Case TypeCode.Char : Result = "Char"
                    Case TypeCode.Int64 : Result = "Long"
 
                    Case Else
 
                        Result = typ.Name
 
                        If (typ.IsCOMObject AndAlso (System.String.CompareOrdinal(Result, COMObjectName) = 0)) Then
                            Result = LegacyTypeNameOfCOMObject(VarName, True)
                        End If
 
UnmangleName:
                        Dim i As Integer
                        i = Result.IndexOf("+"c)
                        If i >= 0 Then
                            Result = Result.Substring(i + 1)
                        End If
 
                End Select
 
            End If
 
            If bIsArray Then
 
                Dim ary As Array
                ary = CType(VarName, Array)
                If ary.Rank = 1 Then
                    Result = Result & "[]"
                Else
                    Result = Result & "[" & (New String(","c, ary.Rank - 1)) & "]"
                End If
 
                Result = OldVBFriendlyNameOfTypeName(Result)
 
            End If
 
            Return Result
        End Function
 
        Public Function SystemTypeName(ByVal VbName As String) As String
 
            Select Case Trim(VbName).ToUpperInvariant()
                Case "OBJECT" : Return "System.Object"
                Case "SHORT" : Return "System.Int16"
                Case "INTEGER" : Return "System.Int32"
                Case "SINGLE" : Return "System.Single"
                Case "DOUBLE" : Return "System.Double"
                Case "DATE" : Return "System.DateTime"
                Case "STRING" : Return "System.String"
                Case "BOOLEAN" : Return "System.Boolean"
                Case "DECIMAL" : Return "System.Decimal"
                Case "BYTE" : Return "System.Byte"
                Case "CHAR" : Return "System.Char"
                Case "LONG" : Return "System.Int64"
                Case Else : Return Nothing
            End Select
 
        End Function
 
        Public Function VbTypeName(ByVal UrtName As String) As String
            Return OldVbTypeName(UrtName)
        End Function
 
        Friend Function OldVbTypeName(ByVal UrtName As String) As String
 
            UrtName = Trim(UrtName).ToUpperInvariant()
            If Left(UrtName, 7) = "SYSTEM." Then
                UrtName = Mid(UrtName, 8)
            End If
 
            Select Case UrtName
                Case "OBJECT" : Return "Object"
                Case "INT16" : Return "Short"
                Case "INT32" : Return "Integer"
                Case "SINGLE" : Return "Single"
                Case "DOUBLE" : Return "Double"
                Case "DATETIME" : Return "Date"
                Case "STRING" : Return "String"
                Case "BOOLEAN" : Return "Boolean"
                Case "DECIMAL" : Return "Decimal"
                Case "BYTE" : Return "Byte"
                Case "CHAR" : Return "Char"
                Case "INT64" : Return "Long"
                Case Else
                    Return Nothing
            End Select
 
        End Function
 
        Friend Function LegacyTypeNameOfCOMObject(ByVal VarName As Object, ByVal bThrowException As Boolean) As String
 
            Dim Result As String = COMObjectName
 
#If TARGET_WINDOWS Then
            Dim pTypeInfo As UnsafeNativeMethods.ITypeInfo = Nothing
            Dim hr As Integer
            Dim ClassName As String = Nothing
            Dim DocString As String = Nothing
            Dim HelpContext As Integer
            Dim HelpFile As String = Nothing
 
            Dim pDispatch As UnsafeNativeMethods.IDispatch = TryCast(VarName, UnsafeNativeMethods.IDispatch)
 
            If pDispatch IsNot Nothing Then
                hr = pDispatch.GetTypeInfo(0, UnsafeNativeMethods.LCID_US_ENGLISH, pTypeInfo)
                If hr >= 0 Then
                    hr = pTypeInfo.GetDocumentation(-1, ClassName, DocString, HelpContext, HelpFile)
                    If hr >= 0 Then
                        Result = ClassName
                    End If
                End If
            End If
#End If
 
            If Result.Chars(0) = "_"c Then
                Result = Result.Substring(1)
            End If
 
            Return Result
        End Function
 
    End Module
 
End Namespace