Registry Module (windows only)

Share your advanced PureBasic knowledge/code with the community.
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Registry Module (windows only)

Post by ts-soft »

A small Modul to use the Registry on Windows.

Functions:
Delete Value or Key.
Read Entry.
Write Entrys.
...

Supports for Read and Write:
#REG_BINARY (requires the *Ret.RegValue parameter)
#REG_DWORD
#REG_QWORD
#REG_SZ
#REG_EXPAND_SZ (auto expanded on read)
#REG_MULTI_SZ (the result is a String with #LF$ as separator, the same for value)

Wow6432Node is supported as flag!
x86, x64, ascii and unicode supported.

Code: Select all

;======================================================================
; Module:          Registry.pbi
;
; Author:          Thomas (ts-soft) Schulz
; Date:            Sep 04, 2015
; Version:         1.5.0
; Target Compiler: PureBasic 5.2+
; Target OS:       Windows
; License:         Free, unrestricted, no warranty whatsoever
;                  Use at your own risk
;======================================================================

; History:
; Version 1.5.0, Sep 04, 2015
; fixed for Use with PB5.40 and higher

; Version 1.4.2, Jun 27, 2014
; fixed WriteValue

; Version 1.4.1, Sep 02, 2013
; fixed XP_DeleteTree()

; Version 1.4, Sep 02, 2013
; fixed Clear Resultstructure
; + compatibility to WinXP

; Version 1.3.3, Sep 01, 2013
; + Clear Resultstructure

; Version 1.3.2, Aug 31, 2013
; fixed a Bug with WriteValue and Unicode

; Version 1.3.1, Aug 30, 2013
; + DeleteTree() ; Deletes the subkeys and values of the specified key recursively.

; Version 1.3, Aug 30, 2013
; + ErrorString to RegValue Structure
; + RegValue to all Functions
; RegValue holds Errornumber and Errorstring!
; Renamed CountValues to CountSubValues

; Version 1.2.1, Aug 25, 2013
; source length reduced with macros

; Version 1.2, Aug 25, 2013
; + CountSubKeys()
; + CountValues()
; + ListSubKey()
; + ListSubValue()
; + updated example
;
; Version 1.1, Aug 25, 2013
; + ReadValue for #REG_BINARY returns a comma separate string with hexvalues (limited to 2096 bytes)
; + small example

