environment.cls

VB 加密----------能够加密解密控件

'
' @return An array of command line Arguments, including the application name.
' @remarks The application is the first Argument in the array. Arguments are
' separated by spaces. If spaces are embedded in an Arguments and should not
' be used to separate the Arguments, then the Arguments must be surrounded in quotes.
'
Public Function GetCommandLineArgs() As String()
    GetCommandLineArgs = ParseCommandLineArgs(CommandLine)
End Function

''
' Provides a mechanism to parse arguments from a command line string.
'
' @param Line The string to parse the arguments from.
' @return An array of arguments.
'
Public Function ParseCommandLineArgs(ByVal Line As String) As String()
    Line = Trim$(Line)
    Dim Length As Long
    Length = Len(Line)
    
    If Length = 0 Then
        ParseCommandLineArgs = Cor.NewStrings
        Exit Function
    End If
    
    Dim Arguments As New ArrayList
    
    Dim Chars() As Integer
    Chars = cString.ToCharArray(Line)
    
    Dim ArgBuffer() As Integer
    ReDim ArgBuffer(0 To Length - 1)
    
    Dim ArgIndex    As Long
    Dim Escaped     As Boolean
    Dim Quoted      As Boolean
    Dim Index       As Long
    Do While Index < Length
        Select Case Chars(Index)
            Case vbBackSlash
                If Escaped Then
                    ' We have two back slashes in a row,
                    ' so we actually need to include them
                    ' as part of the argument.
                    ArgBuffer(ArgIndex) = vbBackSlash
                    ArgBuffer(ArgIndex + 1) = vbBackSlash
                    ArgIndex = ArgIndex + 2
                    Escaped = False
                Else
                    ' Begin the potential escape sequence.
                    ' We only support escaping double quotes.
                    Escaped = True
                End If
            
            Case vbDoubleQuote
                If Escaped Then
                    ' We are escaping a quote, so it is to
                    ' be included in the argument, but not
                    ' the backslash.
                    ArgBuffer(ArgIndex) = vbDoubleQuote
                    ArgIndex = ArgIndex + 1
                    Escaped = False
                    
                    ' We don't end a quoted argument with
                    ' an escaped quote, so let the Quoted
                    ' flag remain as is.
                    
                ElseIf Quoted Then
                    ' We are already in quotes, and so we need
                    ' to determine if we have two quotes in a row.
                    ' If so, then one double quote will be added
                    ' to the argument as if it were escaped.
                    
                    ' Do we have enough character left?
                    If Index + 1 < Length Then
                        ' We have enough, so check for 2nd quote.
                        If Chars(Index + 1) = vbDoubleQuote Then
                            ' We have two quotes, so escape it.
                            ArgBuffer(ArgIndex) = vbDoubleQuote
                            ArgIndex = ArgIndex + 1
                        End If
                    End If
                    
                    Quoted = False
                Else
                    ' We are starting a quoted section
                    Quoted = True
                End If
                
            Case vbSpace
                If Quoted Then
                    ' Being quoted, so include spaces in the argument.
                    ArgBuffer(ArgIndex) = vbSpace
                    ArgIndex = ArgIndex + 1
                Else
                    ' Done with the argument, so add it to the list.
                    Call Arguments.Add(SysAllocStringLen(VarPtr(ArgBuffer(0)), ArgIndex))
                    ArgIndex = 0
                End If
                
                Escaped = False
                
            Case Else
                ArgBuffer(ArgIndex) = Chars(Index)
                ArgIndex = ArgIndex + 1
                Escaped = False
        End Select
        
        Index = Index + 1
    Loop
                
    If ArgIndex > 0 Then Call Arguments.Add(SysAllocStringLen(VarPtr(ArgBuffer(0)), ArgIndex))
    
    ParseCommandLineArgs = Arguments.ToArray(ciString)
End Function

