Hallo,
habe das Problem das ich Werte aus der Registry mit WinRegOpenKeyEx und WinRegQueryValueEx lesen kann, nicht jedoch DWORD Werte.
Frage 1: Muß ich Strings im mit Space vorbelegen um Werte zu bekommen.
Frage 2: Wie müssen die Variablen definiert sein. Vielleicht kann mir ja jemand ein kleines Beispielskript.
Danke,
Thomas
Function RegGetValue(ByVal lngHKEY, ByVal strKey, ByVal strValueName, strValue, ByVal blnDispMsg, lngDllError) As Boolean
'lngHKEY = HKEY_CURRENT_USER
'strKey = „Software\MYApps\MyAppName“
'strValueName = „DSN“
Dim lngMyErr
Dim strMyDescription
Dim strMySource
Dim blnError
Dim lngRet
Dim hndOpenKey
Dim lngVal
Dim strVal
Dim lngValType
Dim strMsg
Dim lngPosNull
On Error GoTo ErrorHandler
strValue = „“
’ Open the key for application’s path.
lngRet = RegOpenKeyEx(lngHKEY, strKey, ByVal 0&, modAPI.KEY_READ, hndOpenKey)
If Not (lngRet = ERROR_SUCCESS) Then
blnError = True
lngDllError = lngRet
If blnDispMsg Then
strMsg = „Error Opening Registry Key Entry:“ & vbCrLf
strMsg = strMsg & „Key/Path=“ & strKey & vbCrLf
strMsg = strMsg & „DLL Returned=“ & Format$(lngRet)
Call MsgBox(strMsg, vbOKOnly Or vbExclamation)
End If
GoTo ExitHandler
End If
'Type herausfinden bzw. ob Key überhaupt vorhanden
strVal = „“
lngVal = 0
lngRet = RegQueryValueEx(hndOpenKey, strValueName, ByVal 0&, lngValType, ByVal strVal, lngVal)
If lngRet = modAPI.ERROR_FILE_NOT_FOUND Then
'Key nicht gefunden
'Fehler-Meldung kommt weiter unten
Else
strVal = String$(lngVal, 0) 'auf die richtige Größe aufblasen
lngRet = RegQueryValueEx(hndOpenKey, strValueName, ByVal 0&, lngValType, ByVal strVal, lngVal)
End If
If Not (lngRet = ERROR_SUCCESS) Then
blnError = True
lngDllError = lngRet
If blnDispMsg Then
strMsg = „Error Retrieving Registry Key Entry:“ & vbCrLf
strMsg = strMsg & „Key=“ & strValueName & vbCrLf
strMsg = strMsg & „DLL Returned=“ & Format$(lngRet)
Call MsgBox(strMsg, vbOKOnly Or vbExclamation)
End If
GoTo ExitHandler
End If
’ ***********************************************
’ Select data type (for the needed types
’ used in the values) and assign value.
’ ***********************************************
Select Case lngValType
Case REG_NONE
strValue = vbNull
Case REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ
If lngVal > 0 Then
lngPosNull = InStr(strVal, Chr$(0))
If lngPosNull > 0 Then lngVal = lngPosNull
strValue = Left$(strVal, lngVal - 1)
End If
Case REG_BINARY, REG_RESOURCE_REQUIREMENTS_LIST
strValue = Me.ConvertToBinary(Left$(strVal, lngVal))
'strValue = Left$(strData, lngData)
Case REG_DWORD
strValue = Me.ConvertDwordToHex(Left$(strVal, lngVal))
Case Else
strValue = Me.ConvertToBinary(Left$(strVal, lngVal))
'strValue = vbNull
End Select
‚-------------------
ExitHandler:
On Error Resume Next
Call RegCloseKey(hndOpenKey)
On Error GoTo 0
If lngMyErr 0 Then
If blnDispMsg Then Call MsgBox(„Run-time error '“ & lngMyErr & "‘:" & vbLf & vbLf & strMyDescription & vbLf & Space(100), vbSystemModal, „Microsoft Visual Basic“)
Call Err.Raise(lngMyErr, strMySource, strMyDescription)
End If
RegGetValue = blnError
Exit Function
'--------------
ErrorHandler:
blnError = True
lngMyErr = Err.Number
strMyDescription = Err.Description
strMySource = Err.Source
Resume ExitHandler
End Function
Public Function ConvertDwordToHex(strValue) As String
Dim l
Dim strBuf
Dim strHex
For l = 1 To Len(strValue)
strHex = Hex(Asc(Mid$(strValue, l, 1)))
strHex = IIf(Len(strHex) = 2, strHex, „0“ & strHex)
strBuf = strHex & strBuf
Next l
ConvertDwordToHex = „0x“ & LCase$(Trim$(strBuf))
End Function
Public Function ConvertToBinary(strValue) As String
Dim l
Dim strBuf
Dim strHex
For l = 1 To Len(strValue)
strHex = Hex(Asc(Mid$(strValue, l, 1)))
strHex = IIf(Len(strHex) = 2, strHex, „0“ & strHex)
strBuf = strBuf & strHex & " "
Next l
ConvertToBinary = LCase$(Trim$(strBuf))
End Function