Function RegDeleteKey Lib "advapi32" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Sub RegCreate(MainKey%, ByVal Key$)
b$ = ""
Do While InStr(Key$, "\")
C$ = zeichennext$(Key$, "\")
RegCreateKey MainKey%, b$, C$
If Len(b$) Then b$ = b$ + "\"
b$ = b$ + C$
Loop
RegCreateKey MainKey%, b$, Key$
End Sub
Sub RegSetValue(KeyIndex%, SubKey As String, Name As String, lTyp&, Wert As String, lByte&)
'KeyIndex=0: HKEY_CLASSES_ROOT
' 1: HKEY_CURRENT_USER
' 2: HKEY_LOCAL_MACHINE
' 3: HKEY_USERS
' 4: HKEY_PERFORMANCE_DATA (nur NT)
' 5: HKEY_CURRENT_CONFIG
' 6: HKEY_DYN_DATA
lhKey& = MainKey + KeyIndex
lResult& = RegOpenKeyEx(lhKey&, SubKey, 0, KEY_SET_VALUE, lhKeyOpen&)
If lResult& <> ERROR_SUCCESS Then Exit Sub
lResult& = RegSetValueEx(lhKeyOpen&, Name, 0, lTyp&, Wert, lByte&)
'If lResult& <> ERROR_SUCCESS Then (Fehler...)
RegCloseKey lhKeyOpen&
End Sub
Sub Reg_DeleteValue(KeyIndex%, Key$, sch$)
lhKey& = MainKey + KeyIndex%
lResult& = RegOpenKeyEx(lhKey&, Key, 0, KEY_SET_VALUE, lhKeyOpen&)
If lResult& <> ERROR_SUCCESS Then Exit Sub
lResult& = RegDeleteValue(lhKeyOpen&, sch$)
'If lResult& <> ERROR_SUCCESS Then (Fehler...)
RegCloseKey lhKeyOpen&
End Sub
Sub Reg_DeleteKey(KeyIndex%, Key$)
lhKey& = MainKey + KeyIndex%
lResult& = RegDeleteKey(lhKey&, Key$)
'If lResult& <> ERROR_SUCCESS Then (Fehler...)
End Sub
Function Reg_Exist_Key(KeyIndex%, SubKey As String) As Boolean
lhKey& = MainKey + KeyIndex
Reg_Exist_Key = False
l& = RegOpenKeyEx(lhKey&, SubKey, 0, KEY_ALL_ACCESS, lhKeyOpen&)
'Schlüssel existiert nicht
If l& <> ERROR_SUCCESS Then Exit Function
Reg_Exist_Key = True
End Function
Function Reg_Exist_Value(KeyIndex%, SubKey As String, Name As String) As Boolean
lhKey& = MainKey + KeyIndex
Reg_Exist_Value = False
l& = RegOpenKeyEx(lhKey&, SubKey, 0, KEY_ALL_ACCESS, lhKeyOpen&)
'Schlüssel existiert nicht
If l& <> ERROR_SUCCESS Then Exit Function
'Wert existiert nicht
l& = RegQueryValueExNULL(lhKeyOpen&, Name, 0&, lTyp&, 0&, cch&)
If l& <> ERROR_SUCCESS Then Exit Function
Reg_Exist_Value = True
End Function
Function Reg_GetValue_Typ(KeyIndex%, SubKey As String, Name As String) As String
lhKey& = MainKey + KeyIndex
Reg_GetValue_Typ = ""
l& = RegOpenKeyEx(lhKey&, SubKey, 0, KEY_ALL_ACCESS, lhKeyOpen&)
If l& <> ERROR_SUCCESS Then Exit Function
l& = RegQueryValueExNULL(lhKeyOpen&, Name, 0&, lTyp&, 0&, cch&)
If l& <> ERROR_SUCCESS Then Exit Function
Select Case lTyp&
Case REG_SZ
Reg_GetValue_Typ = "STRING"
Case REG_DWORD
Reg_GetValue_Typ = "DWORD"
Case REG_BINARY
Reg_GetValue_Typ = "BINARY"
Case Else
Reg_GetValue_Typ = "?"
End Select
End Function
Function Reg_GetValue(KeyIndex%, SubKey As String, Name As String) As String
lhKey& = MainKey + KeyIndex
Reg_GetValue = ""
l& = RegOpenKeyEx(lhKey&, SubKey, 0, KEY_ALL_ACCESS, lhKeyOpen&): If l& <> ERROR_SUCCESS Then Exit Function
l& = RegQueryValueExNULL(lhKeyOpen&, Name, 0&, lTyp&, 0&, cch&): If l& <> ERROR_SUCCESS Then Exit Function
Select Case lTyp&
Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ:
sValue$ = String(cch& + 1, 0)
l& = RegQueryValueExString(lhKeyOpen&, Name, 0&, lTyp&, sValue$, cch&): If l& <> ERROR_SUCCESS Then Exit Function
Reg_GetValue = zeichennext$(Left$(sValue$, cch&), Chr$(0))
Case REG_DWORD
l& = RegQueryValueExLong(lhKeyOpen&, Name, 0&, lTyp&, lValue&, cch&): If l& <> ERROR_SUCCESS Then Exit Function
Reg_GetValue = Trim$(Str$(lValue&))
Case REG_BINARY
sValue$ = String(cch& + 1, 0)
l& = RegQueryValueExString(lhKeyOpen&, Name, 0&, lTyp&, sValue$, cch&): If l& <> ERROR_SUCCESS Then Exit Function
Reg_GetValue = Left$(sValue$, cch&)
For iTempInt = 1 To Len(Reg_GetValue)
s = Asc(Mid$(Reg_GetValue, iTempInt, 1))
'Binärwerte bringen Probleme,
'sollte so aber funktionieren !
temp = ""
If s = 26 Then temp = "1A "
If s = 58 Then temp = "3A "
If s = 74 Then temp = "4A "
If s = 90 Then temp = "5A "
If s = 106 Then temp = "6A "
If s = 122 Then temp = "7A "
If s = 138 Then temp = "8A "
If s = 154 Then temp = "9A "
If temp = "" Then
sBinaryString = sBinaryString & Format(Hex(Asc(Mid$(Reg_GetValue, iTempInt, 1))), "00") & " "
Else
sBinaryString = sBinaryString & temp
End If
Next iTempInt
Reg_GetValue = sBinaryString
End Select
RegCloseKey lhKeyOpen&
End Function
Function zeichennext$(a$, ch$)
ai% = InStr(a$, ch$)
If ai% = 0 Then
zeichennext$ = a$: a$ = ""
Else
zeichennext$ = Left$(a$, ai% - 1): a$ = Mid$(a$, ai% + Len(ch$))
End If
End Function
Sub RegCreateKey(KeyIndex As Integer, SubKey As String, NewSubKey As String)
Dim Security As SECURITY_ATTRIBUTES
lhKey& = MainKey + KeyIndex
lResult& = RegOpenKeyEx(lhKey&, SubKey, 0, KEY_CREATE_SUB_KEY, lhKeyOpen&)
If lResult& <> ERROR_SUCCESS Then Exit Sub
lResult& = RegCreateKeyEx(lhKeyOpen&, NewSubKey, 0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, Security, lhKeyNew&, lDisposition&)
If lResult& = ERROR_SUCCESS Then
'If lDisposition& = REG_CREATED_NEW_KEY Then
' ...Schlüssel wurde angelegt
'Else
' ...Schlüssel existiert bereits
'End If
RegCloseKey lhKeyNew&
Else
'Fehler...
End If
RegCloseKey lhKeyOpen&
End Sub
Sub Reg_SetBinary(MainKey%, Key$, sch$, wrt$)
RegCreate MainKey%, Key$
RegSetValue MainKey%, Key$, sch$, REG_BINARY, wrt$, Len(wrt$)
End Sub
Sub Reg_SetDWord(MainKey%, Key$, sch$, wrt&)
RegCreate MainKey%, Key$
w$ = ""
For n% = 1 To Len(wrt&)
w$ = w$ + Chr$(wrt& Mod 256)
wrt& = Int(wrt& / 256)
Next
RegSetValue MainKey%, Key$, sch$, REG_DWORD, w$, Len(wrt&)
End Sub
Sub Reg_SetString(MainKey%, Key$, sch$, wrt$)
RegCreate MainKey%, Key$
RegSetValue MainKey%, Key$, sch$, REG_SZ, wrt$, Len(wrt$)
End Sub
*****************************************************************************************
Nun der relevante Code des Command-Buttons:
Private
Sub Ausführen_Click()
If Tun(1).Value = 1 Then
SubKey = "AAAAA"
Reg_SetDWord HKEY_CURRENT_MACHINE, SubKey, "NeuDWord", 0
Else
End If
Danke schon mal!!!
Torsten