Wie bekomme ich zur Laufzeit die Namen der Tabellen in einem MDB (Micorosft Access) heraus über TDataSource, TDataBase und/oder TQuery ?
Ich hab da ein kleines Dilemma. Ohne einen Table-Name anzugeben kann ich ned zum MDB connecten, aber ich weis ja diese Namen nicht. Es ist sehr wichtig, dass ich diese zur LKaufzeit herausbekommen kann. In VB geht’s also muss es ja wohl in Delphi sicher auch möglich sein. Also eine Art MDB-Viewer.
thx, Roger
Für den Hardcore-Programmierer:
SELECT Name FROM MSysObjects WHERE Type=1
Reinhard
hey, du bist doch gut in VB ? 
wie macht ihr das, wenn ihr beispielsweise einen API-Call macht um einen String in die Registry zu schreiben oder davon zu lesen ?
Nun ja, dafür gibt es ja eine ganze Reihe von API-Calls. Ich poste mal hier das Sammelsurium aus meinem Beispielprojekt - du musst dir halt das passende herauspicken. (Ein „String in der Registry“ kann ja alles mögliche sein…)
Option Explicit
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Registry Module for Visual Basic for Applications under Windows 95
' Declarations and Control Module
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Declare the specific key path for your
' application's settings in the registry.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Public Const AppReg = "Clipboard Formats"
Private Const REG\_APP\_KEYS\_PATH = "Software\Microsoft\Access\7.0\" & AppReg
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Specify constants to specific branches in the
' registry.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Global Const HKEY\_CLASSES\_ROOT = &H80000000
Global Const HKEY\_CURRENT\_USER = &H80000001
Global Const HKEY\_LOCAL\_MACHINE = &H80000002
Global Const HKEY\_USERS = &H80000003
Private Const ERROR\_SUCCESS = 0&
Private Const ERROR\_NO\_MORE\_ITEMS = 259&
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Specify constants to registry data types.
' These are declared Public for outside module
' usage in the GetAppRegValue() function.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Public Const REG\_NONE = 0
Public Const REG\_SZ = 1
Public Const REG\_EXPAND\_SZ = 2
Public Const REG\_BINARY = 3
Public Const REG\_DWORD = 4
Public Const REG\_DWORD\_LITTLE\_ENDIAN = 4
Public Const REG\_DWORD\_BIG\_ENDIAN = 5
Public Const REG\_LINK = 6
Public Const REG\_MULTI\_SZ = 7
Public Const REG\_RESOURCE\_LIST = 8
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Specify constants to registry action types.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Private Const REG\_OPTION\_NON\_VOLATILE = 0
Private Const KEY\_QUERY\_VALUE = &H1
Private Const KEY\_SET\_VALUE = &H2
Private Const KEY\_CREATE\_SUB\_KEY = &H4
Private Const KEY\_ENUMERATE\_SUB\_KEYS = &H8
Private Const KEY\_NOTIFY = &H10
Private Const KEY\_CREATE\_LINK = &H20
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD\_RIGHTS\_ALL = &H1F0000
Private Const KEY\_ALL\_ACCESS = ((STANDARD\_RIGHTS\_ALL Or KEY\_QUERY\_VALUE Or \_
KEY\_SET\_VALUE Or KEY\_CREATE\_SUB\_KEY Or KEY\_ENUMERATE\_SUB\_KEYS Or \_
KEY\_NOTIFY Or KEY\_CREATE\_LINK) And (Not SYNCHRONIZE))
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Security mask attributes for Windows NT (SAM).
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Type SECURITY\_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Declare Function RegCreateKey Lib "advapi32" Alias "RegCreateKeyA" \_
(ByVal hKey As Long, \_
ByVal lpszSubKey As String, \_
phkResult As Long) \_
As Long
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, \_
lpSecurityAttributes As Any, \_
phkResult As Long, lpdwDisposition As Long) \_
As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" \_
(ByVal hKey As Long, \_
ByVal lpSubKey As String) \_
As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" \_
(ByVal hKey As Long, \_
ByVal lpValueName As String) \_
As Long
Declare Function RegCloseKey Lib "advapi32.dll" \_
(ByVal hKey As Long) \_
As Long
Declare Function RegEnumValue Lib "advapi32" Alias "RegEnumValueA" \_
(ByVal hKey As Long, \_
ByVal iSubKey As Long, \_
ByVal lpszName As String, \_
cchName As Long, \_
dwReserved As Long, \_
lpdwType As Long, \_
lpbData As Any, \_
cbData As Long) \_
As Long
Declare Function RegEnumKeyEx Lib "advapi32" Alias "RegEnumKeyA" \_
(ByVal hKey As Long, \_
ByVal iSubKey As Long, \_
ByVal lpszName As String, \_
ByVal cchName As Long) \_
As Long
Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" \_
(ByVal hKey As Long, \_
ByVal lpszSubKey As String, \_
ByVal ulOptions As Long, \_
ByVal samDesired As Long, \_
phkResult As Long) \_
As Long
Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" \_
(ByVal hKey As Long, \_
ByVal lpszValueName As String, \_
ByVal dwReserved As Long, \_
lpdwType As Long, \_
lpbData As Any, \_
cbData As Long) \_
As Long
Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" \_
(ByVal hKey As Long, \_
ByVal lpszValueName As String, \_
ByVal dwReserved As Long, \_
ByVal fdwType As Long, \_
lpbData As Any, \_
ByVal cbData As Long) \_
As Long
Declare Function RegSetStringEx Lib "advapi32" Alias "RegSetValueExA" \_
(ByVal hKey As Long, \_
ByVal lpszValueName As String, \_
ByVal dwReserved As Long, \_
ByVal fdwType As Long, \_
lpbData As String, \_
ByVal cbData As Long) \_
As Long
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
'How to create a new item in the registry
'The following code will create a new item in the system registry:
Function CreateRegEntry(pDatatype As Long, \_
KeyToAdd As Variant, \_
ValueToAdd As Variant) As Boolean
On Local Error GoTo CreateRegEntry\_Err
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Declare local usage variables.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Dim lResult As Long, I As Integer, Msg As String
Dim strMyKeyFull As String, MyKeyName As String
Dim MyKeyValueLng As Long, MyKeyValueStr As String
Dim MyDataType As Long, phkResult As Long, IsNewKey As Long
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Set path to your application's settings.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegCreateKeyEx(HKEY\_LOCAL\_MACHINE, REG\_APP\_KEYS\_PATH, 0&, \_
REG\_SZ, REG\_OPTION\_NON\_VOLATILE, KEY\_ALL\_ACCESS, \_
ByVal 0&, phkResult, IsNewKey)
If Not (lResult = ERROR\_SUCCESS) Then
CreateRegEntry = False
Msg = "Error Creating Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & strMyKeyFull & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Test" 'App.Title
GoTo CreateRegEntry\_End
End If
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Determine data type and use appropriate
' passed value.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Select Case pDatatype
Case REG\_DWORD
MyKeyValueLng = ValueToAdd
lResult = RegSetValueEx(phkResult, KeyToAdd, \_
ByVal 0&, pDatatype, \_
MyKeyValueLng, Len(MyKeyValueLng))
Case REG\_SZ
MyKeyValueStr = ValueToAdd
lResult = RegSetValueEx(phkResult, KeyToAdd, \_
ByVal 0&, pDatatype, \_
ByVal MyKeyValueStr, Len(MyKeyValueStr))
End Select
If Not (lResult = ERROR\_SUCCESS) Then
CreateRegEntry = False
Msg = "Error Creating Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & KeyToAdd & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Test" 'App.Title
GoTo CreateRegEntry\_End
End If
CreateRegEntry = True
CreateRegEntry\_End:
Exit Function
CreateRegEntry\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "Test" 'App.Title
Resume CreateRegEntry\_End
End Function
'How to delete an existing item in the registry
'The following code will delete and existing item in the system registry:
Function DeleteAllAppRegEntries() As Boolean
On Local Error GoTo DeleteAllAppRegEntries\_Err
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Declare local usage variables.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Dim lResult As Long, Msg As String
Dim hKey As Long
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Open the application's path key.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegOpenKeyEx(HKEY\_LOCAL\_MACHINE, \_
REG\_APP\_KEYS\_PATH, \_
ByVal 0&, KEY\_ALL\_ACCESS, hKey)
If Not (lResult = ERROR\_SUCCESS) Then
DeleteAllAppRegEntries = False
Msg = "Error Opening Registry Key Entry:" & vbCrLf
Msg = Msg & "Key/Path=" & REG\_APP\_KEYS\_PATH & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "ODBC Registry"
GoTo DeleteAllAppRegEntries\_End
End If
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Delete the entire application's path key and any
' associated keys and values.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegDeleteKey(hKey, "")
If Not (lResult = ERROR\_SUCCESS) Then
DeleteAllAppRegEntries = False
Msg = "Error Deleting Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & REG\_APP\_KEYS\_PATH & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "ODBC Registry"
GoTo DeleteAllAppRegEntries\_End
End If
lResult = RegCloseKey(hKey)
DeleteAllAppRegEntries = True
DeleteAllAppRegEntries\_End:
Exit Function
DeleteAllAppRegEntries\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "YourAppName"
Resume DeleteAllAppRegEntries\_End
End Function
'How to return an existing item from the registry
'The following code will return a value from an existing item in the system registry:
Function GetAppRegValue(WhatKey As String, \_
KeyDataType As Variant, \_
KeyValue As Variant, \_
IsVerbose As Integer) As Boolean
On Local Error GoTo GetAppRegValue\_Err
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Declare local usage variables.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Dim lResult As Long, dwResult As Long
Dim dwType As Long, cbData As Long
Dim varStrData As String, varLngData As Long
Dim Msg As String
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Open the key for application's path.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegOpenKeyEx(HKEY\_LOCAL\_MACHINE, \_
REG\_APP\_KEYS\_PATH, \_
ByVal 0&, KEY\_ALL\_ACCESS, dwResult)
If Not (lResult = ERROR\_SUCCESS) Then
GetAppRegValue = False
If IsVerbose Then
Msg = "Error Opening Registry Key Entry:" & vbCrLf
Msg = Msg & "Key/Path=" & REG\_APP\_KEYS\_PATH & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "ODBC Registry"
End If
GoTo GetAppRegValue\_End
End If
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Set up passed variables and retrieve value.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Select Case KeyDataType
Case REG\_SZ
varStrData = String$(255, 0)
cbData = Len(varStrData)
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, \_
dwType, ByVal varStrData, cbData)
Case REG\_DWORD
varLngData = False
cbData = Len(varLngData)
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, \_
dwType, varLngData, cbData)
End Select
If Not (lResult = ERROR\_SUCCESS) Then
GetAppRegValue = False
If IsVerbose Then
Msg = "Error Retrieving Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & WhatKey & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "ODBC Registry"
End If
lResult = RegCloseKey(dwResult)
GoTo GetAppRegValue\_End
End If
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Close key.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegCloseKey(dwResult)
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Select data type (for the needed types
' used in the values) and assign value.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Select Case dwType
Case REG\_NONE
KeyValue = vbNull
Case REG\_SZ
KeyValue = left$(varStrData, cbData)
Case REG\_DWORD
KeyValue = varLngData
Case Else
KeyValue = vbNull
End Select
GetAppRegValue = True
Debug.Print KeyValue
GetAppRegValue\_End:
Exit Function
GetAppRegValue\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "YourAppName"
Resume GetAppRegValue\_End
End Function
'How to update an existing item in the registry
'The following code will return a value from an existing item in the system registry:
Function SetAppRegValue(WhatKey As String, \_
KeyDataType As Variant, \_
NewKeyValue As Variant) \_
As Boolean
On Local Error GoTo SetAppRegValue\_Err
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Declare local usage variables.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Dim lResult As Long, dwResult As Long
Dim dwType As Long, cbData As Long
Dim varStrData As String, varLngData As Long
Dim Msg As String
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Open the key for application's path.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegOpenKeyEx(HKEY\_LOCAL\_MACHINE, \_
REG\_APP\_KEYS\_PATH, \_
ByVal 0&, KEY\_ALL\_ACCESS, dwResult)
If Not (lResult = ERROR\_SUCCESS) Then
SetAppRegValue = False
Msg = "Error Opening Registry Key Entry:" & vbCrLf
Msg = Msg & "Key/Path=" & REG\_APP\_KEYS\_PATH & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "ODBC Registry"
GoTo SetAppRegValue\_End
End If
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Set up passed variables and retrieve value.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
Select Case KeyDataType
Case REG\_SZ
varStrData = NewKeyValue
lResult = RegSetValueEx(dwResult, WhatKey, \_
ByVal 0&, KeyDataType, \_
ByVal varStrData, Len(varStrData))
Case REG\_DWORD
varLngData = CLng(NewKeyValue)
lResult = RegSetValueEx(dwResult, WhatKey, \_
ByVal 0&, KeyDataType, \_
varLngData, Len(varLngData))
End Select
If Not (lResult = ERROR\_SUCCESS) Then
SetAppRegValue = False
Msg = "Error Setting Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & WhatKey & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "ODBC Registry"
lResult = RegCloseKey(dwResult)
GoTo SetAppRegValue\_End
End If
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
' Close key.
' \*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*\*
lResult = RegCloseKey(dwResult)
SetAppRegValue = True
SetAppRegValue\_End:
Exit Function
SetAppRegValue\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "YourAppName"
Resume SetAppRegValue\_End
End Function
Public Function GetAllValues(hKey As Long, lpszSubKey As String, IsVerbose As Boolean)
On Local Error GoTo GetAllValues\_Err
Dim lResult As Long, dwResult As Long, dwType As Long
Dim Msg, Res, Ix As Long, cbData As Long, varStrData As String, cbResLen As Long, varStrRes As String
Res = Null
lResult = RegOpenKeyEx(hKey, lpszSubKey, ByVal 0&, KEY\_ALL\_ACCESS, dwResult)
If lResult ERROR\_SUCCESS Then
If IsVerbose Then
Msg = "Error Opening Registry Key Entry:" & vbCrLf
Msg = Msg & "Key/Path=" & lpszSubKey & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Registry"
End If
GoTo GetAllValues\_End
End If
Res = ""
Ix = 0
Do
varStrData = String$(255, 0)
cbData = Len(varStrData)
lResult = RegEnumValue(dwResult, Ix, varStrData, cbData, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&:wink:
If lResult ERROR\_SUCCESS Then Exit Do
Res = Res & "," & Mid(varStrData, 1, InStr(varStrData, Chr(0)) - 1)
Ix = Ix + 1
Loop
lResult = RegCloseKey(dwResult)
GetAllValues\_End:
On Error Resume Next
If Res "" Then GetAllValues = Mid(Res, 2, 32000)
Exit Function
GetAllValues\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "GetReg"
Resume GetAllValues\_End
End Function
Public Function GetAllSubKeys(hKey As Long, lpszSubKey As String, IsVerbose As Boolean)
On Local Error GoTo GetAllSubKeys\_Err
Dim lResult As Long, dwResult As Long
Dim Msg, Res, Ix As Integer, cbData As Long, varStrData As String
Res = Null
lResult = RegOpenKeyEx(hKey, lpszSubKey, ByVal 0&, KEY\_ALL\_ACCESS, dwResult)
If lResult ERROR\_SUCCESS Then
If IsVerbose Then
Msg = "Error Opening Registry Key Entry:" & vbCrLf
Msg = Msg & "Key/Path=" & lpszSubKey & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Registry"
End If
GoTo GetAllSubKeys\_End
End If
Res = ""
Ix = 0
Do
varStrData = String$(255, 0)
cbData = Len(varStrData)
lResult = RegEnumKeyEx(dwResult, Ix, varStrData, cbData)
If lResult ERROR\_SUCCESS Then Exit Do
Res = Res & "," & Mid(varStrData, 1, InStr(varStrData, Chr(0)) - 1)
Ix = Ix + 1
Loop
lResult = RegCloseKey(dwResult)
GetAllSubKeys\_End:
On Error Resume Next
If Res "" Then GetAllSubKeys = Mid(Res, 2, 32000)
Exit Function
GetAllSubKeys\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "GetReg"
Resume GetAllSubKeys\_End
End Function
Public Function GetRegValue(hKey As Long, KeyPath As String, WhatKey As String, IsVerbose As Integer)
On Local Error GoTo GetRegValue\_Err
' Declare local usage variables.
Dim lResult As Long, dwResult As Long, dwType As Long, cbData As Long, I As Integer
Dim varStrData As String, varLngData As Long, Msg, KeyValue
KeyValue = Null
' Open the key's path.
lResult = RegOpenKeyEx(hKey, KeyPath, ByVal 0&, ByVal 0&, dwResult)
If lResult ERROR\_SUCCESS Then
If IsVerbose Then
Msg = "Error Opening Registry Key Entry:" & vbCrLf
Msg = Msg & "Key/Path=" & KeyPath & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Registry"
End If
GoTo GetRegValue\_End
End If
' Find out the key type.
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, dwType, ByVal 0&, ByVal 0&:wink:
If lResult ERROR\_SUCCESS Then
If IsVerbose Then
Msg = "Error Retrieving Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & WhatKey & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Registry"
End If
lResult = RegCloseKey(dwResult)
GoTo GetRegValue\_End
End If
' Set up passed variables and retrieve value.
Select Case dwType
Case REG\_SZ
varStrData = String$(255, 0)
cbData = Len(varStrData)
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, \_
dwType, ByVal varStrData, cbData)
Case REG\_DWORD
varLngData = False
cbData = Len(varLngData)
lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, \_
dwType, varLngData, cbData)
End Select
If lResult ERROR\_SUCCESS Then
If IsVerbose Then
Msg = "Error Retrieving Registry Key Entry:" & vbCrLf
Msg = Msg & "Key=" & WhatKey & vbCrLf
Msg = Msg & "DLL Returned=" & Format$(lResult)
MsgBox Msg, vbOKOnly Or vbExclamation, "Registry"
End If
lResult = RegCloseKey(dwResult)
GoTo GetRegValue\_End
End If
' Close key.
lResult = RegCloseKey(dwResult)
' Select data type (for the needed types used in the values) and assign value.
Select Case dwType
Case REG\_SZ
KeyValue = Mid$(varStrData, 1, cbData)
If InStr(KeyValue, Chr(0)) \> 0 Then \_
KeyValue = Mid$(KeyValue, 1, InStr(KeyValue, Chr(0)) - 1)
Case REG\_DWORD
KeyValue = varLngData
End Select
'Debug.Print KeyValue
GetRegValue\_End:
On Error Resume Next
GetRegValue = KeyValue
Exit Function
GetRegValue\_Err:
MsgBox error.Description, vbOKOnly Or vbExclamation, "GetRegValue"
Resume GetRegValue\_End
End Function
Public Function GetExt(Ext As String)
Dim Res, s As String, KeyValue
Res = GetRegValue(HKEY\_CLASSES\_ROOT, Ext, "", False)
If IsNull(Res) Then
GetExt = ""
ElseIf Res = "" Then
GetExt = GetAllSubKeys(HKEY\_CLASSES\_ROOT, Ext & "\Shell", False)
Else
GetExt = GetAllSubKeys(HKEY\_CLASSES\_ROOT, Res & "\Shell", False)
End If
End Function
Public Function TesteMich()
Dim Res, KeyValue
Res = GetAppRegValue("Microsoft Excel (\*.xls)", REG\_SZ, KeyValue, True)
TesteMich = KeyValue
End Function
Public Function Testemich1()
Testemich1 = GetAllSubKeys(HKEY\_CLASSES\_ROOT, "CLSID\{00020810-0000-0000-C000-000000000046}", True)
End Function
Public Function Testemich2()
Testemich2 = GetRegValue(HKEY\_CLASSES\_ROOT, "CLSID\{00020810-0000-0000-C000-000000000046}\LocalServer", "", True)
End Function
Danke, das hilft schon mal sehr !
Zum Glück hab ich noch die original Win32-API-Beschreibung von Microsoft zum konventieren
Die Sache mit den Strings ist jetzt klar