Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0548: REG_MULTI_SZ Werte in Registry schreiben und lesen

 von 

Beschreibung 

Dieser Tipp zeigt, wie man mehrzeiligen Text in die Registry schreibt und diese Werte wierder ausliest.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

RegCloseKey, RegCreateKeyExA (RegCreateKeyEx), RegDeleteKeyA (RegDeleteKey), RegDeleteValueA (RegDeleteValue), RegFlushKey, RegOpenKeyExA (RegOpenKeyEx), RegQueryValueExA (RegQueryValueEx), RegSetValueExA (RegSetValueEx), RegSetValueExA (RegSetValueEx_Str)

Download:

Download des Beispielprojektes [4,29 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "Text2"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1" (Index von 0 bis 1)

Option Explicit

Private Sub Form_Load()
    Dim Result As Long
    
    Label2.Caption = "Dieses Beispiel verwendet den Schlüssel ""HKEY_CURRENT_USER\Software\VB"""
    Command1.Caption = "Auslesen"
    Command2.Caption = "Schreiben"
    
    Result = Registry.RegKeyExist(HKEY_CURRENT_USER, "Software\" & _
      "VB and VBA Program Settings\ActiveVB")
        
    'wenn der Key nicht existiert
    If Result = 2 Then 'neuen REG_MULTI_SZ-Key erstellen mit dem Wert 1 2 3
        Registry.RegValueSet HKEY_CURRENT_USER, "Software\VB and VBA " & _
          "Program Settings", "ActiveVB", "1" & vbCrLf & "2" & vbCrLf & _
          "3", True, True
    End If
End Sub

Private Sub Command1_Click()
    Dim Result As Long, Text As String
    
    Result = Registry.RegValueGet(HKEY_CURRENT_USER, "Software\" & _
      "VB and VBA Program Settings", "ActiveVB", Text)
    
    Text1.Text = Text
    
    Debug.Print Result
End Sub

Private Sub Command2_Click()
    Dim Result As Long, Text As String
    
    If Text2 = "" Then
        MsgBox "Bitte einen Wert eingeben", vbCritical
        Exit Sub
    End If
    
    Text = Text2.Text
    
    Registry.RegValueSet HKEY_CURRENT_USER, "Software" & _
      "\VB and VBA Program Settings", "ActiveVB", Text
End Sub


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------- Anfang Modul "Registry" alias Registry.bas --------


 
Option Explicit

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
        Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal _
        lpSubKey As String, ByVal ulOptions As Long, ByVal _
        samDesired As Long, phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _
        (ByVal hKey As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal lpReserved As Long, _
        lpType As Long, lpData As Any, lpcbData As Any) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
        Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal _
        lpSubKey As String, ByVal Reserved As Long, ByVal _
        lpClass As String, ByVal dwOptions As Long, ByVal _
        samDesired As Long, ByVal lpSecurityAttributes As Any, _
        phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal _
        hKey As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal Reserved As Long, ByVal _
        dwType As Long, lpData As Long, ByVal cbData As Long) _
        As Long

Private Declare Function RegSetValueEx_Str Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal Reserved As Long, ByVal _
        dwType As Long, ByVal lpData As String, ByVal cbData As _
        Long) 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

Public Enum HKEY_ROOTS
    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

Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
 
Const KEY_READ = KEY_QUERY_VALUE Or _
                 KEY_ENUMERATE_SUB_KEYS _
                 Or KEY_NOTIFY
                  
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE Or _
                       KEY_SET_VALUE Or _
                       KEY_CREATE_SUB_KEY Or _
                       KEY_ENUMERATE_SUB_KEYS Or _
                       KEY_NOTIFY Or _
                       KEY_CREATE_LINK
Const ERROR_SUCCESS = 0&

Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_LITTLE_ENDIAN = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6
Const REG_MULTI_SZ = 7

Const REG_OPTION_NON_VOLATILE = &H0

Private RegRoot As Long

Public Function RegKeyExist(Root As HKEY_ROOTS, Key$) As Long
     Dim Result As Long, hKey As Long
   
     'Prüfen ob ein Schlüssel existiert
     Result = RegOpenKeyEx(Root, Key, 0, KEY_READ, hKey)
     If Result = ERROR_SUCCESS Then Call RegCloseKey(hKey)
     RegKeyExist = Result
End Function

Public Function RegKeyCreate(Root As HKEY_ROOTS, Newkey$) As Long
    Dim Result As Long, hKey As Long, Back As Long
    
    'Neuen Schlüssel erstellen
    Result = RegCreateKeyEx(Root, Newkey, 0, vbNullString, _
                             REG_OPTION_NON_VOLATILE, _
                             KEY_ALL_ACCESS, 0&, hKey, Back)
    
    If Result = ERROR_SUCCESS Then
        Result = RegFlushKey(hKey)
        If Result = ERROR_SUCCESS Then Call RegCloseKey(hKey)
        RegKeyCreate = Back
    End If
End Function

Public Function RegKeyDelete(Root As HKEY_ROOTS, Key$) As Long
   'Schlüssel erstellen
   RegKeyDelete = RegDeleteKey(Root, Key)
End Function

