Solved

Accessing registry

Posted on 2000-04-27
20
303 Views
Last Modified: 2007-10-18
Hey all... the other day I downloaded a registry class from another question on EE.  However, it is not working.  I am trying to use the CreateEXEAssociation function but it is not working.  I made a CreateEXEAssociationOnNT function based on what I found was created in the registry when I used Explore to create the assoitation.  It writes the correct keys to the registry but it will not write the data to the default vaules.  I have tried a couple of different things, but nothing works.  The module is in a comment below.  I am currently using NT 4.0 SP4, but I would like this to work with 95 and 98 also.  Thanks.
0
Comment
Question by:Ra
  • 9
  • 5
  • 4
  • +2
20 Comments
 

Author Comment

by:Ra
ID: 2756132
'Here is the module:

Option Explicit

' #VBIDEUtils#************************************************************
' * Programmer Name  : Steve McMahon
' * Web Site         : http://www.dogma.demon.co.uk/
' * E-Mail           : steve@dogma.demon.co.uk
' * Date             : 25/09/98
' * Time             : 14:49
' * Module Name      : class_Registry
' * Module Filename  : Registry.cls
' **********************************************************************
' * Comments         : This class is an easy, self-contained way to get
' *  complete access to the Windows registry.
' *  Simple methods allow you to create, enumerate and delete keys
' *  and values in the registry, without restriction.
' *  You can even read/write binary data to the registry.
' *
' * Example :
' *  get a String Value from the Registry
' *    Dim clsRegistry As New class_Registry
' *    With clsRegistry
' *       .ClassKey = HKEY_LOCAL_MACHINE
' *       .SectionKey = "Software\PrintPreview"
' *       .ValueKey = "Version"
' *       .ValueType = REG_SZ
' *       sTip = .Value
' *    End With
' *
' *  Save a Form's position to the Registry
' *    Dim clsRegistry As New class_Registry
' *    With clsRegistry
' *       .ClassKey = HKEY_CURRENT_USER
' *       ' You don't need to check if this key already exists
' *       ' - the class will create it for you
' *       .SectionKey = "Software\" & App.EXEName & "\" & frmThis.name
' *       .ValueKey = "Maximized"
' *       .ValueType = REG_DWORD
' *       .Value = (frmThis.WindowState = vbMaximized)
' *       If (frmThis.WindowState <> vbMaximized)
' *           .ValueKey = "Left"
' *           .Value = frmThis.Left
' *           .ValueKey = "Top"
' *           .Value = frmThis.Top
' *           .ValueKey = "Width"
' *           .Value = frmThis.Width
' *           .ValueKey = "Height"
' *           .Value = frmThis.Height
' *       End If
' *    End With
' *
' **********************************************************************

' *** Registry Specific Access Rights
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_ALL_ACCESS = &H3F

' *** Open/Create Options
Private Const REG_OPTION_NON_VOLATILE = 0&
Private Const REG_OPTION_VOLATILE = &H1

' *** Key creation/open disposition
Private Const REG_CREATED_NEW_KEY = &H1
Private Const REG_OPENED_EXISTING_KEY = &H2

' *** masks for the predefined standard access types
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF

' *** Define severity codes
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_MORE_DATA = 234 ' ***   dderror
Private Const ERROR_NO_MORE_ITEMS = 259

' *** Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
   nLength As Long
   lpSecurityDescriptor As Long
   bInheritHandle As Boolean
End Type

Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

' *** Registry Function Prototypes
Private Declare Function RegOpenKeyEx Lib "Advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueExStr Lib "Advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal szData As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "Advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, szData As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "Advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, szData As Byte, ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "Advapi32" (ByVal hKey As Long) As Long

Private Declare Function RegQueryValueExStr Lib "Advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "Advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, szData As Long, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueExByte Lib "Advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, szData As Byte, ByRef lpcbData As Long) As Long

Private Declare Function RegCreateKeyEx Lib "Advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, ByVal lpData As Long, ByVal lpcbData As Long) As Long
Private Declare Function RegEnumValueLong Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegEnumValueStr Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegEnumValueByte Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long

Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

' ***  Other declares:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long

Public Enum ERegistryClassConstants
   HKEY_CLASSES_ROOT = &H80000000
   HKEY_CURRENT_USER = &H80000001
   HKEY_LOCAL_MACHINE = &H80000002
   HKEY_USERS = &H80000003
   HKEY_PERFORMANCE_DATA = &H80000004
   HKEY_CURRENT_CONFIG = &H80000005
   HKEY_DYN_DATA = &H80000006
End Enum

