It is currently Mon Aug 03, 2020 10:14 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 71 posts ]  Go to page 1, 2, 3, 4, 5  Next
Author Message
 Post subject: Registry Module (windows only)
PostPosted: Sat Aug 24, 2013 6:26 pm 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5755
Location: Berlin - Germany
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:
;======================================================================
; 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

_________________
PureBasic 5.71 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 19.3 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Last edited by ts-soft on Fri Sep 04, 2015 4:04 pm, edited 13 times in total.

Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sat Aug 24, 2013 8:16 pm 
Offline
Enthusiast
Enthusiast

Joined: Tue Oct 31, 2006 4:34 am
Posts: 534
Hi ts-soft
I haven't got any free time right now to test this stuff, but thanks very very much for this.

yrreti


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Aug 25, 2013 12:04 am 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5755
Location: Berlin - Germany
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.71 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 19.3 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Mon Aug 26, 2013 9:37 pm 
Offline
Addict
Addict
User avatar

Joined: Thu Oct 16, 2003 8:30 pm
Posts: 1998
Location: North Florida
Nice, needed a new one of these. Thanks.


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Wed Aug 28, 2013 1:36 pm 
Offline
User
User

Joined: Fri Aug 06, 2010 11:46 pm
Posts: 24
Thank you!,
I have replaced the old Code with this module. :D


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Wed Aug 28, 2013 9:27 pm 
Offline
User
User

Joined: Wed Jul 11, 2012 3:54 pm
Posts: 16
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:
Declare.i RegError()                      ; true if error occured
Declare.s RegErrorText()               ; returns error text if error occured


Code:
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:
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 ...


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Fri Aug 30, 2013 8:00 pm 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5755
Location: Berlin - Germany
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.71 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 19.3 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Fri Aug 30, 2013 8:32 pm 
Offline
Addict
Addict
User avatar

Joined: Thu Oct 16, 2003 8:30 pm
Posts: 1998
Location: North Florida
Excellent.


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Fri Aug 30, 2013 8:53 pm 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5755
Location: Berlin - Germany
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.71 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 19.3 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Sep 01, 2013 9:10 am 
Offline
User
User

Joined: Wed Jul 11, 2012 3:54 pm
Posts: 16
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:
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.


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Sep 01, 2013 11:48 am 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5755
Location: Berlin - Germany
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.71 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 19.3 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Sep 01, 2013 5:14 pm 
Offline
User
User

Joined: Wed Jul 11, 2012 3:54 pm
Posts: 16
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:
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:
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


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Sep 01, 2013 5:35 pm 
Offline
User
User

Joined: Tue Oct 30, 2012 1:39 am
Posts: 81
Not sure what I'm doing wrong -- shouldn't both these sets of code result in the same thing:

Code:
#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:
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


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Sep 01, 2013 6:10 pm 
Offline
Always Here
Always Here
User avatar

Joined: Thu Jun 24, 2004 2:44 pm
Posts: 5755
Location: Berlin - Germany
@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.71 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 19.3 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Image


Top
 Profile  
Reply with quote  
 Post subject: Re: Registry Module (windows only)
PostPosted: Sun Sep 01, 2013 6:47 pm 
Offline
User
User

Joined: Tue Oct 30, 2012 1:39 am
Posts: 81
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:
    OpenKey()
    error = RegDeleteTree(hKey) ;<< IMA Error here.


I am on b14; I try b15 later


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 71 posts ]  Go to page 1, 2, 3, 4, 5  Next

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 16 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye