Option Explicit
 
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 Any, _
        phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegFlushKey Lib "advapi32.dll" (ByVal _
        hKey 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 Long, ByVal cbData As Long) _
        As Long
Private Declare Function RegSetValueEx_Str Lib "advapi32.dll" _
        Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal Reserved As Long, ByVal _
        dwType As Long, ByVal lpData As String, ByVal cbData As _
        Long) As Long
 
 
 
Private Const HKEY_CLASSES_ROOT = &H80000000
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 KEY_ALL_ACCESS = KEY_QUERY_VALUE Or _
                       KEY_SET_VALUE Or _
                       KEY_CREATE_SUB_KEY Or _
                       KEY_ENUMERATE_SUB_KEYS Or _
                       KEY_NOTIFY Or _
                       KEY_CREATE_LINK
Private Const ERROR_SUCCESS = 0&
Private Const REG_OPTION_NON_VOLATILE = &H0
Private Const REG_DWORD = 4
Private Const REG_SZ = 1
 
 
Private Sub btnOK_Click()
        Dim StrVar$, hKey&, Rv&
 
 
    Rv = RegKeyCreate(HKEY_CLASSES_ROOT, ".mbl")
    If Rv <> 0 Then
       StrVar = "fb_mblfile"
       Rv = RegValueSet(HKEY_CLASSES_ROOT, ".mbl", vbNullString, StrVar)
    End If
 
    Rv = RegKeyCreate(HKEY_CLASSES_ROOT, "fb_mblfile")
    If Rv <> 0 Then
       StrVar = "MusicCatalog MBL-File"
       Rv = RegValueSet(HKEY_CLASSES_ROOT, "fb_mblfile", vbNullString, StrVar)
    End If
 
    Rv = RegKeyCreate(HKEY_CLASSES_ROOT, "fb_mblfile\DefaultIcon")
    If Rv <> 0 Then
       If Right(App.Path, 1) = "\" Then
          StrVar = App.Path & "Musiccatalog.exe,1"
       Else
          StrVar = App.Path & "\Musiccatalog.exe,1"
       End If
       Rv = RegValueSet(HKEY_CLASSES_ROOT, "fb_mblfile\DefaultIcon", _
         vbNullString, StrVar)
    End If
 
    Rv = RegKeyCreate(HKEY_CLASSES_ROOT, "fb_mblfile\Shell\Open\Command")
    If Rv <> 0 Then
       If Right(App.Path, 1) = "\" Then
          StrVar = App.Path & "Musiccatalog.exe" & " /open%1"
       Else
          StrVar = App.Path & "\Musiccatalog.exe" & " /open%1"
       End If
       Rv = RegValueSet(HKEY_CLASSES_ROOT, "fb_mblfile\Shell\Open\Command", _
         vbNullString, StrVar)
       btnOK.Caption = "MBL-OK"
    End If
 
End Sub
 
 
Function RegKeyCreate(Root&, NewKey$) As Long
  Dim Result&, hKey&, Back&
    'Neuen Schlüssel erstellen
    Result = RegCreateKeyEx(Root, NewKey, 0, vbNullString, _
                            REG_OPTION_NON_VOLATILE, _
                            KEY_ALL_ACCESS, 0&, hKey, Back)
    If Result = ERROR_SUCCESS Then
      Result = RegFlushKey(hKey)
      If Result = ERROR_SUCCESS Then Call RegCloseKey(hKey)
        RegKeyCreate = Back
    End If
End Function
 
Function RegValueSet(Root&, Key$, Field$, Value As Variant) As Long
  Dim Result&, hKey&, s$, l&
    'Wert in ein Feld der Registry schreiben
    Result = RegOpenKeyEx(Root, Key, 0, KEY_ALL_ACCESS, hKey)
    If Result = ERROR_SUCCESS Then
      Select Case VarType(Value)
        Case vbInteger, vbLong
          l = CLng(Value)
          Result = RegSetValueEx(hKey, Field, 0, REG_DWORD, l, 4)
        Case vbString
          s = CStr(Value)
          Result = RegSetValueEx_Str(hKey, Field, 0, REG_SZ, s, _
                                        Len(s) + 1)
      End Select
      Result = RegCloseKey(hKey)
    End If
 
    RegValueSet = Result
 
End Function

Gruß
Fieber
http://computer.net-berlin.de - Visual Basic - Tips & Tricks sowie viel Grafik