Public Enum ERegistryValueTypes
   ' *** Predefined Value Types
   REG_NONE = (0)                         ' *** No value type
   REG_SZ = (1)                           ' *** Unicode nul terminated string
   REG_EXPAND_SZ = (2)                    ' *** Unicode nul terminated string w/enviornment var
   REG_BINARY = (3)                       ' *** Free form binary
   REG_DWORD = (4)                        ' *** 32-bit number
   REG_DWORD_LITTLE_ENDIAN = (4)          ' *** 32-bit number (same as REG_DWORD)
   REG_DWORD_BIG_ENDIAN = (5)             ' *** 32-bit number
   REG_LINK = (6)                         ' *** Symbolic Link (unicode)
   REG_MULTI_SZ = (7)                     ' *** Multiple Unicode strings
   REG_RESOURCE_LIST = (8)                ' *** Resource list in the resource map
   REG_FULL_RESOURCE_DESCRIPTOR = (9)     ' *** Resource list in the hardware description
   REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum

Private m_hClassKey As Long
Private m_sSectionKey As String
Private m_sValueKey As String
Private m_vValue As Variant
Private m_sSetValue As String
Private m_vDefault As Variant
Private m_eValueType As ERegistryValueTypes

Public Property Get KeyExists() As Boolean
   ' *** KeyExists = bCheckKeyExists( _
    ' ***                 m_hClassKey, _
    ' ***                 m_sSectionKey _
    ' ***             )
   
   Dim hKey As Long
   
   If RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, 1, hKey) = ERROR_SUCCESS Then
      KeyExists = True
      RegCloseKey hKey
   Else
      KeyExists = False
   End If

End Property

Public Function CreateKey() As Boolean
   
   Dim tSA        As SECURITY_ATTRIBUTES
   Dim hKey       As Long
   Dim lCreate    As Long
   Dim e          As Long

   ' *** Open or Create the key
   e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, tSA, hKey, lCreate)
   If e Then
      Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to create registry Key: ' *** " & m_sSectionKey
   Else
      CreateKey = (e = ERROR_SUCCESS)
      ' *** Close the key
      RegCloseKey hKey
   End If
   
End Function

Public Function DeleteKey() As Boolean
   
   Dim e As Long
   e = RegDeleteKey(m_hClassKey, m_sSectionKey)
   If e Then
      Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: ' *** " & m_hClassKey & "' *** ,Section: ' *** " & m_sSectionKey
   Else
      DeleteKey = (e = ERROR_SUCCESS)
   End If

End Function

Public Function DeleteValue() As Boolean
   
   Dim e       As Long
   Dim hKey    As Long

   e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ALL_ACCESS, hKey)
   If e Then
      Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to open key ' *** " & m_hClassKey & "' *** ,Section: ' *** " & m_sSectionKey & "' ***  for delete access"
   Else
      e = RegDeleteValue(hKey, m_sValueKey)
      If e Then
         Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to delete registry Key: ' *** " & m_hClassKey & "' *** ,Section: ' *** " & m_sSectionKey & "' *** ,Key: ' *** " & m_sValueKey
      Else
         DeleteValue = (e = ERROR_SUCCESS)
      End If
   End If

End Function

Public Property Get Value() As Variant
   
   Dim vValue     As Variant
   Dim cData      As Long
   Dim sData      As String
   Dim ordType    As Long
   Dim e          As Long
   Dim hKey       As Long

   e = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
   ' *** ApiRaiseIf e

   e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, 0&, cData)
   If e And e <> ERROR_MORE_DATA Then
      Value = m_vDefault
      Exit Property
   End If

   m_eValueType = ordType
   Select Case ordType
      Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
         Dim iData As Long
         e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, iData, cData)
         vValue = CLng(iData)

      Case REG_DWORD_BIG_ENDIAN  ' ***  Unlikely, but you never know
         Dim dwData As Long
         e = RegQueryValueExLong(hKey, m_sValueKey, 0&, ordType, dwData, cData)
         vValue = SwapEndian(dwData)

      Case REG_SZ, REG_MULTI_SZ ' ***  Same thing to Visual Basic
         sData = String$(cData - 1, 0)
         e = RegQueryValueExStr(hKey, m_sValueKey, 0&, ordType, sData, cData)
         vValue = sData

      Case REG_EXPAND_SZ
         sData = String$(cData - 1, 0)
         e = RegQueryValueExStr(hKey, m_sValueKey, 0&, ordType, sData, cData)
         vValue = ExpandEnvStr(sData)

         ' ***  Catch REG_BINARY and anything else
      Case Else
         Dim abData() As Byte
         ReDim abData(cData)
         e = RegQueryValueExByte(hKey, m_sValueKey, 0&, ordType, abData(0), cData)
         vValue = abData

   End Select
   Value = vValue