''
' Returns an environment variable value.
'
' @param Name The name of the environment variable to return.
' @param Target The system region to retrieve the variable from.
' @return The value of the environment variable.
' @remarks If the variable does not exist, then an empty string is returned.
' <p>A Target of Process will retrieve the variable from the current process. Other
' targets will retrieve the variable value from the registry.</p>
'
Public Function GetEnvironmentVariable(ByVal Name As String, Optional ByVal Target As EnvironmentVariableTarget = EnvironmentVariableTarget.Process) As String
    Dim rk As RegistryKey
    
    Select Case Target
        Case EnvironmentVariableTarget.Process
            ' use the GetEnvironmentVariable api to allow for realtime
            ' updating of the environment variables for the current
            ' process. VB's Environ does not reflect variable changes.
            Dim Size As Long
            Size = 128
            Do
                Dim Buf As String
                Buf = String$(Size, 0)
                Size = API.GetEnvironmentVariable(Name, Buf, Len(Buf))
                If Size = 0 Then
                    Dim Result As Long
                    Result = Err.LastDllError
                    If Result = ERROR_ENVVAR_NOT_FOUND Or (Result = 0) Then Exit Function
                    IOError Result, "Name"
                End If
            Loop While Size > Len(Buf)
            GetEnvironmentVariable = Left$(Buf, Size)
            
        Case EnvironmentVariableTarget.Machine
            Call VerifyNTMachine
            Set rk = Registry.LocalMachine.OpenSubKey("system\currentcontrolset\control\session manager\environment")
            GetEnvironmentVariable = rk.GetValue(Name, vbNullString)
            
        Case EnvironmentVariableTarget.User
            Call VerifyNTMachine
            Set rk = Registry.CurrentUser.OpenSubKey("environment")
            GetEnvironmentVariable = rk.GetValue(Name, vbNullString)
            
        Case Else
            Throw Cor.NewArgumentException("Invalid Target value.", "Target")
    End Select
End Function

''
' Returns an IDictionary object containing all environment variables as name/value pairs.
'
' @param Target The system region to retrieve the environment variable from.
' @return A dictionary containing the name/value pairs.
' @remarks The hidden environment variables are not included in the dictionary.
' <p>A Target of Process will retrieve the variable from the current process. Other
' targets will retrieve the variable value from the registry.</p>
'
Public Function GetEnvironmentVariables(Optional ByVal Target As EnvironmentVariableTarget = Process) As IDictionary
    Dim Ret As New Hashtable
    Dim rk  As RegistryKey
    
    If Target = EnvironmentVariableTarget.Process Then
        ' use the GetEnvironmentStrings api to allow for realtime
        ' updating of the environment variables for the current
        ' process. VB's Environ does not reflect variable changes.
        Set Ret = InternalGetEnvironmentVariables
    Else
        Call VerifyNTMachine
        Select Case Target
            Case EnvironmentVariableTarget.Machine: Set rk = Registry.LocalMachine.OpenSubKey("system\currentcontrolset\control\session manager\environment")
            Case EnvironmentVariableTarget.User:    Set rk = Registry.CurrentUser.OpenSubKey("environment")
            Case Else: Throw Cor.NewArgumentException("Invalid Target value.", "Target")
        End Select
        
        Dim Names() As String
        Names = rk.GetValueNames
        
        Dim i As Long
        For i = 0 To UBound(Names)
            Call Ret.Add(Names(i), rk.GetValue(Names(i)))
        Next i
    End If
    
    Set GetEnvironmentVariables = Ret
End Function

''
' Returns the path for a specified folder type.
'
' @param Folder The folder to return the path of.
' @return The path for the specified folder.
'
Public Function GetFolderPath(ByVal Folder As SpecialFolder) As String
    Dim Buf As String
    
    Buf = String$(MAX_PATH, 0)
    Call SHGetFolderPath(0, Folder, 0, 0, Buf)
    GetFolderPath = SysAllocString(StrPtr(Buf))
End Function

''
' Returns the logical drives installed on the local machine.
'
' @return An array containing all of the logical drives installed.
'
Public Function GetLogicalDrives() As String()
    GetLogicalDrives = Directory.GetLogicalDrives
End Function

