364 lines
13 KiB
VB.net
364 lines
13 KiB
VB.net
Attribute VB_Name = "modRegEntry"
|
|
Option Explicit
|
|
|
|
Public Const REG_SZ As Long = 1
|
|
Public Const REG_DWORD As Long = 4
|
|
|
|
Public Const HKEY_CLASSES_ROOT As Long = &H80000000
|
|
Public Const HKEY_CURRENT_USER As Long = &H80000001
|
|
Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
|
|
Public Const HKEY_USERS As Long = &H80000003
|
|
Public Const lpRegKey As String = "SOFTWARE\lindner & partner\"
|
|
|
|
Const KEY_ALL_ACCESS As Long = &H3F
|
|
|
|
Const REG_OPTION_NON_VOLATILE = 0
|
|
|
|
Const STANDARD_RIGHTS_ALL As Long = &H1F0000
|
|
Const READ_CONTROL As Long = &H20000
|
|
Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
|
|
Const KEY_QUERY_VALUE As Long = &H1
|
|
Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
|
|
Const KEY_NOTIFY As Long = &H10
|
|
Const SYNCHRONIZE As Long = &H100000
|
|
Const KEY_READ As Long = _
|
|
((STANDARD_RIGHTS_READ _
|
|
Or KEY_QUERY_VALUE _
|
|
Or KEY_ENUMERATE_SUB_KEYS _
|
|
Or KEY_NOTIFY) _
|
|
And (Not SYNCHRONIZE))
|
|
|
|
Const ERROR_NONE = 0
|
|
Const ERROR_BADDB = 1
|
|
Const ERROR_BADKEY = 2
|
|
Const ERROR_CANTOPEN = 3
|
|
Const ERROR_CANTREAD = 4
|
|
Const ERROR_CANTWRITE = 5
|
|
Const ERROR_OUTOFMEMORY = 6
|
|
Const ERROR_INVALID_PARAMETER = 7
|
|
Const ERROR_ACCESS_DENIED = 8
|
|
Const ERROR_INVALID_PARAMETERS = 87
|
|
Const ERROR_NO_MORE_ITEMS = 259
|
|
|
|
|
|
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 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 Long, phkResult As Long, lpdwDisposition As Long) As Long
|
|
|
|
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
|
|
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
|
|
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
|
|
As String, lpcbData As Long) As Long
|
|
|
|
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
|
|
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
|
|
String, ByVal lpReserved As Long, lpType As Long, lpData As _
|
|
Long, lpcbData As Long) As Long
|
|
|
|
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
|
|
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
|
|
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
|
|
As Long, lpcbData As Long) As Long
|
|
|
|
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
|
|
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
|
|
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
|
|
String, ByVal cbData As Long) As Long
|
|
|
|
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
|
|
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
|
|
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
|
|
ByVal cbData As Long) As Long
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetRegSetting
|
|
' Purpose :
|
|
' Parameters : NA
|
|
' Return val : NA
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Function GetRegSetting(ByVal RegHKey As String, ByVal SubKey As String, _
|
|
Key As String, ByVal RegTyp As Long, Optional Default As Variant)
|
|
Dim sRetVal As String
|
|
Dim lRetVal As Long
|
|
Dim lrc As Long
|
|
Dim hKey As Long
|
|
Dim lValLen As Long
|
|
|
|
If IsMissing(Default) Then
|
|
If RegTyp = REG_SZ Then
|
|
GetRegSetting = ""
|
|
ElseIf RegTyp = REG_DWORD Then
|
|
GetRegSetting = 0
|
|
End If
|
|
Else
|
|
GetRegSetting = Default
|
|
End If
|
|
sRetVal = String(255, 0)
|
|
lValLen = Len(sRetVal)
|
|
|
|
lrc = RegOpenKeyEx(RegHKey, SubKey, 0&, KEY_READ, hKey)
|
|
If RegTyp = REG_SZ Then
|
|
lrc = RegQueryValueExString(hKey, Key, 0&, RegTyp, sRetVal, lValLen)
|
|
sRetVal = Left(sRetVal, lValLen - 1)
|
|
If lrc = 0 Then GetRegSetting = sRetVal
|
|
ElseIf RegTyp = REG_DWORD Then
|
|
lrc = RegQueryValueExLong(hKey, Key, 0&, RegTyp, lRetVal, lValLen)
|
|
If lrc = 0 Then GetRegSetting = lRetVal
|
|
End If
|
|
lrc = RegCloseKey(hKey)
|
|
End Function
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : SaveRegSetting
|
|
' Purpose :
|
|
' Parameters : NA
|
|
' Return val : NA
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Sub SaveRegSetting(ByVal RegHKey As String, ByVal SubKey As String, Key As String, _
|
|
ByVal Value As Variant, ByVal RegTyp As Long)
|
|
Dim hNewKey As Long 'handle to the new key
|
|
Dim lRetVal As Long 'result of the RegCreateKeyEx function
|
|
Dim sValue As String
|
|
Dim lValue As Long
|
|
|
|
lRetVal = RegCreateKeyEx(RegHKey, SubKey, 0&, _
|
|
vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
|
|
0&, hNewKey, lRetVal)
|
|
If RegTyp = REG_DWORD Then
|
|
lValue = CLng(Value)
|
|
lRetVal = RegSetValueExLong(hNewKey, Key, 0&, REG_DWORD, lValue, 4)
|
|
ElseIf RegTyp = REG_SZ Then
|
|
sValue = Value & Chr$(0)
|
|
lRetVal = RegSetValueExString(hNewKey, Key, 0&, REG_SZ, sValue, Len(sValue))
|
|
End If
|
|
RegCloseKey (hNewKey)
|
|
End Sub
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetLPRegSetting
|
|
' Purpose :
|
|
' Parameters : NA
|
|
' Return val : NA
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Function GetLPRegSetting(ByVal RegHKey As String, ByVal SubKey As String, _
|
|
Key As String, ByVal RegTyp As Long, Optional Default As Variant)
|
|
Dim sRetVal As String
|
|
Dim lRetVal As Long
|
|
Dim lrc As Long
|
|
Dim hKey As Long
|
|
Dim lValLen As Long
|
|
|
|
If IsMissing(Default) Then
|
|
If RegTyp = REG_SZ Then
|
|
GetLPRegSetting = ""
|
|
ElseIf RegTyp = REG_DWORD Then
|
|
GetLPRegSetting = 0
|
|
End If
|
|
Else
|
|
GetLPRegSetting = Default
|
|
End If
|
|
sRetVal = String(255, 0)
|
|
lValLen = Len(sRetVal)
|
|
|
|
lrc = RegOpenKeyEx(RegHKey, lpRegKey & SubKey, _
|
|
0&, KEY_READ, hKey)
|
|
If RegTyp = REG_SZ Then
|
|
lrc = RegQueryValueExString(hKey, Key, 0&, RegTyp, sRetVal, lValLen)
|
|
sRetVal = Left(sRetVal, lValLen - 1)
|
|
If lrc = 0 Then GetLPRegSetting = sRetVal
|
|
ElseIf RegTyp = REG_DWORD Then
|
|
lrc = RegQueryValueExLong(hKey, Key, 0&, RegTyp, lRetVal, lValLen)
|
|
If lrc = 0 Then GetLPRegSetting = lRetVal
|
|
End If
|
|
lrc = RegCloseKey(hKey)
|
|
End Function
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : SaveLPRegSetting
|
|
' Purpose :
|
|
' Parameters :
|
|
' Return val : NA
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Sub SaveLPRegSetting(ByVal RegHKey As String, ByVal SubKey As String, Key As String, _
|
|
ByVal Value As Variant, ByVal RegTyp As Long)
|
|
Dim hNewKey As Long 'handle to the new key
|
|
Dim lRetVal As Long 'result of the RegCreateKeyEx function
|
|
Dim sValue As String
|
|
Dim lValue As Long
|
|
|
|
lRetVal = RegCreateKeyEx(RegHKey, lpRegKey & SubKey, 0&, _
|
|
vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
|
|
0&, hNewKey, lRetVal)
|
|
If RegTyp = REG_DWORD Then
|
|
lValue = CLng(Value)
|
|
lRetVal = RegSetValueExLong(hNewKey, Key, 0&, REG_DWORD, lValue, 4)
|
|
Else
|
|
sValue = Value & Chr$(0)
|
|
lRetVal = RegSetValueExString(hNewKey, Key, 0&, REG_SZ, sValue, Len(sValue))
|
|
End If
|
|
RegCloseKey (hNewKey)
|
|
End Sub
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetWindowState
|
|
' Purpose :
|
|
' Parameters : NA
|
|
' Return val :
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Sub GetWindowState(ThisWindow As Form, Optional SizeWindow As Variant)
|
|
Dim i As Integer
|
|
Dim CharPos As Integer
|
|
Dim Height As Long
|
|
Dim LLeft As Long
|
|
Dim Top As Long
|
|
Dim Width As Long
|
|
Dim State As Integer
|
|
Dim Setting As String
|
|
|
|
|
|
'--- Einstellungen laden
|
|
Setting = GetLPRegSetting(HKEY_CURRENT_USER, "Pruefstation2000\Startup", "WindowState", REG_SZ, "2.2600.1800.9200.5800")
|
|
|
|
CharPos = -1
|
|
Do Until CharPos = 0
|
|
CharPos = InStr(Setting, ".")
|
|
If CharPos = 0 Then
|
|
Height = Val(Setting)
|
|
Exit Do
|
|
End If
|
|
Select Case i
|
|
Case 0: State = Left(Setting, CharPos - 1)
|
|
Case 1: LLeft = Left(Setting, CharPos - 1)
|
|
Case 2: Top = Left(Setting, CharPos - 1)
|
|
Case 3: Width = Left(Setting, CharPos - 1)
|
|
End Select
|
|
Setting = Mid(Setting, CharPos + 1)
|
|
i = i + 1
|
|
Loop
|
|
|
|
'perform the move -------------------------------
|
|
Select Case State
|
|
Case vbNormal
|
|
On Error Resume Next
|
|
ThisWindow.Move LLeft, Top, Width, Height
|
|
On Error GoTo 0
|
|
Case vbMinimized, vbMaximized
|
|
ThisWindow.WindowState = vbMaximized
|
|
End Select
|
|
End Sub
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : SetWindowState
|
|
' Purpose : Speichert die Fenstereinstellungen
|
|
' Parameters :
|
|
' Return val : NA
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Sub SetWindowState(ThisWindow As Form)
|
|
Dim Setting As String
|
|
|
|
Setting = ThisWindow.WindowState & "." & ThisWindow.Left & "." _
|
|
& ThisWindow.Top & "." & ThisWindow.Width & "." & ThisWindow.Height
|
|
SaveLPRegSetting HKEY_CURRENT_USER, "Pruefstation2000\Startup", "WindowState", Setting, REG_SZ
|
|
End Sub
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetFileType
|
|
' Purpose : Ermittelt die Dateibeschreibung aus der Registry
|
|
' Parameters : File Extension (ohne . )
|
|
' Return val :
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Function GetFileType(ByVal FileExtension As String) As String
|
|
Dim ExtensionKey As String
|
|
Dim FileType As String
|
|
|
|
GetFileType = "Datei"
|
|
On Error GoTo KeyError
|
|
ExtensionKey = GetRegSetting(HKEY_CLASSES_ROOT, "." & FileExtension, "", REG_SZ, "")
|
|
If ExtensionKey <> "" Then
|
|
FileType = GetRegSetting(HKEY_CLASSES_ROOT, ExtensionKey, "", REG_SZ, "")
|
|
If FileType <> "" Then
|
|
GetFileType = FileType
|
|
On Error GoTo 0
|
|
End If
|
|
End If
|
|
KeyError:
|
|
On Error GoTo 0
|
|
End Function
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetShellPlayCommand
|
|
' Purpose : Ermittelt das Shell Command zum Abspielen von Videos
|
|
' Parameters : Dateierweiterung
|
|
' Return val : Shell Command
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Function GetShellPlayCommand(ByVal FileExtension As String) As String
|
|
Dim ExtensionKey As String
|
|
Dim ShellCommand As String
|
|
|
|
GetShellPlayCommand = ""
|
|
On Error GoTo KeyError
|
|
ExtensionKey = GetRegSetting(HKEY_CLASSES_ROOT, "." & FileExtension, "", REG_SZ, "")
|
|
If ExtensionKey <> "" Then
|
|
ExtensionKey = ExtensionKey & "\shell\play\command"
|
|
ShellCommand = GetRegSetting(HKEY_CLASSES_ROOT, ExtensionKey, "", REG_SZ, "")
|
|
If ShellCommand <> "" Then
|
|
GetShellPlayCommand = ShellCommand
|
|
On Error GoTo 0
|
|
End If
|
|
End If
|
|
|
|
KeyError:
|
|
On Error GoTo 0
|
|
End Function
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetShellOpenCommand
|
|
' Purpose : Ermittelt das Shell Command zum öffnen von Dateien
|
|
' Parameters : Dateierweiterung
|
|
' Return val : Shell Command
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Function GetShellOpenCommand(ByVal FileExtension As String) As String
|
|
Dim ExtensionKey As String
|
|
Dim ShellCommand As String
|
|
|
|
GetShellOpenCommand = ""
|
|
On Error GoTo KeyError
|
|
ExtensionKey = GetRegSetting(HKEY_CLASSES_ROOT, "." & FileExtension, "", REG_SZ, "")
|
|
If ExtensionKey <> "" Then
|
|
ExtensionKey = ExtensionKey & "\shell\open\command"
|
|
ShellCommand = GetRegSetting(HKEY_CLASSES_ROOT, ExtensionKey, "", REG_SZ, "")
|
|
If ShellCommand <> "" Then
|
|
GetShellOpenCommand = ShellCommand
|
|
On Error GoTo 0
|
|
End If
|
|
End If
|
|
|
|
KeyError:
|
|
On Error GoTo 0
|
|
End Function
|
|
|
|
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
' Name : GetInstallPath
|
|
' Purpose :
|
|
' Parameters :
|
|
' Return val : NA
|
|
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
|
|
Public Function GetInstallPath() As String
|
|
Dim thePath As String
|
|
'--- Install Path laden
|
|
thePath = GetLPRegSetting(HKEY_LOCAL_MACHINE, "Puefstation2000", "AppPath", REG_SZ, "")
|
|
If thePath = "" Then
|
|
GetInstallPath = App.Path
|
|
Else
|
|
GetInstallPath = thePath
|
|
End If
|
|
End Function
|