Mail:  Username:  Password:   Help | Sign Up
Search: 

Rename Recycle Bin
by Tau

Purpose:
The code will rename the Recyle Bin according to what the user enters in an Inpput Box. After setting the proper registry setting it will minimize all open windows and 'press' F5 to refresh the desktop.

Requirements:
This code requires a Command Button named Command1 which can be modified in the last Sub.

System:
This code will function on Visual Basic versions 5.0 and 6.0, and is to be used with no BAS file.



Private Declare Function RegOpenKey& Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long)
Private Declare Function RegOpenKeyEx& Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey&, ByVal lpszSubKey$, ByVal dwOptions&, ByVal samDesired&, lpHKey&)
Private Declare Function RegSetValueEx& Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal dwRes&, ByVal dwType&, lpDataBuff As Any, ByVal nSize&)
Private Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey&)
Private Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function GetTickCount& Lib "kernel32" ()

Const WM_COMMAND = &H111
Const MIN_ALL = 419
Const VK_F5 = &H74

Const ERROR_SUCCESS = 0&
'Registry Read/Write permissions:
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or _
KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ




Private Function GetMainKeyHandle(ByVal sMainKey As String) As Long

'Returns the handle of the main key (the constants below)

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

Select Case sMainKey
    Case "HKEY_CLASSES_ROOT"
        GetMainKeyHandle = HKEY_CLASSES_ROOT
    Case "HKEY_CURRENT_USER"
        GetMainKeyHandle = HKEY_CURRENT_USER
    Case "HKEY_LOCAL_MACHINE"
        GetMainKeyHandle = HKEY_LOCAL_MACHINE
    Case "HKEY_USERS"
        GetMainKeyHandle = HKEY_USERS
    Case "HKEY_PERFORMANCE_DATA"
        GetMainKeyHandle = HKEY_PERFORMANCE_DATA
    Case "HKEY_CURRENT_CONFIG"
        GetMainKeyHandle = HKEY_CURRENT_CONFIG
    Case "HKEY_DYN_DATA"
        GetMainKeyHandle = HKEY_DYN_DATA
End Select

End Function

Private Function GetHKEYHandle(ByRef sKeyName As String) As Long
    
'This sub parses the passed keyname, separates the main HKEY part from
'the rest of the keyname, and returns the main key handle. Every
'Registry API function requires this handle for the HKEY. The rest
'of the keyname is passed to the API reg functions as another argument;
'therefore, we'll separate them in this function. The value returned
'in the sKeyName argument will contain the part of the keyname that
'the API reg functions require. This is the reason the argument is
'passed by reference instead of by value.

'Pass the full path to the key in this format:
'HKEY_CURRENT_USER\Control Panel\Desktop

Dim lKeyHandle As Long
Dim nBackSlash As Integer

'A simple check to make sure the key was passed correctly
If Left(sKeyName, 5) <> "HKEY_" Or Right(sKeyName, 1) = "\" Then
    MsgBox "Incorrect Format:" & vbCrLf & vbCrLf & sKeyName
    Exit Function
End If

