laatzen/Pruef2000/source/modRegEntry.bas

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 <20>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