DeclareModule Registry
  Structure RegValue
    TYPE.l      ; like: #REG_BINARY, #REG_DWORD ...
    SIZE.l
    ERROR.l
    ERRORSTR.s
    DWORD.l     ; #REG_DWORD
    QWORD.q     ; #REG_QWORD
    *BINARY     ; #REG_BINARY
    STRING.s    ; #REG_EXPAND_SZ, #REG_MULTI_SZ, #REG_SZ
  EndStructure
 
  Enumeration -1 Step -1
    #REG_ERR_ALLOCATE_MEMORY
    #REG_ERR_BINARYPOINTER_MISSING
    #REG_ERR_REGVALUE_VAR_MISSING
  EndEnumeration
 
  Declare.i ReadType(topKey,                  ; like #HKEY_LOCAL_MACHINE, #HKEY_CURRENT_USER, #HKEY_CLASSES_ROOT ...
                     KeyName.s,               ; KeyName without topKey
                     ValueName.s = "",        ; ValueName, "" for Default
                     WOW64 = #False,          ; If #TRUE, uses the 'Wow6432Node' path for Key
                     *Ret.RegValue = 0)         
  ; result 0 = error or #REG_NONE (not supported)
 
  Declare.s ReadValue(topKey,
                      KeyName.s,
                      ValueName.s = "",
                      WOW64 = #False,
                      *Ret.RegValue = 0)
  ; result "" = error
 
  Declare.i WriteValue(topKey,
                       KeyName.s,
                       ValueName.s,
                       Value.s,              ; Value as string
                       Type.l,               ; Type like: #REG_DWORD, #REG_EXPAND_SZ, #REG_SZ
                       WOW64 = #False,
                       *Ret.RegValue = 0)    ; to return more infos, is required for #REG_BINARY!
  ; result 0 = error, > 0 = successfull (1 = key created, 2 = key opened)
 
  Declare.i DeleteTree(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
  ; Deletes the subkeys and values of the specified key recursively.
  ; result 0 = error
 
  Declare.i DeleteKey(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
  ; result 0 = error
 
  Declare.i DeleteValue(topKey, KeyName.s, ValueName.s, WOW64 = #False, *Ret.RegValue = 0)
  ; result 0 = error
 
  Declare.i CountSubKeys(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
 
  Declare.i CountSubValues(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
 
  Declare.s ListSubKey(topKey, KeyName.s, index, WOW64 = #False, *Ret.RegValue = 0) ; the index is 0-based!
 
  Declare.s ListSubValue(topKey, KeyName.s, index, WOW64 = #False, *Ret.RegValue = 0)
 
EndDeclareModule

Module Registry
  EnableExplicit
 
  Prototype RegDeleteKey(hKey.i, lpSubKey.p-Unicode, samDesired.l, Reserved.l = 0)
  Prototype RegSetValue(hKey.i, lpValueName.p-Unicode, Reserved.l, dwType.l, *lpData, cbData.l)
  Prototype RegDeleteTree(hKey.i, lpSubKey.p-Unicode = 0)
  Prototype RegEnumKeyEx(hKey.i, dwIndex.l, *lpName, *lpcName, *lpReserved, *lpClass, *lpcClass, *lpftLastWriteTime)
  Prototype ExpandEnvironmentStrings(*lpSrc, *lpDst, nSize.l)
  
  Global RegDeleteKey.RegDeleteKey
  Global RegSetValue.RegSetValue
  Global RegDeleteTree.RegDeleteTree
  Global RegEnumKeyEx.RegEnumKeyEx
  Global ExpandEnvironmentStrings.ExpandEnvironmentStrings
  
  Define dll.i
 
  dll = OpenLibrary(#PB_Any, "Advapi32.dll")
  If dll
    RegDeleteKey = GetFunction(dll, "RegDeleteKeyExW")
    RegSetValue = GetFunction(dll, "RegSetValueExW")
    RegDeleteTree = GetFunction(dll, "RegDeleteTreeW")
    RegEnumKeyEx = GetFunction(dll, "RegEnumKeyExW")
    ExpandEnvironmentStrings = GetFunction(dll, "ExpandEnvironmentStringsW")
  EndIf
 
  #KEY_WOW64_64KEY = $100
  #KEY_WOW64_32KEY = $200
 
  Macro OpenKey()
    If WOW64
      CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
        samDesired | #KEY_WOW64_64KEY
      CompilerElse
        samDesired | #KEY_WOW64_32KEY
      CompilerEndIf
    EndIf
   
    If Left(KeyName, 1) = "\"  : KeyName = Right(KeyName, Len(KeyName) - 1) : EndIf
    If Right(KeyName, 1) = "\" : KeyName = Left(KeyName, Len(KeyName) - 1)  : EndIf
   
    If *Ret <> 0
      ClearStructure(*Ret, RegValue)
    EndIf
   
    error = RegOpenKeyEx_(topKey, KeyName, 0, samDesired, @hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      If hKey
        RegCloseKey_(hKey)
      EndIf
      ProcedureReturn #False
    EndIf
  EndMacro
 
  Macro OpenKeyS()
    If WOW64
      CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
        samDesired | #KEY_WOW64_64KEY
      CompilerElse
        samDesired | #KEY_WOW64_32KEY
      CompilerEndIf
    EndIf
   
    If Left(KeyName, 1) = "\"  : KeyName = Right(KeyName, Len(KeyName) - 1) : EndIf
    If Right(KeyName, 1) = "\" : KeyName = Left(KeyName, Len(KeyName) - 1)  : EndIf
   
    If *Ret <> 0
      ClearStructure(*Ret, RegValue)
    EndIf
   
    error = RegOpenKeyEx_(topKey, KeyName, 0, samDesired, @hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      If hKey
        RegCloseKey_(hKey)
      EndIf
      ProcedureReturn ""
    EndIf
  EndMacro
 
  Procedure.s GetLastErrorStr(error)
    Protected Buffer.i, result.s
   
    If FormatMessage_(#FORMAT_MESSAGE_ALLOCATE_BUFFER | #FORMAT_MESSAGE_FROM_SYSTEM, 0, error, 0, @Buffer, 0, 0)
      result = PeekS(Buffer)
      LocalFree_(Buffer)
     
      ProcedureReturn result
    EndIf
  EndProcedure
 
  Procedure.i XP_DeleteTree(topKey, KeyName.s, *Ret.RegValue = 0)
    Protected hKey, error, dwSize.l, sBuf.s = Space(260)
   
    If Left(KeyName, 1) = "\"  : KeyName = Right(KeyName, Len(KeyName) - 1) : EndIf
    If Right(KeyName, 1) = "\" : KeyName = Left(KeyName, Len(KeyName) - 1)  : EndIf
   
    If *Ret <> 0
      ClearStructure(*Ret, RegValue)
    EndIf
   
    error = RegOpenKeyEx_(topKey, KeyName, 0, #KEY_ENUMERATE_SUB_KEYS, @hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      If hKey
        RegCloseKey_(hKey)
      EndIf
      ProcedureReturn #False
    EndIf
   
    Repeat
      dwSize.l = 260
      error = RegEnumKeyEx(hKey, 0, @sBuf, @dwSize, 0, 0, 0, 0)
      If Not error
        XP_DeleteTree(hKey, sBuf)
      EndIf
    Until error
    RegCloseKey_(hKey)
    error = RegDeleteKey_(topKey, KeyName)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
   
    ProcedureReturn #True   
  EndProcedure
 
  Procedure.i DeleteTree(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_ALL_ACCESS
    Protected hKey
   
    If RegDeleteTree = 0
      ProcedureReturn XP_DeleteTree(topKey, KeyName, *Ret)
    EndIf
   
    OpenKey()
   
    error = RegDeleteTree(hKey)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
    ProcedureReturn #True   
  EndProcedure
 
  Procedure.i DeleteKey(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_WRITE
   
    If WOW64
      CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
        samDesired | #KEY_WOW64_64KEY
      CompilerElse
        samDesired | #KEY_WOW64_32KEY
      CompilerEndIf
    EndIf
   
    If Left(KeyName, 1) = "\"  : KeyName = Right(KeyName, Len(KeyName) - 1) : EndIf
    If Right(KeyName, 1) = "\" : KeyName = Left(KeyName, Len(KeyName) - 1)  : EndIf
   
    If RegDeleteKey
      error = RegDeleteKey(topKey, KeyName, samDesired)
    Else
      error = RegDeleteKey_(topKey, KeyName)
    EndIf
    If error
      If *Ret <> 0
        ClearStructure(*Ret, RegValue)
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
    ProcedureReturn #True
  EndProcedure
 
  Procedure.i DeleteValue(topKey, KeyName.s, ValueName.s, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_WRITE
    Protected hKey
   
    OpenKey()
   
    error = RegDeleteValue_(hKey, ValueName)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
    ProcedureReturn #True         
  EndProcedure
 
  Procedure.i CountSubKeys(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_READ
    Protected hKey, count
   
    OpenKey()
   
    error = RegQueryInfoKey_(hKey, 0, 0, 0, @count, 0, 0, 0, 0, 0, 0, 0)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
    ProcedureReturn count
  EndProcedure
 
  Procedure.s ListSubKey(topKey, KeyName.s, index, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_READ
    Protected hKey, size, result.s
   
    OpenKeyS()
   
    error = RegQueryInfoKey_(hKey, 0, 0, 0, 0, @size, 0, 0, 0, 0, 0, 0)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      RegCloseKey_(hKey)
      ProcedureReturn ""
    EndIf
    size + 1
    result = Space(size)
    error = RegEnumKeyEx(hKey, index, @result, @size, 0, 0, 0, 0)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn ""
    EndIf
    ProcedureReturn result   
  EndProcedure
 
  Procedure.i CountSubValues(topKey, KeyName.s, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_READ
    Protected hKey, count
   
    OpenKey()
   
    error = RegQueryInfoKey_(hKey, 0, 0, 0, 0, 0, 0, @count, 0, 0, 0, 0)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
    ProcedureReturn count
  EndProcedure
 
  Procedure.s ListSubValue(topKey, KeyName.s, index, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_READ
    Protected hKey, size, result.s
   
    OpenKeyS()
   
    error = RegQueryInfoKey_(hKey, 0, 0, 0, 0, 0, 0, 0, @size, 0, 0, 0)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      RegCloseKey_(hKey)
      ProcedureReturn ""
    EndIf
    size + 1
    result = Space(size)
    error = RegEnumValue_(hKey, index, @result, @size, 0, 0, 0, 0)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn ""
    EndIf
    ProcedureReturn result   
  EndProcedure
 
  Procedure.i ReadType(topKey, KeyName.s, ValueName.s = "", WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_READ
    Protected hKey, lpType
   
    OpenKey()
   
    error = RegQueryValueEx_(hKey, ValueName, 0, @lpType, 0, 0)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
    ProcedureReturn lpType         
  EndProcedure
 
  Procedure.s ReadValue(topKey, KeyName.s, ValueName.s = "", WOW64 = #False, *Ret.RegValue = 0)
    Protected error, result.s, samDesired = #KEY_READ
    Protected hKey, lpType.l, *lpData, lpcbData.l, ExSZlength, *ExSZMem, i
   
    OpenKeyS()
   
    error = RegQueryValueEx_(hKey, ValueName, 0, 0, 0, @lpcbData)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      RegCloseKey_(hKey)
      ProcedureReturn ""
    EndIf
   
    If lpcbData
      *lpData = AllocateMemory(lpcbData)
      If *lpData = 0
        If *Ret <> 0
          *Ret\ERROR = #REG_ERR_ALLOCATE_MEMORY
          *Ret\ERRORSTR = "Error: Can't allocate memory"
        EndIf
        Debug "Error: Can't allocate memory"
        RegCloseKey_(hKey)
        ProcedureReturn ""
      EndIf
    EndIf
   
    error = RegQueryValueEx_(hKey, ValueName, 0, @lpType, *lpData, @lpcbData)
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      FreeMemory(*lpData)
      ProcedureReturn ""
    EndIf   
   
    If *Ret <> 0
      *Ret\TYPE = lpType
    EndIf
   
    Select lpType
      Case #REG_BINARY
        If lpcbData <= 2096
          For i = 0 To lpcbData - 1
            result + "$" + RSet(Hex(PeekA(*lpData + i)), 2, "0") + ","
          Next
        Else
          For i = 0 To 2095
            result + "$" + RSet(Hex(PeekA(*lpData + i)), 2, "0") + ","
          Next
        EndIf
        result = Left(result, Len(result) - 1)
        If *Ret <> 0
          *Ret\BINARY = *lpData
          *Ret\SIZE = lpcbData
        EndIf
        ProcedureReturn result ; we don't free the memory!
       
      Case #REG_DWORD
        If *Ret <> 0
          *Ret\DWORD = PeekL(*lpData)
          *Ret\SIZE = SizeOf(Long)
        EndIf
        result = Str(PeekL(*lpData))
       
      Case #REG_EXPAND_SZ
        ExSZlength = ExpandEnvironmentStrings(*lpData, 0, 0)
        If ExSZlength > 0
          *ExSZMem = AllocateMemory(ExSZlength)
          If *ExSZMem
            If ExpandEnvironmentStrings(*lpData, *ExSZMem, ExSZlength)
              result = PeekS(*ExSZMem)
              If *Ret <> 0
                *Ret\STRING = result
                *Ret\SIZE = Len(result)
              EndIf
            EndIf
            FreeMemory(*ExSZMem)
          EndIf
        Else
          Debug "Error: Can't allocate memory"
        EndIf
       
      Case #REG_MULTI_SZ
        While i < lpcbData
          If PeekS(*lpData + i, 1) = ""
            result + #LF$
          Else
            result + PeekS(*lpData + i, 1)
          EndIf
          i + SizeOf(Character)
        Wend
        If Right(result, 1) = #LF$
          result = Left(result, Len(result) - 1)
        EndIf
        If *Ret <> 0
          *Ret\STRING = result
          *Ret\SIZE = Len(result)
        EndIf
       
      Case #REG_QWORD
        If *Ret <> 0
          *Ret\QWORD = PeekQ(*lpData)
          *Ret\SIZE = SizeOf(Quad)
        EndIf
        result = Str(PeekQ(*lpData))
       
      Case #REG_SZ
        result = PeekS(*lpData)
        If *Ret <> 0
          *Ret\STRING = result
          *Ret\SIZE = Len(result)
        EndIf
    EndSelect
   
    FreeMemory(*lpData)
   
    ProcedureReturn result
  EndProcedure
 
  Procedure.i WriteValue(topKey, KeyName.s, ValueName.s, Value.s, Type.l, WOW64 = #False, *Ret.RegValue = 0)
    Protected error, samDesired = #KEY_WRITE
    Protected hKey, *lpData, lpcbData.q, count, create, i, tmp.s, pos, temp1.l, temp2.q
   
    If WOW64
      CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
        samDesired | #KEY_WOW64_64KEY
      CompilerElse
        samDesired | #KEY_WOW64_32KEY
      CompilerEndIf
    EndIf
   
    If Left(KeyName, 1) = "\"  : KeyName = Right(KeyName, Len(KeyName) - 1) : EndIf
    If Right(KeyName, 1) = "\" : KeyName = Left(KeyName, Len(KeyName) - 1)  : EndIf
   
    If *Ret <> 0
      If Type <> #REG_BINARY
        ClearStructure(*Ret, RegValue)
      Else
        *Ret\TYPE = 0
        *Ret\ERROR = 0
        *Ret\ERRORSTR = ""
        *Ret\DWORD = 0
        *Ret\QWORD = 0
        *Ret\STRING = ""
      EndIf
    EndIf
   
    error = RegCreateKeyEx_(topKey, KeyName, 0, #Null$, 0, samDesired, 0, @hKey, @create)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      If hKey
        RegCloseKey_(hKey)
      EndIf
      ProcedureReturn #False
    EndIf
   
    Select Type
      Case #REG_BINARY
        If *Ret = 0
          If *Ret <> 0
            *Ret\ERROR = #REG_ERR_REGVALUE_VAR_MISSING
            *Ret\ERRORSTR = "Error: Required *Ret.RegValue parameter not found!"
          EndIf
          Debug "Error: Required *Ret.RegValue parameter not found!"
          RegCloseKey_(hKey)
          ProcedureReturn #False
        EndIf
        lpcbData = *Ret\SIZE
        *lpData = *Ret\BINARY
        If *lpData = 0
          If *Ret <> 0
            *Ret\ERROR = #REG_ERR_BINARYPOINTER_MISSING
            *Ret\ERRORSTR = "Error: No Pointer to BINARY defined!"
          EndIf
          Debug "Error: No Pointer to BINARY defined!"
          RegCloseKey_(hKey)
          ProcedureReturn #False         
        EndIf
        If lpcbData = 0
          lpcbData = MemorySize(*lpData)
        EndIf
        error = RegSetValueEx_(hKey, ValueName, 0, #REG_BINARY, *lpData, lpcbData)
       
      Case #REG_DWORD
        temp1 = Val(Value)
        error = RegSetValueEx_(hKey, ValueName, 0, #REG_DWORD, @temp1, 4)
       
      Case #REG_QWORD
        temp2 = Val(Value)
        error = RegSetValueEx_(hKey, ValueName, 0, #REG_QWORD, @temp2, 8)
       
      Case #REG_EXPAND_SZ, #REG_SZ
        error = RegSetValueEx_(hKey, ValueName, 0, Type, @Value, StringByteLength(Value) + SizeOf(Character))
       
      Case #REG_MULTI_SZ
        count = CountString(Value, #LF$)
        For i = 0 To count
          tmp = StringField(Value, i + 1, #LF$)
          lpcbData + StringByteLength(tmp, #PB_Unicode) + 2
        Next
        If lpcbData
          *lpData = AllocateMemory(lpcbData)
          If *lpData
            For i = 0 To count
              tmp = StringField(Value, i + 1, #LF$)
              PokeS(*lpData + pos, tmp, -1, #PB_Unicode)
              pos + StringByteLength(tmp, #PB_Unicode) + 2
            Next
            error = RegSetValue(hKey, ValueName, 0, Type, *lpData, lpcbData)
            FreeMemory(*lpData)
          Else
            If *Ret <> 0
              *Ret\ERROR = #REG_ERR_ALLOCATE_MEMORY
              *Ret\ERRORSTR = "Error: Can't allocate memory"
            EndIf
            Debug "Error: Can't allocate memory"
            RegCloseKey_(hKey)
            ProcedureReturn #False           
          EndIf
        EndIf
       
    EndSelect
   
    RegCloseKey_(hKey)
    If error
      If *Ret <> 0
        *Ret\ERROR = error
        *Ret\ERRORSTR = GetLastErrorStr(error)
      EndIf
      Debug GetLastErrorStr(error)
      ProcedureReturn #False
    EndIf
   
    ProcedureReturn create         
  EndProcedure
 
EndModule

CompilerIf #PB_Compiler_IsMainFile
  EnableExplicit
 
  Define count, i
 
  count = Registry::CountSubValues(#HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices")
  For i = 0 To count - 1
    Debug Registry::ListSubValue(#HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", i)
  Next
 
  Debug "-----------------------"
 
  UseModule Registry
 
  Define.s Multi_SZ_Str = "ts-soft" + #LF$ + "Software-Development" + #LF$ + #LF$ + "Copyright 2013" + #LF$ + "Programmed in PureBasic"
 
  If  WriteValue(#HKEY_CURRENT_USER, "Software\ts-soft", "demo", Multi_SZ_Str, #REG_MULTI_SZ)
    Debug ReadValue(#HKEY_CURRENT_USER, "Software\ts-soft", "demo")
    Select MessageRequester("Registry-Example", "Delete the demo Registry-Value?", #PB_MessageRequester_YesNo)
      Case #PB_MessageRequester_Yes
        If DeleteValue(#HKEY_CURRENT_USER, "Software\ts-soft", "demo")
          Debug "Value deleted"
        Else
          Debug "Value not deleted"
        EndIf
    EndSelect
  EndIf
CompilerEndIf
Have fun
Last edited by ts-soft on Fri Sep 04, 2015 4:04 pm, edited 13 times in total.
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
yrreti
Enthusiast
Enthusiast
Posts: 546
Joined: Tue Oct 31, 2006 4:34 am

Re: Registry Module (windows only)

Post by yrreti »

Hi ts-soft
I haven't got any free time right now to test this stuff, but thanks very very much for this.

yrreti
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Re: Registry Module (windows only)

Post by ts-soft »

Update:
History wrote:; Version 1.1, Aug 25, 2013
; + ReadValue for #REG_BINARY returns a comma separate string with hexvalues (limited to 2096 bytes)
; + small example
History wrote:; Version 1.2, Aug 25, 2013
; + CountSubKeys()
; + CountValues()
; + ListSubKey()
; + ListSubValue()
; + updated example
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
User avatar
NoahPhense
Addict
Addict
Posts: 1999
Joined: Thu Oct 16, 2003 8:30 pm
Location: North Florida

Re: Registry Module (windows only)

Post by NoahPhense »

Nice, needed a new one of these. Thanks.
VoSs2o0o
User
User
Posts: 24
Joined: Fri Aug 06, 2010 11:46 pm

Re: Registry Module (windows only)

Post by VoSs2o0o »

Thank you!,
I have replaced the old Code with this module. :D
RomanR
User
User
Posts: 16
Joined: Wed Jul 11, 2012 3:54 pm

Re: Registry Module (windows only)

Post by RomanR »

Thank you very much!

This is exactly what I was looking for! :D
I'm using this module to get the "FriendlyNames" of all available comm-ports - if interested, just tell me :wink:

I made 2 small changes though:

:arrow: I added 2 small Procedures:

(Declaration in DeclareModule)

Code: Select all

Declare.i RegError()                      ; true if error occured
Declare.s RegErrorText()               ; returns error text if error occured

Code: Select all

Global RegError.i, RegErrorText.s

Procedure.i RegError()
    ProcedureReturn RegError
EndProcedure
  
Procedure.s RegErrorText()
    ProcedureReturn RegErrorText
EndProcedure
:arrow: then I added 2 small Macros for all "Debug" statements, SetError is for Debug , UnsetError is for success (just bevore ProcedureReturn):
(Well I could place UnsetError at the beginning of the procedure for better readable code ...)

Code: Select all

Global ErrorText.s

Macro SetError(ErrorTxt)
    RegError = #True
    RegErrorText = ErrorTxt
    ;Debug ErrorTxt
EndMacro
  
Macro UnsetError
    RegError = #False
    RegErrorText = ""
EndMacro
Now it is possible to check always if an error occured, and get the error-text in the main program ...
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Re: Registry Module (windows only)

Post by ts-soft »

Update:
History wrote:; Version 1.3, Aug 30, 2013
; + ErrorString to RegValue Structure
; + RegValue to all Functions
; RegValue holds Errornumber and Errorstring!
; Renamed CountValues to CountSubValues
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
User avatar
NoahPhense
Addict
Addict
Posts: 1999
Joined: Thu Oct 16, 2003 8:30 pm
Location: North Florida

Re: Registry Module (windows only)

Post by NoahPhense »

Excellent.
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Re: Registry Module (windows only)

Post by ts-soft »

Thx.

Update:
History wrote:; Version 1.3.1, Aug 30, 2013
; + DeleteTree() ; Deletes the subkeys and values of the specified key recursively.
I think, it is complete

Update:
History wrote:; Version 1.3.2, Aug 31, 2013
; fixed a Bug with WriteValue and Unicode
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
RomanR
User
User
Posts: 16
Joined: Wed Jul 11, 2012 3:54 pm

Re: Registry Module (windows only)

Post by RomanR »

Hi ts-soft,

this is nearly perfect :D

I have just one question:

do I have to initialise the structure (RegValue) each time I get an error?

e.g.:

Code: Select all

UseModule Registry
Define RegReturn.RegValue

svc1 = CountSubValues(#HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E97D-E325-11CE-BFC1-08002BE10318}\0021", #False, RegReturn)
If Not RegReturn\ERROR
	For i3 = 0 To svc1 - 1
;		do something
	Next
Else
	Debug "SubKey: {4D36E97D-E325-11CE-BFC1-08002BE10318}\0021"
	Debug RegReturn\ERRORSTR
	ClearStructure(@RegReturn, RegValue)
EndIf
This particular key returns "access denied" ("Zugriff verweigert" german language :wink: ) on my system. If I don't clear the structure if an error occurs, all successive keys get the same error.
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Re: Registry Module (windows only)

Post by ts-soft »

Update:
History wrote:; Version 1.3.3, Sep 01, 2013
; + Clear Resultstructure
Structuremember Size and *BINARY not cleared, for WriteValue, if you
use #Reg_Binary (this can't work, as it is an in-out member)

Greetings - Thomas
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
RomanR
User
User
Posts: 16
Joined: Wed Jul 11, 2012 3:54 pm

Re: Registry Module (windows only)

Post by RomanR »

Hello ts-soft,

I think there is still a tiny bug:

i'm reading rekursively through the registry. But if one error occurs, it won't be cleared on the next call.

Code: Select all

EnableExplicit

XIncludeFile "Registry.pbi"

UseModule Registry

Define RegReturn.RegValue
Define ccsctrl.s = "SYSTEM\CurrentControlSet\Control\Class\{4D36E97D-E325-11CE-BFC1-08002BE10318}" ;  error only on Key 0021 and Properties
Define skc1, svc1, i1, i2, sk1.s, sv1.s

skc1 = CountSubKeys(#HKEY_LOCAL_MACHINE, ccsctrl, #False, @RegReturn)
For i1 = 0 To skc1 - 1
  sk1 = ListSubKey(#HKEY_LOCAL_MACHINE, ccsctrl, i1, #False, @RegReturn)
  svc1 = CountSubValues(#HKEY_LOCAL_MACHINE, ccsctrl + "\" + sk1, #False, @RegReturn)
  If Not RegReturn\ERROR
    For i2 = 0 To svc1 - 1
      sv1 = ListSubValue(#HKEY_LOCAL_MACHINE, ccsctrl + "\" + sk1, i2, #False, @RegReturn)
      Debug "Key: " + sk1 + " (" + Str(i2) + ") : " + sv1
    Next
  Else
    Debug "SubKey: " + sk1
    Debug RegReturn\ERRORSTR
  EndIf
  Debug "----------"
Next
Is it safe to clear RegReturn in the OpenKey/OpenKeyS Macros?

e.g.:

Code: Select all

If error
  If *Ret <> 0
    ClearStructure(*Ret, RegValue)
    *Ret\ERROR = error
    *Ret\ERRORSTR = GetLastErrorStr(error)
  EndIf
  Debug GetLastErrorStr(error)
  If hKey
    RegCloseKey_(hKey)
  EndIf
  ProcedureReturn #False
Else
  If *Ret <> 0
    ClearStructure(*Ret, RegValue)
  EndIf
EndIf
Damion12
User
User
Posts: 81
Joined: Tue Oct 30, 2012 1:39 am

Re: Registry Module (windows only)

Post by Damion12 »

Not sure what I'm doing wrong -- shouldn't both these sets of code result in the same thing:

Code: Select all

#basekey = "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts"
count = Registry::CountSubKeys(#HKEY_CURRENT_USER, #basekey)
For i = 0 To count - 1
	cWork.s = #basekey+"\"+Registry::ListSubKey(#HKEY_CURRENT_USER, #basekey, i)
	Debug cWork
	Debug Registry::ReadValue(#HKEY_CURRENT_USER, cWork, "Application")
Next
The above fails, below works.

Code: Select all

UseModule registry

#basekey = "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts"

count = CountSubKeys(#HKEY_CURRENT_USER, #basekey)
For i = 0 To count - 1
	cWork.s = #basekey+"\"+ListSubKey(#HKEY_CURRENT_USER, #basekey, i)
	Debug cWork
	Debug ReadValue(#HKEY_CURRENT_USER, cWork, "Application")
Next
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Re: Registry Module (windows only)

Post by ts-soft »

@Damion12
can't see any difference, only there is no member "application" in the registry!
(using Beta 15!)

@RomanR
Work's fine here, only you can't open "Properties" (also not as Admin! or in RegEdit.exe)
http://www.winvistatips.com/device-prop ... 24487.html
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image
Damion12
User
User
Posts: 81
Joined: Tue Oct 30, 2012 1:39 am

Re: Registry Module (windows only)

Post by Damion12 »

ts-soft wrote:@Damion12
can't see any difference, only there is no member "application" in the registry!
(using Beta 15!)
Weird that the second works fine. I also get IMA error on DeleteTree

Code: Select all

    OpenKey()
    error = RegDeleteTree(hKey) ;<< IMA Error here.
I am on b14; I try b15 later
Post Reply