nBackSlash = InStr(sKeyName, "\")
If nBackSlash = 0 Then
    'Only the main key was specified
    lKeyHandle = GetMainKeyHandle(sKeyName)
    sKeyName = ""
Else
    'Get the handle to the main key
    lKeyHandle = GetMainKeyHandle(Left$(sKeyName, nBackSlash - 1))
    'Strip the HKEY part of the keyname away
    sKeyName = Mid$(sKeyName, nBackSlash + 1)
End If

'Make sure the handle is valid (just another check)
If lKeyHandle < &H80000000 Or lKeyHandle > &H80000006 Then
    MsgBox "Not a valid HKEY handle", vbCritical
    lKeyHandle = 0
End If

GetHKEYHandle = lKeyHandle

End Function

Private Function GetRegStringValue(ByVal sKeyName As String, ByVal sSetting As String, ByRef sValue As String, Optional bNoErrMessage As Boolean = True) As Boolean
Dim hKey As Long, hMainKey As Long
Dim lRtn As Long, sBuffer As String
Dim lBufferSize As Long, lType As Long
Dim sErrMsg As String

lType = REG_SZ
    
hMainKey = GetHKEYHandle(sKeyName)

If hMainKey Then
    'Open the key
    lRtn = RegOpenKeyEx(hMainKey, sKeyName, 0&, KEY_READ, hKey)
    If lRtn = ERROR_SUCCESS Then
        'Query for the data
        sBuffer = Space(255)
        lBufferSize = Len(sBuffer)
        lRtn = RegQueryValueEx(hKey, sSetting, 0&, lType, sBuffer, lBufferSize)
        If lRtn = ERROR_SUCCESS Then
            'Remove spaces and eliminate the terminating character
            sBuffer = Trim(sBuffer)
            sValue = Left(sBuffer, Len(sBuffer) - 1)
            GetRegStringValue = True
        Else
            If Not bNoErrMessage Then
                sErrMsg = GetRegError(lRtn)
                MsgBox sErrMsg, vbCritical, "Registry Query Error"
            End If
            GetRegStringValue = False
        End If
    Else
        If Not bNoErrMessage Then
            sErrMsg = GetRegError(lRtn)
            MsgBox sErrMsg, vbCritical, "Registry Open Error"
        End If
    End If
End If

End Function

Private Function GetRegError(ByVal lErrorCode As Long) As String
    
'This function returns the error string associated with error
'codes returned by the Registry API functions

Select Case lErrorCode
    Case 1009, 1015
        'As Doomsday* would say "We're in trouble now!"
        GetRegError = "The Registry Database is corrupt!"
    Case 2, 1010
        GetRegError = "Bad Key Name"
    Case 1011
        GetRegError = "Can't Open Key"
    Case 4, 1012
        GetRegError = "Can't Read Key"
    Case 5
        GetRegError = "Access to this key is denied"
    Case 1013
        GetRegError = "Can't Write Key"
    Case 8, 14
        GetRegError = "Out of memory"
    Case 87
        GetRegError = "Invalid Parameter"
    Case 234
        GetRegError = "There is more data than the buffer has been allocated to hold."
    Case Else
        GetRegError = "Undefined Error Code: " & Str$(lErrorCode)
End Select

'* - Haven't you ever played Wing Commander? :)
End Function

Public Function WriteRegStringValue(ByVal sKeyName As String, sSetting As String, sValue As String, Optional bNoErrMessage As Boolean = True) As Boolean

'Returns True if successful; otherwise False

Dim hKey As Long, hMainKey As Long
Dim lRtn As Long, lDataSize As Long
Dim lType As Long, sErrMsg As String

WriteRegStringValue = False

lType = REG_SZ

hMainKey = GetHKEYHandle(sKeyName)

If hMainKey Then
    'Open the key
    lRtn = RegOpenKeyEx(hMainKey, sKeyName, 0&, KEY_WRITE, hKey)
    If lRtn = ERROR_SUCCESS Then
        'Write the value
        lDataSize = Len(sSetting)
        lRtn = RegSetValueEx(hKey, sSetting, 0&, lType, ByVal sValue, lDataSize)
        If lRtn = ERROR_SUCCESS Then
            WriteRegStringValue = True
        Else
            If Not bNoErrMessage Then
                sErrMsg = GetRegError(lRtn)
                MsgBox sErrMsg, vbCritical, "Registry Write Error"
            End If
            WriteRegStringValue = False
        End If
        lRtn = RegCloseKey(hKey)
    Else
        If Not bNoErrMessage Then
            sErrMsg = GetRegError(lRtn)
            MsgBox sErrMsg, vbCritical, "Registry Open Error"
        End If
        WriteRegStringValue = False
    End If
End If

End Function

Private Sub RenameRecycleBin()
        Dim sRegPath$, NewName$, OldName$
'Obtain the current Recycle Bin name out of the registry to be
'displayed in the Input Box
        sRegPath$ = "HKEY_CLASSES_ROOT\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}"
        Call GetRegStringValue(sRegPath$, vbNullString, OldName$)
'Display the Input Box
        NewName$ = InputBox("What do you want to rename your Recycle Bin?", "New Name", OldName$)
        Call WriteRegStringValue(sRegPath$, vbNullString, NewName$)
'F5 needs to be pressed on the Desktop to refresh it
'This will change the name so the user can see it

'Minimize All Windows
    TrayWnd& = FindWindow("Shell_TrayWnd", vbNullString)
    Call PostMessage(TrayWnd&, WM_COMMAND, MIM_ALL, 0&)
'Pause to allow the Desktop to appear
        Timeout 0.3
'Press F5
    Call keybd_event(VK_F5, 0, 0, 0)
End Sub

Public Sub Timeout(sSeconds As Variant)
Dim StartTime&, curTime&
sSeconds = sSeconds * 1000
StartTime = GetTickCount()
Do: DoEvents
    curTime = GetTickCount()
Loop Until ((curTime& - StartTime&) > sSeconds)
End Sub

Private Sub Command1_Click()
    RenameRecycleBin
End Sub


Articles | Documents | Tools | FDO | Atoms | Tokens | Security Breaches

© 2000 BMB and Tau Productions. Contacts: BMB | Tau | Rob