End Property

Public Property Let Value(ByVal vValue As Variant)
   
   Dim ordType       As Long
   Dim c             As Long
   Dim hKey          As Long
   Dim e             As Long
   Dim lCreate       As Long
   Dim tSA           As SECURITY_ATTRIBUTES

   ' *** Open or Create the key
   e = RegCreateKeyEx(m_hClassKey, m_sSectionKey, 0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, tSA, hKey, lCreate)

   If e Then
      Err.Raise 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: ' *** " & m_hClassKey & "' *** ,Section: ' *** " & m_sSectionKey & "' *** ,Key: ' *** " & m_sValueKey & "' ***  to value: ' *** " & m_vValue & "' *** "
   Else

      Select Case m_eValueType
         Case REG_BINARY
            If (VarType(vValue) = vbArray + vbByte) Then
               Dim ab() As Byte
               ab = vValue
               ordType = REG_BINARY
               c = UBound(ab) - LBound(ab) - 1
               e = RegSetValueExByte(hKey, m_sValueKey, 0&, ordType, ab(0), c)
            Else
               Err.Raise 26001
            End If
         Case REG_DWORD, REG_DWORD_BIG_ENDIAN, REG_DWORD_LITTLE_ENDIAN
            If (VarType(vValue) = vbInteger) Or (VarType(vValue) = vbLong) Then
               Dim i As Long
               i = vValue
               ordType = REG_DWORD
               e = RegSetValueExLong(hKey, m_sValueKey, 0&, ordType, i, 4)
            End If
         Case REG_SZ, REG_EXPAND_SZ
            Dim s As String, iPos As Long
            s = vValue
            ordType = REG_SZ
            ' ***  Assume anything with two non-adjacent percents is expanded string
            iPos = InStr(s, "%")
            If iPos Then
               If InStr(iPos + 2, s, "%") Then ordType = REG_EXPAND_SZ
            End If
            c = Len(s) + 1
            e = RegSetValueExStr(hKey, m_sValueKey, 0&, ordType, s, c)

            ' ***  User should convert to a compatible type before calling
         Case Else
            e = ERROR_INVALID_DATA

      End Select

      If Not e Then
         m_vValue = vValue
      Else
         Err.Raise vbObjectError + 1048 + 26001, App.EXEName & ".cRegistry", "Failed to set registry value Key: ' *** " & m_hClassKey & "' *** ,Section: ' *** " & m_sSectionKey & "' *** ,Key: ' *** " & m_sValueKey & "' ***  to value: ' *** " & m_vValue & "' *** "
      End If

      ' *** Close the key
      RegCloseKey hKey

   End If

End Property

Public Function EnumerateValues(ByRef sKeyNames() As String, ByRef iKeyCount As Long) As Boolean
   
   Dim lResult       As Long
   Dim hKey          As Long
   Dim SName         As String
   Dim lNameSize     As Long
   Dim sData         As String
   Dim lIndex        As Long
   Dim cJunk         As Long
   Dim cNameMax      As Long
   Dim ft            As Currency

   ' ***  Log "EnterEnumerateValues"

   iKeyCount = 0
   Erase sKeyNames()

   lIndex = 0
   lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_QUERY_VALUE, hKey)
   If (lResult = ERROR_SUCCESS) Then
      ' ***  Log "OpenedKey:" & m_hClassKey & "," & m_sSectionKey
      lResult = RegQueryInfoKey(hKey, "", cJunk, 0, cJunk, cJunk, cJunk, cJunk, cNameMax, cJunk, cJunk, ft)
      Do While lResult = ERROR_SUCCESS

         ' *** Set buffer space
         lNameSize = cNameMax + 1
         SName = String$(lNameSize, 0)
         If (lNameSize = 0) Then lNameSize = 1

         ' ***  Log "Requesting Next Value"

         ' *** Get value name:
         lResult = RegEnumValue(hKey, lIndex, SName, lNameSize, 0&, 0&, 0&, 0&)
         
         ' ***  Log "RegEnumValue returned:" & lResult
         If (lResult = ERROR_SUCCESS) Then

            ' ***  Although in theory you can also retrieve the actual
            ' ***  value and type here, I found it always (ultimately) resulted in
            ' ***  a GPF, on Win95 and NT.  Why?  Can anyone help?

            SName = Left$(SName, lNameSize)
            ' ***  Log "Enumerated value:" & sName

            iKeyCount = iKeyCount + 1
            ReDim Preserve sKeyNames(1 To iKeyCount) As String
            sKeyNames(iKeyCount) = SName
         End If
         lIndex = lIndex + 1
      Loop
   End If
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If

   ' ***  Log "Exit Enumerate Values"
   EnumerateValues = True
   Exit Function

