[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 702
  • Last Modified:

Piddle!

VB6

Hi experts.

Given a path I would like to be able to retrieve the Pidl

Whoa! Stop! Not so fast!

I've heard of SHSimpleIDListFromPath, and of SHILCreateFromPath

Those are fine and dandy, except, all they give you is a pointer - a Long.

I need more than just a long. I need to get my grubby little hands on all them lurvely bytes. If I KNEW that the number of bytes was fixed I could do something with a copymem. But I don't know that, and I don't get any definitive answers anywhere.

But I can't figure out how to get from having the pointer to establishing what all those bytes are. I didn't find anything helpful on t'internet.

Cheers
0
WernerVonBraun
Asked:
WernerVonBraun
  • 13
  • 4
2 Solutions
 
WernerVonBraunAuthor Commented:
looking at a few Pidls relating to Folders I did notice that they all seemed to end with the hexadecimal byte values 14, 00, 00, 00

Was that a coincidence, or could I use that information to establish where a Pidl ends?
0
 
WernerVonBraunAuthor Commented:
forget it. That is clearly a red herring. Back to Square One
0
 
Guy Hengel [angelIII / a3]Billing EngineerCommented:
the double 00 00 is where the string ends. C string notation.
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
WernerVonBraunAuthor Commented:
Except there are a lot of 00 00s in the middle of the Pidls I found. I think there might be one within each Item ID?
0
 
Guy Hengel [angelIII / a3]Billing EngineerCommented:
yes, exactly.
so, you need to "split" the result by the "00 00", and the full result is ended by "00 00 00 00"
0
 
WernerVonBraunAuthor Commented:
No, that doesn't seem to be it either. In the Pidl I am looking at there is a series of 19 consecutive "00"s embedded in the middle of the Pidl (that rhymes!)

You'd think that given a Long handle for a Pidl ... surely there would be a simple API call that would give you the length in bytes somehow? Or am I being naive? I've been known to be naive in the past so it is a strong possibility.

Once I have the pointer to the first byte, and the length in bytes it should be a simple CopyMem into a byte array that has been suitably initialised?

0
 
Guy Hengel [angelIII / a3]Billing EngineerCommented:
ok, let's see: why do you need that PIDL, actually?
0
 
nffvrxqgrcfqvvcCommented:
Are you looking for your own way to convert the long pointer to a path?
Option Explicit
 
Private Declare Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
Private Declare Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
    
Public Function StringToPIDL(ByVal szPath As String) As Long
  ' Create PIDL from string.
  Dim lpPIDL    As Long
  
  Call SHParseDisplayName(StrPtr(szPath), 0, lpPIDL, 0, 0)
  StringToPIDL = lpPIDL
  
End Function
 
Public Function PIDLToString(ByVal dwPidl As Long) As String
  ' Return string from PIDL
  Dim Buffer(8192 - 1) As Byte
  
  Call SHGetPathFromIDListW(dwPidl, VarPtr(Buffer(0)))
  PIDLToString = Left$(Buffer, lstrlenW(StrPtr(Buffer)))
  Erase Buffer
  
End Function

Open in new window

0
 
WernerVonBraunAuthor Commented:
Hello angelIII, egl1044,

Ok, let me elaborate a bit on the background of this request.

In Microsoft Office it is possible to change the default "places" that appear in the toolbar on the left in the Save As or Open dialogs. This corresponds with a Registry key:

HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Common\Open Find\Places\UserDefinedPlaces

Each path is represented by a "PlaceN" subkey, starting with "Place0", then "Place1" etc.

In that key there is a Name value and a Pidl value. The Pidl value is REG_BINARY. There are also some DWORD values but I won't go into those.

You can easily try this yourself. Go into, say, "Word", and go Save As, browse to a folder, and then in the Save As dialog click on Tools and go Add to My Places. After that you can see it in your own registry.



The problem is this: we want to create a bit of software that monitors a particular folder. Then, whenever a document is dropped into that folder, it will notice, and launch an action. Now then, as soon as this monitor program is launched, and it is running in the background, I want to add the folder that we are monitoring to "My Places". And when the monitor program is closed I want to revert back to normal.

I therefore need to add it programmatically. Now I *KNOW* that you can get away with just writing the Name and a Path variable, and the first time you use Save As in an MS Office product it will do the conversion from Path to Pidl in the background. I do know that. So I could just leave it at that. But I'm a geek and I want to know how it's done.

It's very easy to read the Pidl out of the registry, and use SHGetPathFromIDList to convert it to the actual Path in string format. All I need to do is read the data into a byte array, and pass the VarPtr to byte 0 as the first parameter. Robert's your mother's brother.


But if I wanted to WRITE a Pidl to the registry, this isn't good enough. SHSimpleIDListFromPath, and  SHILCreateFromPath don't produce Byte Arrays, they produce only a pointer (which, btw, doesn't appear to work for me either, it always seems to come back as 0 - and any documentation on t' web hints at these functions being deprecated? So what is current then?)

The pointer would be grand if only I knew how many bytes to retrieve. But I don't. So I'm stuck.


Cheers


Pino
0
 
Guy Hengel [angelIII / a3]Billing EngineerCommented:
let's see if this helps:
http://www.tech-archive.net/Archive/Word/microsoft.public.word.vba.general/2007-12/msg00479.html
Sub NewMyPlacesFldr()
 
strMyPlaceName = "Testing Folder"
strMyPlacePath = "C:\Test"
 
On Error Resume Next
 
Const HKEY_CURRENT_USER = &H80000001
strComputer = "."
 
Set objRegistry = GetObject("winmgmts:\\" & _
strComputer & "\root\default:StdRegProv")
 
strKeyPath = "Software\Microsoft\Office\" _
& Application.Version & "\Common\Open Find\Places\UserDefinedPlaces"
objRegistry.EnumKey HKEY_CURRENT_USER, strKeyPath, arrSubkeys
 
intNew = -1
 
For Each objSubkey In arrSubkeys
intPlace = CInt(Right(objSubkey, Len(objSubkey) - 5))
If intPlace > intNew Then
intNew = intPlace
End If
Next
 
intNew = intNew + 1
 
strKeyPathNew = strKeyPath & "\Place" & CStr(intNew)
objRegistry.CreateKey HKEY_CURRENT_USER, strKeyPathNew
 
strValue = strMyPlaceName
strValueName = "Name"
objRegistry.SetStringValue HKEY_CURRENT_USER, _
strKeyPathNew, strValueName, strValue
 
strValue = strMyPlacePath
strValueName = "Path"
objRegistry.SetStringValue HKEY_CURRENT_USER, _
strKeyPathNew, strValueName, strValue
 
End Sub

Open in new window

0
 
WernerVonBraunAuthor Commented:
Yes, that's what I said :-)

What I'd like to do is replace the bit where you set the "Path" value with one where you write the actual Pidl



I know, I know. I'm a geek.

However, I think I may have made a bit of progress. I just found out a couple of small things:

Firstly, there is an ILCreateFromPath function that appears to be current. It, too returns a Long.

Secondly, the reason the functions were returning 0 is due to the format of the string. I should convert the string to Unicode. Doing that gets it to return data no problem.

Finally, there is an ILGetSize function. I think that with that I can get what I need.


Watch this space, I'll let you know what I find.


Pino
0
 
WernerVonBraunAuthor Commented:
ok

First of all, as an aside and off topic for this particular thread, I used a Registry class that I found on the web. It does the job most of the time, BUT it has a bug in setting a registry value of type REG_BINARY. You pass in a byte array for that, and it calculated the size as Ubound - LBound [shock, horror] - 1

That should be PLUS 1, of course. A byte array Dim-ed as (1 to 5) has 5 elements, i.e. 5 - 1 + 1, and not 3 as it calculated as 5 - 1 - 1. It makes no difference whether it is a 0-based array either. An array Dim-ed (0 to 4) still has 4 - 0 + 1 = 5 elements, and not 4 - 0 - 1 = 3 !

Annoying when you have to fix bugs like that :-)