Public Function RegFieldDelete(Root As HKEY_ROOTS, Key$, Field$) As Long
    Dim Result As Long, hKey As Long
    
    'Feld löschen
    Result = RegOpenKeyEx(Root, Key, 0, KEY_ALL_ACCESS, hKey)
    If Result = ERROR_SUCCESS Then
        Result = RegDeleteValue(hKey, Field)
        Result = RegCloseKey(hKey)
    End If
    RegFieldDelete = Result
End Function

Public Function RegValueSet(Root As HKEY_ROOTS, Key$, Field$, Value As Variant, _
                            Optional ReplaceVBCrLf As Boolean = True, _
                            Optional Create As Boolean = True) As Long

    Dim Result As Long, hKey As Long, s As String
    Dim l As Long, FoundNullChars As Boolean

    'Wenn der Key nicht existiert, dann erstellen
    If Not RegKeyExist(Root, Key) And Create = True Then
        RegKeyCreate Root, Key
    End If

    If InStr(1, Value, vbCrLf) And ReplaceVBCrLf Then
        Value = Replace(Value, vbCrLf, vbNullChar)
        FoundNullChars = True
    End If

    'Wert in ein Feld der Registry schreiben
    Result = RegOpenKeyEx(Root, Key, 0, KEY_ALL_ACCESS, hKey)
    If Result = ERROR_SUCCESS Then
        Select Case VarType(Value)
        Case vbInteger, vbLong
            l = CLng(Value)
            Result = RegSetValueEx(hKey, Field, 0, REG_DWORD, l, 4)
        Case vbString
            If FoundNullChars Then
                s = CStr(Value)
                Result = RegSetValueEx_Str(hKey, Field, 0, REG_MULTI_SZ, s, _
                                         Len(s))
            Else
                s = CStr(Value)
                Result = RegSetValueEx_Str(hKey, Field, 0, REG_SZ, s, _
                                         Len(s))
            End If
       End Select
       
       Result = RegCloseKey(hKey)
     End If

     RegValueSet = Result
 End Function

 Public Function RegValueGet(Root As HKEY_ROOTS, Key$, Field$, Value As Variant) As Long
    Dim Result As Long, hKey As Long, dwType As Long
    Dim Lng As Long, Buffer As String, l As Long
   
    'Wert aus einem Feld der Registry auslesen
    Result = RegOpenKeyEx(Root, Key, 0, KEY_READ, hKey)
    If Result = ERROR_SUCCESS Then
        Result = RegQueryValueEx(hKey, Field, 0&, dwType, ByVal 0&, l)
        If Result = ERROR_SUCCESS Then
            Select Case dwType
                Case REG_SZ
                    Buffer = Space$(l)
                    Result = RegQueryValueEx(hKey, Field, 0&, _
                             dwType, ByVal Buffer, l)
                    
                    If Result = ERROR_SUCCESS Then Value = Buffer
                    
                Case REG_DWORD
                    Result = RegQueryValueEx(hKey, Field, 0&, dwType, Lng, l)
                    If Result = ERROR_SUCCESS Then Value = Lng
                
                Case REG_MULTI_SZ
                    Buffer = Space$(l)
                    Result = RegQueryValueEx(hKey, Field, 0&, _
                             dwType, ByVal Buffer, l)
                    
                    Buffer = Replace(Buffer, vbNullChar, vbCrLf)
             
                    If Result = ERROR_SUCCESS Then Value = Buffer
            End Select
        End If
    End If

    If Result = ERROR_SUCCESS Then Result = RegCloseKey(hKey)
    RegValueGet = Result
End Function



'--------- Ende Modul "Registry" alias Registry.bas ---------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Patrick am 17.12.2003 um 09:49

Sollte bei REG_MULTI_SZ Werten nicht folgendes stehen?

Buffer = Space$(l) '+ 1 in Klammer weglassen

und

Result = RegSetValueEx_Str(hKey, Field, 0, REG_MULTI_SZ, s, Len(s)) 'ebenso das + 1 weglassen

Beim lesen und späteren zurückspeichern sind dann 2 Zeichen zuviel, oder???

Kommentar von Peter Sühlo am 09.12.2003 um 16:05

Ich habe den Sourcecode für ein spezielles Problem unter VBA für MS Access 97 unter NT 4.0 reduziert und es hat funktioniert. Danke.
PS: Wenn man nicht Administrator ist, sollte man beim Schreiben in die Registry statt KEY_ALL_ACCESS lieber den speziellen Wert KEY_SET_VALUE (in der Funktion RegOpenKeyEx) verwenden, sonst kann es ein Problem geben.

Kommentar von Jan Lohage am 17.05.2003 um 16:46

aber mit der methode kann man keine werte an beliebigen stellen der registry ändern/erstellen

Jan

Kommentar von garth am 13.12.2002 um 00:18

siet komplieziert aus der code zur registry ich habe und nutze da einen einfacheren

Public UTextname

Public Sub ReadRegistry()
UTextname = GetSetting("Programname", "Personal Information", "Textname", "")

End Sub

Public Sub SaveRegistry()
Call SaveSetting("Programname", "Personal Information", "Textname", UTextname)
End Sub