EnumerateValuesError:
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If
   Err.Raise vbObjectError + 1048 + 26003, App.EXEName & ".cRegistry", Err.Description
   Exit Function

End Function

Public Function EnumerateSections(ByRef sSect() As String, ByRef iSectCount As Long) As Boolean
   
   Dim lResult       As Long
   Dim hKey          As Long
   Dim dwReserved    As Long
   Dim szBuffer      As String
   Dim lBuffSize     As Long
   Dim lIndex        As Long
   Dim lType         As Long
   Dim sCompKey      As String
   Dim iPos          As Long

   On Error GoTo EnumerateSectionsError

   iSectCount = 0
   Erase sSect
   ' ***
   lIndex = 0

   lResult = RegOpenKeyEx(m_hClassKey, m_sSectionKey, 0, KEY_ENUMERATE_SUB_KEYS, hKey)
   Do While lResult = ERROR_SUCCESS
      ' *** Set buffer space
      szBuffer = String$(255, 0)
      lBuffSize = Len(szBuffer)

      ' *** Get next value
      lResult = RegEnumKey(hKey, lIndex, szBuffer, lBuffSize)

      If (lResult = ERROR_SUCCESS) Then
         iSectCount = iSectCount + 1
         ReDim Preserve sSect(1 To iSectCount) As String
         iPos = InStr(szBuffer, Chr$(0))
         If (iPos > 0) Then
            sSect(iSectCount) = Left(szBuffer, iPos - 1)
         Else
            sSect(iSectCount) = Left(szBuffer, lBuffSize)
         End If
      End If

      lIndex = lIndex + 1
   Loop
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If
   EnumerateSections = True
   Exit Function

EnumerateSectionsError:
   If (hKey <> 0) Then
      RegCloseKey hKey
   End If
   Err.Raise vbObjectError + 1048 + 26002, App.EXEName & ".cRegistry", Err.Description
   Exit Function

End Function

Public Sub CreateEXEAssociation(ByVal sExePath As String, ByVal sClassName As String, ByVal sClassDescription As String, ByVal sAssociation As String, Optional ByVal lDefaultIconIndex As Long = -1)

   ClassKey = HKEY_CLASSES_ROOT
   SectionKey = "." & sAssociation
   ValueKey = ""
   Value = sClassName
   SectionKey = "." & sAssociation & "\shell\open\command"
   ValueKey = ""
   Value = sExePath & " ""%1"""

   SectionKey = sClassName
   ValueKey = ""
   Value = sClassDescription
   SectionKey = sClassName & "\shell\open\command"
   ValueKey = sExePath & " ""%1"""
   If lDefaultIconIndex > -1 Then
      SectionKey = sClassName & "\DefaultIcon"
      ValueKey = ""
      Value = sExePath & "," & CStr(lDefaultIconIndex)
   End If

End Sub

Public Sub CreateEXEAssociationOnNT(ByVal sExePath As String, ByVal sClassName As String, ByVal sAssociation As String, Optional ByVal lDefaultIconIndex As Long = -1)
   
   ClassKey = HKEY_CLASSES_ROOT
   SectionKey = "." & sAssociation
   ValueKey = ""
   Value = sClassName
   
   ClassKey = HKEY_CLASSES_ROOT
   SectionKey = sClassName & "\shell\open\command"
   ValueKey = ""
   Value = sExePath & " %1"
   
End Sub

Public Property Get ValueType() As ERegistryValueTypes
   
   ValueType = m_eValueType

End Property

Public Property Let ValueType(ByVal eValueType As ERegistryValueTypes)
   
   m_eValueType = eValueType

End Property

Public Property Get ClassKey() As ERegistryClassConstants
   
   ClassKey = m_hClassKey

End Property

Public Property Let ClassKey(ByVal eKey As ERegistryClassConstants)
   
   m_hClassKey = eKey

End Property

Public Property Get SectionKey() As String
   
   SectionKey = m_sSectionKey

End Property

Public Property Let SectionKey(ByVal sSectionKey As String)
   
   m_sSectionKey = sSectionKey

End Property

Public Property Get ValueKey() As String
   
   ValueKey = m_sValueKey

End Property

Public Property Let ValueKey(ByVal sValueKey As String)
   
   m_sValueKey = sValueKey

End Property

Public Property Get Default() As Variant
   
   Default = m_vDefault

End Property

Public Property Let Default(ByVal vDefault As Variant)
   
   m_vDefault = vDefault

End Property

Private Function SwapEndian(ByVal dw As Long) As Long
   
   CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
   CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
   CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
   CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1

End Function