' #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
' *
' **********************************************************************
 
Option Explicit
 
' *** 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 = CLng(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 = CStr(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 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

Open in new window

0
 
WernerVonBraunAuthor Commented:
Offending piece of code:

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
'''AAARRGGHHH               c = UBound(ab) - LBound(ab) - 1    '<--- EEEEEEEEEKKKK!!!!!! SHOULD BE:
               c = UBound(ab) - LBound(ab) + 1    '<--- THAT's better.
               e = RegSetValueExByte(hKey, m_sValueKey, 0&, ordType, ab(0), c)
            Else
               Err.Raise 26001
            End If

Open in new window

0
 
WernerVonBraunAuthor Commented:
Other than that, all you need is these declarations:


Private Declare Function ILCreateFromPath Lib "shell32" (ByVal sPath As String) As Long
Private Declare Function ILGetSize Lib "shell32" (ByVal lPidl As Long) As Long
Private Declare Sub ILFree Lib "shell32" (ByVal lPidl As Long)
 
Private Declare Sub CopyMemLong _
                Lib "kernel32" _
              Alias "RtlMoveMemory" _
                   (ByVal Destination As Long, _
                    ByVal Source As Long, _
                    ByVal Length As Long)

Open in new window

0
 
WernerVonBraunAuthor Commented:
And other than that it's just a case of:


Dim lOut As Long
Dim lPidlLen As Long
Dim bytData() As Byte
 
 
'[...]
 
        lOut = ILCreateFromPath(StrConv(msPersonalPath, vbUnicode))
        lPidlLen = ILGetSize(lOut)
        ReDim bytData(0 To lPidlLen - 1)
        CopyMemLong VarPtr(bytData(0)), lOut, lPidlLen
        ILFree lOut
        
        objReg.ValueKey = "Pidl"
        objReg.ValueType = REG_BINARY
        objReg.Value = bytData

Open in new window

0
 
WernerVonBraunAuthor Commented:
Oops. Obviously msPersonalPath is a string that contains the Path.
0
 
WernerVonBraunAuthor Commented:
I've just split the points between you two. I know I figured it out myself but I'm not stingy. Enjoy.


Produced by Rozeboosje

25 February 2009

Thank you for watchiing

Re-boot your mind
0
 
WernerVonBraunAuthor Commented:
> watchiing

damn this bouncy keyboard :-)
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 13
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now