Registrywert Port unter variablen Druckernamen auslesen und ändern

Hier der Code für VB6:
Alles in den Code einer Form kopieren, starten und erledigt.


Option Explicit

Private Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, phkResult As Long) As Long

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 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 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 Any, ByVal cbData As Long) _
As Long

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

Private Declare Function RegCreateKey Lib "advapi32.dll" _
Alias "RegCreateKeyA" (ByVal hKey As Long, _
ByVal lpSubKey As String, phkResult As Long) 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 Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_DYN_DATA = &H80000006
Private Const REG_SZ = 1


Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const KEY_ALL_ACCESS = &HF003F
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_SET_VALUE = &H2
Private Const KEY_WRITE = &H20006


'Wert (String/Text) für einen bestimmten
'Schlüsselnamen speichern. Sollte der Schlüssel nicht
'existieren, wird dieser autom. erstellt.
'
'Parameterbeschreibung
'---------------------
'hKey (Hauptschlüssel) : z.B. HKEY_CURRENT_USER
'sPath (Schlüsselpfad) : z.B. MeineAnwendung
'sValue (Schlüsselname): z.B. Path
'iData (Schlüsselwert) : z.B. c:\programme\MeineAnwendung

Private Sub fStringSpeichern(hKey As Long, sPath As String, _
sValue As String, ByVal iData As String)

Dim vRet As Variant

RegCreateKey hKey, sPath, vRet
RegSetValueEx vRet, sValue, 0, REG_SZ, ByVal iData, _
Len(iData)
RegCloseKey vRet
End Sub


'Wert für einen bestimmten
'Schlüsselnamen auslesen.
'
'Parameterbeschreibung
'---------------------
'hKey (Hauptschlüssel) : z.B. HKEY_CURRENT_USER
'sPath (Schlüsselpfad) : z.B. MeineAnwendung
'sValue (Schlüsselname): z.B. Path
'Rückgabewert : z.B. c:\programme\MeineAnwendung

Private Function fWertLesen(hKey As Long, sPath As String, _
sValue As String) As String
Dim vRet As Variant

RegOpenKey hKey, sPath, vRet
fWertLesen = fRegAbfrageWert(vRet, sValue)
RegCloseKey vRet
End Function

'Wird von "fWertLesen" aufgerufen und gibt den Wert
'eines Schlüsselnamens zurück. Hierbei wird autom.
'ermittelt, ob es sich um einen String oder Binärwert
'handelt.
Function fRegAbfrageWert(ByVal hKey As Long, _
ByVal sValueName As String) As String
Dim SBuffer As String
Dim lRes As Long
Dim lTypeValue As Long
Dim lBufferSizeData As Long
Dim iData As Integer
On Error GoTo regError
lRes = RegQueryValueEx(hKey, sValueName, 0, _
lTypeValue, ByVal 0, lBufferSizeData)
If lRes = 0 Then
If lTypeValue = REG_SZ Then
SBuffer = String(lBufferSizeData, Chr$(0))
lRes = RegQueryValueEx(hKey, sValueName, 0, _
0, ByVal SBuffer, lBufferSizeData)
If lRes = 0 Then
fRegAbfrageWert = Left$(SBuffer, _
InStr(1, SBuffer, Chr$(0)) - 1)
End If
ElseIf lTypeValue = REG_BINARY Then
lRes = RegQueryValueEx(hKey, sValueName, 0, _
0, iData, lBufferSizeData)
If lRes = 0 Then
fRegAbfrageWert = iData
End If
End If
End If
Exit Function
regError:
fRegAbfrageWert = ""
End Function


'Löschen eines Schlüsselnamens
'
'Parameterbeschreibung
'---------------------
'hKey (Hauptschlüssel) : z.B. HKEY_CURRENT_USER
'sPath (Schlüsselpfad) : z.B. MeineAnwendung
'sValue (Schlüsselname): z.B. Path

Private Sub fWerteLoeschen(hKey As Long, sPath As String, _
sValue As String)

Dim vRet As Variant

RegCreateKey hKey, sPath, vRet
RegDeleteValue vRet, sValue
RegCloseKey vRet
End Sub
Private Function EnumRegKeys(ByVal Root As Long, ByVal KeyName As String, ByRef res As Boolean) As Collection
Dim Ret As Long
Dim hKey As Long
Dim Cnt As Long
Dim sName As String * 255
Dim sData As String
Dim SKeys As String
Dim sCurKey As String
Const ERROR_NO_MORE_ITEMS = 259&
Const BufferSize = 255
Dim Col As Collection
Set Col = New Collection
Ret = BufferSize

If RegOpenKey(Root, KeyName, hKey) = 0 Then
'Create buffer
sName = String(BufferSize, 0)
'Enumerate keys
While RegEnumKeyEx(hKey, Cnt, sName, Ret, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) <> ERROR_NO_MORE_ITEMS
sCurKey = Left$(sName, Ret)
Col.Add sCurKey

'Prepare for next
Cnt = Cnt + 1
sName = String(BufferSize, 0)
Ret = BufferSize
Wend
'Close key
RegCloseKey hKey
res = True
Set EnumRegKeys = Col
End If
End Function