Private Function ExpandEnvStr(sData As String) As String
   
   Dim c As Long, s As String
   
   ' ***  Get the length
   s = "" ' ***  Needed to get around Windows 95 limitation
   c = ExpandEnvironmentStrings(sData, s, c)
   ' ***  Expand the string
   s = String$(c - 1, 0)
   c = ExpandEnvironmentStrings(sData, s, c)
   ExpandEnvStr = s

End Function

Public Function GetRegistrySetting(nKeyRoot As ERegistryClassConstants, sKeyName As String, sSubKeyRef As String, sDefault As String, Optional vValueType As ERegistryValueTypes = REG_EXPAND_SZ) As String
   ' *** Return the value of a settings in the registry

   ClassKey = nKeyRoot
   SectionKey = sKeyName
   ValueKey = sSubKeyRef
   Default = sDefault
   ValueType = vValueType

   GetRegistrySetting = Value

End Function

Public Sub SetRegistrySetting(nKeyRoot As ERegistryClassConstants, sSubKeyRef As String, sKeyName As String, sValue As String, Optional vValueType As ERegistryValueTypes = REG_EXPAND_SZ)
   ' *** Set a value in the registry

   ClassKey = nKeyRoot
   SectionKey = sSubKeyRef
   ValueKey = sKeyName
   ValueType = vValueType
   Value = sValue

End Sub
0
 

Expert Comment

by:catdaddy123
ID: 2756233
There are two or three registry samples at http://616.org that would probably help you. There are also some great registry tips. Just search for registry.
0
 

Author Comment

by:Ra
ID: 2756311
catdaddy, I only found 1 example at that site and it gave me an error when I tried to run it.

Somebody please take a look at the module I poseted and tell me why the CreateEXEAssociation will not work.

Thanks.
0
 

Expert Comment

by:GreatMikey
ID: 2756345
i see you module but its just plain code what we need is to know exactly what u have done??????
i.e. what type of data you are writing.....
0
 

Author Comment

by:Ra
ID: 2756396
I am using the CreateEXEAssociation funciton to try and create a file association.  I am not doing anything more then that.  I want to associate .odr extensions with my app.  The CreateEXEAssociation function runs without giving an error, but the values are not written to the registry.  For example, it adds the .odr under HKEY_CLASSES_ROOT, but will not put "Order Form" as the data value under (Default) to link it to the "Order Form" key where the second half of the function writes the path and exe name of my program.

In short, this module will not write ANY data values to the registry.
0
 
LVL 18

Expert Comment

by:mdougan
ID: 2756455
Well, call me crazy, but it looks like you're just setting the values of the member variables and you're never calling one of the registry APIs to actually write the settings to the registry:

Public Sub CreateEXEAssociation(ByVal sExePath As String, ByVal sClassName As String, ByVal sClassDescription As String,
                      ByVal sAssociation As String, Optional ByVal lDefaultIconIndex As Long = -1)

                         ClassKey = HKEY_CLASSES_ROOT
                         SectionKey = "." & sAssociation
                         ValueKey = ""
                         Value = sClassName

' Why are you setting these three twice?
                         SectionKey = "." & sAssociation & "\shell\open\command"
                         ValueKey = ""
                         Value = sExePath & " ""%1"""

' Where is the call to SetRegistrySetting or equivilant?

                         SectionKey = sClassName
                         ValueKey = ""
                         Value = sClassDescription

' Why are you setting these two twice?
                         SectionKey = sClassName & "\shell\open\command"
                         ValueKey = sExePath & " ""%1"""

                         If lDefaultIconIndex > -1 Then
' and now a third time?
                            SectionKey = sClassName & "\DefaultIcon"
                            ValueKey = ""
                            Value = sExePath & "," & CStr(lDefaultIconIndex)
                         End If


' Where is the call to SetRegistrySetting or equivilant?

                      End Sub
0
 
LVL 18

Expert Comment

by:mdougan
ID: 2756479
Sorry, I just found the Let Value procedure, I'll keep looking
0
 

Author Comment

by:Ra
ID: 2756554
Yeah, value is supposed to write the value to the registry, but it doesn't.  This is what NT writes when i use Explorer to make the assoitation:

HKEY_CLASSES_ROOT
|_ .odr    (Default)   "ord_auto_file"
|_ ord_auto_file (Default)  "Path\filename.exe %1"

what this module wites:

HKEY_CLASSES_ROOT
|_ .odr    (Default)   <value not set>
|_ Order Form (Default) <value not set>

I have manually changed "ord_auto_file" to "Order Form" in both keys after NT makes the assoiation and it still works.  If the program writes "Order Form" to both, it should also work.  I just can't get it to write the values.
0
 
LVL 18

Expert Comment