''
' Sets, creates, or deletes an environment variable in the specified region.
'
' @param Variable The name of the variable to set the value for.
' @param Value The value of the variable.
' @param Target The region the variable is located in the system.
' @remarks Setting the variable in the Process region only affects the current
' process that is setting the variable. Setting a variable in a User or Machine
' region will set the values in the registry.
' <p>by setting the value to an empty string, the variable will be deleted.</p>
'
Public Sub SetEnvironmentVariable(ByVal Variable As String, ByVal Value As String, Optional ByVal Target As EnvironmentVariableTarget = Process)
    If Len(Variable) = 0 Then _
        Throw Cor.NewArgumentException("Variable name cannot be an empty string.", "Variable")
    If InStr(Variable, "=") > 0 Then _
        Throw Cor.NewArgumentException("Variable name cannot contain an equal '=' sign.", "Variable")
    If Len(Variable) > 255 Then _
        Throw Cor.NewArgumentException("Variable name cannot exceed 255 characters.", "Variable")
    If Len(Value) > 32767 Then _
        Throw Cor.NewArgumentException("Value cannot exceed a length of 32767 characters including the terminating null.", "Value")
    
    Select Case Target
        Case EnvironmentVariableTarget.Process
            If API.SetEnvironmentVariable(Variable, Value) = BOOL_FALSE Then _
                Throw Cor.NewArgumentException(GetErrorMessage(Err.LastDllError), "Value")
                
        Case EnvironmentVariableTarget.Machine, EnvironmentVariableTarget.User
            Call VerifyNTMachine
            
            Dim rk As RegistryKey
            If Target = EnvironmentVariableTarget.Machine Then
                Set rk = Registry.LocalMachine.OpenSubKey("system\currentcontrolset\control\session manager\environment", True)
            Else
                Set rk = Registry.CurrentUser.OpenSubKey("environment", True)
            End If
            
            If Len(Value) > 0 Then
                Call rk.SetValue(Variable, Value)
            Else
                Call rk.DeleteValue(Variable, False)
            End If
            
            Call SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, StrPtr("Environment"), SMTO_NORMAL, 1000, 0)
            
        Case Else
            Throw Cor.NewArgumentException("Invalid target specified.", "Target")
    End Select
End Sub

''
' Returns the number of processors on the current machine.
'
' @return The processor count.
' @remarks This method counts the number of process subkey entries
' located in the 'Hardware\Description\System\CentralProcessor'
' region of the HKEY_LOCAL_MACHINE registry key.
'
Public Property Get ProcessorCount() As Long
    Dim rk As RegistryKey
    Set rk = Registry.LocalMachine.OpenSubKey("Hardware\Description\System\CentralProcessor")
    ProcessorCount = rk.SubKeyCount
End Property



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Friend Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Friend Function GetResourceString(ByVal resId As Long, ParamArray args() As Variant) As String
    Dim vArgs() As Variant
    Call Helper.Swap4(ByVal ArrPtr(vArgs), ByVal Helper.DerefEBP(16))
    GetResourceString = cString.FormatArray(LoadResString(resId), vArgs)
End Function

Friend Sub VerifyNTMachine()
    If Not IsNT Then
        Throw Cor.NewNotSupportedException("This operation is only supported on Windows NT platforms.")
    End If
End Sub

Friend Function IsNT() As Boolean
    IsNT = (mOSVersion.Platform = Win32NT)
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' we need to use the GetEnvironmentStrings API method instead of
' iterating through the variables using Environ because Environ
' does not reflect changes to the variables after the application starts.
Private Function InternalGetEnvironmentVariables() As IDictionary
    Dim Strings() As String
    Strings() = Split(API.GetEnvironmentStrings, vbNullChar)
    
    Dim Ret As New Hashtable
    Dim i   As Long
    For i = 0 To UBound(Strings)
        If Asc(Strings(i)) <> vbEqual Then
            Dim Parts() As String
            Parts = Split(Strings(i), "=")
            
            Call Ret.Add(Trim$(Parts(0)), Trim$(Parts(1)))
        End If
    Next i
    
    Set InternalGetEnvironmentVariables = Ret
End Function