Private Function EnumRegValues(ByVal Root As Long, ByVal KeyName As String, ByRef res As Boolean) As Collection
Dim Ret As Long
Dim hKey As Long
Dim Cnt As Long
Dim sName As String * 255
'Dim sNameLen As Long
Dim sType As Long
Dim tempData(255) As Byte
Dim tempDataLen As Long
Dim sData As String
Dim SKeys As String
Dim sCurKey As String
Dim Values As Collection
Set Values = New Collection
Const ERROR_NO_MORE_ITEMS = 259&
Const BufferSize = 255

Ret = BufferSize

If RegOpenKeyEx(Root, KeyName, 0&, KEY_READ, hKey) = 0 Then
'Create buffer
'sName = String(BufferSize, 0)
tempDataLen = 255
'Enumerate keys
Cnt = 0
Do While RegEnumValue(hKey, Cnt, sName, Len(sName), 0&, sType, tempData(0), tempDataLen) = 0
sCurKey = Left$(sName, InStr(1, sName, Chr$(0)) - 1)
If Len(sCurKey) > 0 Then
Values.Add sCurKey
SKeys = SKeys & sCurKey & ","
Debug.Print sCurKey & vbTab & Left$(StrConv(tempData, vbUnicode), tempDataLen)
End If
'Prepare for next
Cnt = Cnt + 1
'sName = String(BufferSize, 0)
Ret = BufferSize
tempDataLen = 255
Loop
'Close key
RegCloseKey hKey
res = True
'EnumRegValues = Left$(sKeys, Len(sKeys) - 1)
Set EnumRegValues = Values
End If
End Function

Private Function fDeleteKey(ByVal Root As Long, ByVal KeyName As String, ByVal Subkey, ByRef res As Boolean) As String
Dim Ret As Long
Dim hKey As Long
Const BufferSize = 255

Ret = BufferSize

If RegOpenKey(Root, KeyName, hKey) = 0 Then
RegDeleteKey hKey, Subkey
RegCloseKey hKey
End If
End Function
Private Function fDeleteValue(ByVal Root As Long, ByVal KeyName As String, ByVal Subkey, ByRef res As Boolean) As String
Dim Ret As Long
Dim hKey As Long
Const BufferSize = 255

Ret = BufferSize

If RegOpenKey(Root, KeyName, hKey) = 0 Then
RegDeleteValue hKey, Subkey
RegCloseKey hKey
End If
End Function

' Sucht nach KeyNames
Private Function Get_SubFolders(ByVal hKey As Long, _
ByVal StartFolder As String) As Variant

Dim SubStr As String
Dim RetHandle As Long
Dim KeyIndex As Long
Dim RetVar() As String
Dim retval As Long
ReDim RetVar(0)
retval = RegOpenKeyEx(hKey, StartFolder, 0&, _
KEY_ENUMERATE_SUB_KEYS, RetHandle)

' Wenn der Key nicht geöffnet werden kann
' Funktion verlassen
If retval <> 0 Then
Get_SubFolders = RetVar
Exit Function
End If

Do
SubStr = Space(255)
' KeyNames enumerieren, den x-ten (KeyIndex)
' KeyName auslesen
retval = RegEnumKey(RetHandle, KeyIndex, SubStr, _
Len(SubStr))
If retval <> 0 Then Exit Do

ReDim Preserve RetVar(0 To KeyIndex)

' Index für die nächste Suche erhöhen
KeyIndex = KeyIndex + 1
RetVar(UBound(RetVar)) = Left$(SubStr, _
InStr(1, SubStr, vbNullChar) - 1)
Loop
RegCloseKey RetHandle

Get_SubFolders = RetVar
End Function

'#################################################################
'# Paramter : Root z.B. HKEY_LOCAL_MACHINE #
'# EnumKey z.B. System\CurrentcontrolSet\Control\Print\Printers #
'# Subkey z.B. Port #
'# FindRegEntry z.B. 192.168.15.200 #
'# ReplaceRegEntry z.B. 192.168.16.200 #
'#################################################################
Private Sub ChangeKey(ByVal Root As Long, ByVal EnumKey As String, _
ByVal Subkey As String, ByVal FindRegEntry As String, ByVal ReplaceRegEntry As String)

Dim Subkeys() As String
Dim i As Long
Subkeys() = Get_SubFolders(Root, EnumKey)
For i = 0 To UBound(Subkeys())
Debug.Print Subkeys(i)
If FindRegEntry = fWertLesen(Root, EnumKey & "\" & Subkeys(i), Subkey) Then
fStringSpeichern Root, EnumKey & "\" & Subkeys(i), Subkey, ReplaceRegEntry
'Exit sub 'wenn nicht weiter gesucht werden soll
End If
Next
End Sub


Private Sub Form_Load()
ChangeKey HKEY_LOCAL_MACHINE, "system\currentcontrolset\control\print\printers", "port", "192.168.15.200", "192.168.16.200"

End Sub