by:mdougan
ID: 2756559
Does your Let Value procedure succeed in creating the Key?  I noticed some differences in the call to create the Key from mine:

nRet = RegCreateKeyEx(Group, Section, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, ByVal 0&, hKey, nResult)
   
I put the & after the third parameter, I use the vbNullString instead of "", I pass a 0& instead of the Security Attributes (and I change the declare to type this parm As Any)

Since I only use one version of RegSetValueEx I compared it to your string version:

      Setting = Setting & vbNullChar
        nRet = RegSetValueEx(hKey, Key, 0&, REG_SZ, ByVal Setting, Len(Setting))

I explicity add the vbNullChar to the end of the string, and then pass the new length of the string to the function's last parameter.  I defined the data value parm (second from end) ByVal sss As Any.

I've used this one version to create all types of key values, binary, byte, string, dword etc.
0
 

Expert Comment

by:GreatMikey
ID: 2756587
in the creatassociationonnt and not in the n t one you havent called the valuetype functionn to set the regtype so the value function thinks you are creating an empty key!!!! fooollll
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:Ra
ID: 2756594
I set it to DWORD but it still doesn't work.. fool.
0
 
LVL 18

Expert Comment

by:mdougan
ID: 2756620
Oh, I noticed that this line:

   ValueKey = sExePath & " ""%1"""

Should probably be for the Value, not the ValueKey

And, I'm not seeing anywhere where you are setting the ValueKey to one of the Enum values for the key like REG_SZ etc.
0
 

Expert Comment

by:GreatMikey
ID: 2756646
Sorry if i was rude!!! i was a bit anoyed my pc was crashing :)
n e way  have you tried checking the return values from teh api functions the set the value as they are executed? and then cross referencing them to see what they meen? if you dont have msdn then ill tell you the resturn values meaning
0
 

Author Comment

by:Ra
ID: 2756652
Yeah, that's the way i did it in my OnNT Function.  I'll try setting th e ValueKey to one of those enum values and see what happens.

I made the OnNT function because of the way Explore made the assoication.  The original function looks like it could be for 95/98.  I did not write this module.  The only thing I did was the OnNT funciton.
0
 

Author Comment

by:Ra
ID: 2756661
NP GM, I know how that feels (I have 95 at home).  ;)  I do have MSDN so I'll check on the return values.
0
 

Expert Comment

by:GreatMikey
ID: 2756674
Sorry if i was rude!!! i was a bit anoyed my pc was crashing :)
n e way  have you tried checking the return values from teh api functions the set the value as they are executed? and then cross referencing them to see what they meen? if you dont have msdn then ill tell you the resturn values meaning
0
 

Author Comment

by:Ra
ID: 2756716
I just went back to check, and this function was posted on December 14, 1998 so it is possible that it was designed for vb 5 or earlyer.  I can't remember when 6 came out... sometime in 99, I think.
0
 
LVL 18

Expert Comment

by:mdougan
ID: 2756757
Oh, I noticed that this line:

   ValueKey = sExePath & " ""%1"""

Should probably be for the Value, not the ValueKey

And, I'm not seeing anywhere where you are setting the ValueKey to one of the Enum values for the key like REG_SZ etc.
0
 

Accepted Solution

by:
richking042700 earned 50 total points
ID: 2757484
With this module:

Rem Win32 API Registry Functions
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpValueName As String) As Long
Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hkey As Long, ByVal lpFile As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long


Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
        ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long


Rem Win32 Registry Specialized Functions
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long

Rem Win32 API Predefined Key Types
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005


Rem Win32 API Error Constants
Global Const ERROR_SUCCESS = 0
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Rem Specialized Error Constant
Global Const INVALIDKEY = -1

Rem Win32 API Registry Function Constants
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const SYNCHRONIZE = &H100000
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Public Const KEY_EVENT = &H1
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const REG_BINARY = 3
Public Const REG_CREATED_NEW_KEY = &H1
Public Const REG_DWORD = 4
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_DWORD_LITTLE_ENDIAN = 4
Public Const REG_EXPAND_SZ = 2
Public Const REG_LINK = 6
Public Const REG_NONE = 0
Public Const REG_OPENED_EXISTING_KEY = &H2
Public Const REG_OPTION_BACKUP_RESTORE = 4
Public Const REG_OPTION_CREATE_LINK = 2
Public Const REG_OPTION_NON_VOLATILE = 0
Public Const REG_OPTION_RESERVED = 0
Public Const REG_OPTION_VOLATILE = 1
Public Const REG_REFRESH_HIVE = &H2
Public Const REG_RESOURCE_LIST = 8
Public Const REG_RESOURCE_REQUIREMENTS_LIST = 10
Public Const REG_SZ = 1
Public Const REG_WHOLE_HIVE_VOLATILE = &H1

Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Public Type BROWSEINFO
   hOwner           As Long
   pidlRoot         As Long
   pszDisplayName   As String
   lpszTitle        As String
   ulFlags          As Long
   lpfn             As Long
   lParam           As Long
   iImage           As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const MAX_PATH = 256
