GFRegShellInfo/GFRegShellInfomod.bas

Attribute VB_Name = "GFRegShellInfomod"
Option Explicit
'(c)2001, 2003 by Louis.
'
'NOTE: this module contains functions (ok, there are only two) that can be used
'to determine 'what can be done' with a special file type.
'The file type actions can then e.g. be transferred to a pop up menu
'by the target project.

Public Function GFRegShellInfo_GetRegShellInfo(ByVal RegMainKey As Long, ByVal RegRootKey As String, ByRef RegShellNumber As Integer, ByRef RegShellDescriptionArray() As String, ByRef RegShellCommandArray() As String) As Boolean
    'on error resume next
    Dim RegSubKeyNumber As Integer
    Dim RegSubKeyArray() As String
    Dim RegSubKeyLoop As Integer
    Dim Temp As Long
    Dim Tempstr$
    '
    'NOTE: RegMainKey should be HKEY_CLASSES_ROOT,
    'RegRootKey should be e.g. 'Paint.Picture' (Win98 default for .bmp files).
    '
    'reset
    RegShellNumber = 0 'rest
    ReDim RegShellDescriptionArray(1 To 1) As String 'reset
    ReDim RegShellCommandArray(1 To 1) As String 'reset
    'verify
    If Not (Right$(RegRootKey, 1) = "\") Then RegRootKey = RegRootKey + "\"
    If Not (UCase$(Right$(RegRootKey, 6)) = "SHELL\") Then RegRootKey = RegRootKey + "SHELL\"
    'begin
    '
    'NOTE: a list of all sub keys of RegRootKey + "SHELL\" is created
    'as these sub keys (mostly) contain the action description
    'and sub key + "COMMAND\" contains the command to execute the
    'application that can perform the file type related action.
    '
    If Rmod.RegGetSubKeyList(RegMainKey, RegRootKey, RegSubKeyNumber, RegSubKeyArray()) = False Then GoTo Error:
    '
    'NOTE: the following code creates the RegShell[...] data out of
    'the sub keys and their values.
    '
    For RegSubKeyLoop = 1 To RegSubKeyNumber
        '
        RegShellNumber = RegShellNumber + 1 'cannot exceed 32767
        ReDim Preserve RegShellDescriptionArray(1 To RegShellNumber) As String
        ReDim Preserve RegShellCommandArray(1 To RegShellNumber) As String
        '
        Tempstr$ = Rmod.RegGetKeyValue(RegMainKey, RegSubKeyArray(RegSubKeyLoop), "")
        If Len(Tempstr$) = 0 Then 'verify
            RegShellDescriptionArray(RegShellNumber) = _
                UCase$(Left$(GetLastSubDirName(RegSubKeyArray(RegSubKeyLoop)), 1)) + LCase$(Mid$(GetLastSubDirName(RegSubKeyArray(RegSubKeyLoop)), 2)) 'Mid$(a, b) used only
        Else
            RegShellDescriptionArray(RegShellNumber) = Tempstr$
        End If
        '
        'NOTE: '&' is removed as it is used to create a menu short cut only.
        '
        For Temp = 1 To Len(RegShellDescriptionArray(RegShellNumber))
            If Mid$(RegShellDescriptionArray(RegShellNumber), Temp, 1) = "&" Then _
                RegShellDescriptionArray(RegShellNumber) = Left$(RegShellDescriptionArray(RegShellNumber), Temp ‑ 1) + Mid$(RegShellDescriptionArray(RegShellNumber), Temp + 1) 'Mid$(a, b) used only
        Next Temp
        '
        Tempstr$ = Rmod.RegGetKeyValue(RegMainKey, RegSubKeyArray(RegSubKeyLoop) + "COMMAND\", "")
        If Len(Tempstr$) = 0 Then 'verify
            RegShellCommandArray(RegSubKeyLoop) = "" 'reset (error)
        Else
            RegShellCommandArray(RegSubKeyLoop) = Tempstr$
        End If
    Next RegSubKeyLoop
    GFRegShellInfo_GetRegShellInfo = True 'ok
    Exit Function
Error:
    GFRegShellInfo_GetRegShellInfo = False 'error
    Exit Function
End Function

Public Sub GFRegShellInfo_CreateDirectoryAction(ByVal ActionDescription As String, ByVal ActionSubKeyName As String, ByVal ActionCommand As String)
    'on error resume next
    '
    'NOTE: this sub adds an action to the 'Explorer‑right‑click‑menu'
    'that opens when the user clicks on a directory, example:
    'ActionDescription: Open with MyGreatApp
    'ActionSubKeyName: MyGreatApp.Open
    'ActionCommand: C:\MyGreatApp\MyGreatApp.exe "%1"
    '
    'verify
    If Not (Right(ActionSubKeyName, 1) = "\") Then ActionSubKeyName = ActionSubKeyName + "\"
    Rmod.RegGetKeyValueErrorFlag = False 'reset
    Call Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, "Directory\Shell\", "")
    If Rmod.RegGetKeyValueErrorFlag = True Then _
        Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Directory\Shell\")
    'begin
    Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Directory\Shell\" + ActionSubKeyName)
    Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Directory\Shell\" + ActionSubKeyName + "Command\")
    Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, "Directory\Shell\" + ActionSubKeyName, "", CVar(ActionDescription), REG_SZ)
    Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, "Directory\Shell\" + ActionSubKeyName + "Command\", "", CVar(ActionCommand), REG_SZ)
End Sub

Public Sub GFRegShellInfo_RemoveDirectoryAction(ByVal ActionDescription As String, ByVal ActionSubKeyName As String, ByVal ActionCommand As String)
    'on error resume next
    '
    'NOTE: this sub removes an action from the 'Explorer‑right‑click‑menu'
    'that opens when the user clicks on a directory, example:
    'ActionDescription: Open with MyGreatApp
    'ActionSubKeyName: MyGreatApp.Open
    'ActionCommand: C:\MyGreatApp\MyGreatApp.exe "%1"
    '
    'verify
    If Not (Right(ActionSubKeyName, 1) = "\") Then ActionSubKeyName = ActionSubKeyName + "\"
    Rmod.RegGetKeyValueErrorFlag = False 'reset
    Call Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, "Directory\Shell\", "")
    If Rmod.RegGetKeyValueErrorFlag = True Then _
        Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Directory\Shell\")
    'begin
    Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, "Directory\Shell\" + ActionSubKeyName + "Command\")
    Call Rmod.RegDeleteSubKey(HKEY_CLASSES_ROOT, "Directory\Shell\" + ActionSubKeyName)
End Sub

Public Sub GFRegShellInfo_CreateDriveAction(ByVal ActionDescription As String, ByVal ActionSubKeyName As String, ByVal ActionCommand As String)
    'on error resume next
    '
    'NOTE: this sub adds an action to the 'Explorer‑right‑click‑menu'
    'that opens when the user clicks on a directory, example:
    'ActionDescription: Open with MyGreatApp
    'ActionSubKeyName: MyGreatApp.Open
    'ActionCommand: C:\MyGreatApp\MyGreatApp.exe "%1"
    '
    'verify
    If Not (Right(ActionSubKeyName, 1) = "\") Then ActionSubKeyName = ActionSubKeyName + "\"
    Rmod.RegGetKeyValueErrorFlag = False 'reset
    Call Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, "Drive\Shell\", "")
    If Rmod.RegGetKeyValueErrorFlag = True Then _
        Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Drive\Shell\")
    'begin
    Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Drive\Shell\" + ActionSubKeyName)
    Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, "Drive\Shell\" + ActionSubKeyName + "Command\")
    Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, "Drive\Shell\" + ActionSubKeyName, "", CVar(ActionDescription), REG_SZ)
    Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, "Drive\Shell\" + ActionSubKeyName + "Command\", "", CVar(ActionCommand), REG_SZ)
End Sub

Public Sub GFRegShellInfo_CreateFileAction(ByVal FileDescription As String, ByVal ActionDescription As String, ByVal ActionSubKeyName As String, ByVal ActionCommand As String)
    'on error resume next
    '
    'NOTE: this sub adds an action to the 'Explorer‑right‑click‑menu'
    'that opens when the user clicks on a directory, example:
    'ActionDescription: Open with MyGreatApp
    'ActionSubKeyName: MyGreatApp.Open
    'ActionCommand: C:\MyGreatApp\MyGreatApp.exe "%1"
    '
    'verify
    If Not (Right(ActionSubKeyName, 1) = "\") Then ActionSubKeyName = ActionSubKeyName + "\"
    Rmod.RegGetKeyValueErrorFlag = False 'reset
    Call Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, FileDescription + "\Shell\", "")
    If Rmod.RegGetKeyValueErrorFlag = True Then _
        Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, FileDescription + "\Shell\")
    'begin
    Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, FileDescription + "\Shell\" + ActionSubKeyName)
    Call Rmod.RegCreateSubKey(HKEY_CLASSES_ROOT, FileDescription + "\Shell\" + ActionSubKeyName + "Command\")
    Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, FileDescription + "\Shell\" + ActionSubKeyName, "", CVar(ActionDescription), REG_SZ)
    Call Rmod.RegSetKeyValue(HKEY_CLASSES_ROOT, FileDescription + "\Shell\" + ActionSubKeyName + "Command\", "", CVar(ActionCommand), REG_SZ)
End Sub

Private Function GetLastSubDirName(ByVal DirectoryString As String) As String 'can be used as general function
    'On Error Resume Next 'returns e.g. 'Windows' for DirectoryString = "C:\Windows\" or nothing for error
    Dim NetWorkMachineName As String 'could be cut and must be re‑added
    Dim CharLoop As Integer
    'preset
    If Mid$(DirectoryString, 1, 2) = "\\" Then
        For CharLoop = 3 To Len(DirectoryString)
            If Mid$(DirectoryString, CharLoop, 1) = "\" Then
                NetWorkMachineName = Left$(DirectoryString, CharLoop)
                DirectoryString = Right$(DirectoryString, Len(DirectoryString) ‑ CharLoop)
                Exit For 'important
            End If
        Next CharLoop
    End If
    GetLastSubDirName = NetWorkMachineName + DirectoryString 'return e.g. 'C:\' for DirectoryString = "C:\"
    'begin
    If Mid$(DirectoryString, Len(DirectoryString), 1) = "\" Then
        For CharLoop = (Len(DirectoryString) ‑ 1) To 1 Step (‑1)
            If Mid$(DirectoryString, CharLoop, 1) = "\" Then
                GetLastSubDirName = Mid$(DirectoryString, (CharLoop + 1), ((Len(DirectoryString) ‑ 1) ‑ CharLoop))
                Exit Function 'ok
            End If
        Next CharLoop
        'return value preset, do not remove last backslash
    Else
        For CharLoop = (Len(DirectoryString)) To 1 Step (‑1)
            If Mid$(DirectoryString, CharLoop, 1) = "\" Then
                GetLastSubDirName = Mid$(DirectoryString, (CharLoop + 1), ((Len(DirectoryString)) ‑ CharLoop))
                Exit Function 'ok
            End If
        Next CharLoop
        'return value preset, do not remove last backslash
    End If
    Exit Function
End Function


[END OF FILE]