Public Const WM_CLOSE = &H10

Public pidl As Long

    Declare Function OSRegSetValueEx Lib "advapi32" _
        Alias "RegSetValueExA" ( _
        ByVal hkey As Long, _
        ByVal lpszValueName As String, _
        ByVal dwReserved As Long, _
        ByVal fdwType As Long, _
        lpbData As Any, _
        ByVal cbData As Long) As Long
   
    Declare Function OSRegOpenKey Lib "advapi32" _
        Alias "RegOpenKeyA" ( _
        ByVal hkey As Long, _
        ByVal lpszSubKey As String, _
        phkResult As Long) As Long
   
    Declare Function OSRegQueryValueEx Lib "advapi32" _
        Alias "RegQueryValueExA" ( _
        ByVal hkey As Long, _
        ByVal lpszValueName As String, _
        ByVal dwReserved As Long, _
        lpdwType As Long, _
        lpbData As Any, _
        cbData As Long) As Long
   
    Declare Function OSRegCloseKey Lib "advapi32" _
        Alias "RegCloseKey" ( _
        ByVal hkey As Long) As Long
    Declare Function OSRegCreateKey Lib "advapi32" _
        Alias "RegCreateKeyA" ( _
        ByVal hkey As Long, _
        ByVal lpszSubKey As String, _
        phkResult As Long) As Long

Public Declare Function SHGetPathFromIDList _
   Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
  (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
   Alias "SHBrowseForFolderA" _
  (lpBrowseInfo As BROWSEINFO) As Long

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Function GetIniString(strSection As String, strKey As String, strINIFileName As String) As String
    Dim strRetVal As String
    Dim intRtrn As Integer

    strRetVal = String$(255, 0)
    intRtrn = GetPrivateProfileString(strSection, strKey, "", strRetVal, Len(strRetVal), strINIFileName)

    If intRtrn = 0 Then
        GetIniString = ""
    Else
        GetIniString = Left$(strRetVal, intRtrn)
    End If

End Function

Public Sub SetKeyVal(lPredefinedKey As Long, sKeyName As String, sValueName As String, _
    vValueSetting As Variant, lValueType As Long)
   
    'Entry:
    '   lPredefinedKey = either HKEY_LOCAL_USER or HKEY_LOCAL_MACHINE
    '   sKeyName = the path to the key being operated on (ie. "SOFTWARE\Cyber3")
    '   sValueName = the name of the keyvalue to change (ie. "Menus")
    '   vValueSetting = the value to set for the keyvalue (ie. "True")
    '   lValueType = the type of value it is, either REG_SZ (for string) or REG_DWORD (for int)
    'Return:
    '   Currently, this function has no return value
   
    Dim lRetVal As Long         'result of the SetValueEx function
    Dim hkey As Long            'handle of open key
   
    'open the specified key
    lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, _
                           KEY_ALL_ACCESS, hkey)
    lRetVal = SetValueEx(hkey, sValueName, lValueType, vValueSetting)
    RegCloseKey (hkey)
End Sub


Rem Win32 API Registry Specialized Function
Rem SHOULD NOT BE CALLED DIRECTLY -- Use SetKeyValue() instead

Public Function SetValueEx(ByVal hkey As Long, sValueName As String, _
lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String
    Select Case lType
        Case REG_SZ
            sValue = vValue & Chr$(0)
            SetValueEx = RegSetValueExString(hkey, sValueName, 0&, _
                                           lType, sValue, Len(sValue))
        Case REG_DWORD
            If vValue = True Then
                lValue = 1
            ElseIf vValue = False Then
                lValue = 0
            End If
            SetValueEx = RegSetValueExLong(hkey, sValueName, 0&, lType, lValue, 4)
        Case REG_DWORD_BIG_ENDIAN
            lValue = Val(vValue)
            SetValueEx = RegSetValueExLong(hkey, sValueName, 0&, lType, lValue, 4)
        End Select
End Function

Rem Win32 API Registry Specialized Function
Rem SHOULD NOT BE CALLED DIRECTLY -- Use GetKeyValue() instead

Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch - 1)
            Else
                vValue = Empty
            End If
        ' For DWORDS
        Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
lValue, cch)
            If lrc = ERROR_NONE Then
                If lValue = 0 Then
                    vValue = False
                ElseIf lValue = 1 Then
                    vValue = True
                End If
            End If
        Case REG_DWORD_BIG_ENDIAN
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then
                vValue = CLng(lValue)
            End If
        Case Else
            'all other data types not supported
            lrc = -1
    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function
   

Public Function CreateNewKey(sNewKeyName As String, lPredefinedKey As Long) As Long
    'This function encapsulates the Win32 RegCreateKeyEX API call
    '
    'Entry:
    '  sNewKeyName is the name of the key to create or open (ie. "Cyber3\teacher")
    '  lPredefinedKey is the Key Section to use (ie. HKEY_LOCAL_MACHINE)
    '
    'Return Value:
    '  REG_CREATED_NEW_KEY is returned if the specified key DID NOT exist already
    '  REG_OPENED_EXISTING_KEY is returned if the key already existed
    '  INVALIDKEY is returned if the operation was unsuccessful
   
    Dim SA As SECURITY_ATTRIBUTES   'security structure
    Dim hNewKey As Long         'handle to the new key
    Dim lRetVal As Long         'result of the RegCreateKeyEx function
    Dim CreatVal As Long        'whether key was created or existed already
   
    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, _
              vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
              SA, hNewKey, CreatVal)
    If lRetVal = ERROR_SUCCESS Then
        CreateNewKey = CreatVal
    Else
        CreateNewKey = INVALIDKEY
    End If
   
    RegCloseKey (hNewKey)
       
End Function


Public Function GetKeyVal(lPredefinedKey As Long, sKeyName As String, sValueName As String) _
    As Variant
   
    'Entry:
    '   lPredefinedKey = either HKEY_LOCAL_MACHINE or HKEY_LOCAL_USER
    '   sKeyName = path to the key that contains the value you want (ie. "SOFTWARE\Cyber3")
    '   sValueName = the name of the keyvalue to get (ie. "Menus")
    'Return:
    '   The value returned is the value of the specified key, as Variant
    '   It should be assigned to a variable of the correct type (String or Integer) before use
   
    Dim lRetVal As Long         'result of the API functions
    Dim hkey As Long         'handle of opened key
    Dim vValue As Variant      'setting of queried value

    lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, _
        KEY_ALL_ACCESS, hkey)
   
    lRetVal = QueryValueEx(hkey, sValueName, vValue)
   
    GetKeyVal = vValue
   
    RegCloseKey (hkey)
End Function


Then you can use these functions to create an association:
*NOTE: I used a fake program and association.


Dim sPath As String
    Dim strPathIcon As String
  'File Associations begin with a listing
  'of the default extension under HKEY_CLASSES_ROOT.
  'So the first step is to create that
  'root extension item
   CreateNewKey ".s2g", HKEY_CLASSES_ROOT
   
   
  'To the extension just added, add a
  'subitem where the registry will look for
  'commands relating to the .xxx extension
  '("MyApp.Document"). Its type is String (REG_SZ)
   SetKeyVal HKEY_CLASSES_ROOT, ".s2g", "", "s2gfile", REG_SZ
   
   
  'Create the 'MyApp.Document' item under
  'HKEY_CLASSES_ROOT. This is where you'll put
  'the command line to execute or other shell
  'statements necessary.
   CreateNewKey "s2gfile\shell\open\command", HKEY_CLASSES_ROOT
   CreateNewKey "s2gfile\defaulticon", HKEY_CLASSES_ROOT
   
  'Set its default item to "MyApp Document".
  'This is what is displayed in Explorer against
  'for files with a xxx extension. Its type is
  'String (REG_SZ)
   SetKeyVal HKEY_CLASSES_ROOT, "s2gfile", "", "Scan2Gold Image", REG_SZ
   
   
  'Finally, add the path to myapp.exe
  'Remember to add %1 as the final command
  'parameter to assure the app opens the passed
  'command line item.
  '(results in '"c:\LongPathname\Myapp.exe %1")
  'Again, its type is string.
   If Right(txtUNC, 1) <> "\" Then
        strPathIcon = txtUNC & "\S2gView.exe,0"
        sPath = txtUNC & "\S2gView.exe %1"
   Else
        strPathIcon = txtUNC & "S2gView.exe,0"
        sPath = txtUNC & "S2gView.exe %1"
   End If
   SetKeyVal HKEY_CLASSES_ROOT, "s2gfile\defaulticon", "", strPathIcon, REG_SZ
   
   SetKeyVal HKEY_CLASSES_ROOT, "s2gfile\shell\open\command", "", sPath, REG_SZ
0
 

Author Comment

by:Ra
ID: 2759207
Thanks richking, your modlue works perfectly.  I'm gonna look at your module and try to figure out what is wrong with the one I was using.

Thanks everyone for all the help.
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now