fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Eigenes URL Protokoll registrieren

Uploader:	csde_rats
Datum/Zeit:	23.03.2009 16:19:43
#include "windows.bi"



Function UpdateKey(KeyRoot As HKEY, _

  KeyName As String, _

  SubKeyName As String, _

  SubKeyValue As String) As BOOL



  Dim rc As Long ' Rückgabe-Code

  Dim hKey As HKEY ' Zugriffsnummer für Registrierungsschlüssel

  Dim lpAttr As SECURITY_ATTRIBUTES ' Sicherheitstyp der Registrierung



  lpAttr.nLength = 50 ' Sicherheitsattribute auf Standardeinstellungen setzen...

  lpAttr.lpSecurityDescriptor = 0

  lpAttr.bInheritHandle = True



  ' ------------------------------------------------------------

  ' - Registrierungsschlüssel erstellen/öffnen...

  ' ------------------------------------------------------------

  rc = RegCreateKeyEx(KeyRoot, StrPtr(KeyName), 0, 0, _

    REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, @lpAttr, _

    @hKey, NULL) ' //KeyRoot//KeyName erstellen/öffnen

  If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Fehler behandeln...



  ' ------------------------------------------------------------

  ' - Schlüsselwert erstellen/bearbeiten...

  ' ------------------------------------------------------------

  If (SubKeyValue = "") Then

    ' Für RegSetValueEx() wird zur korrekten Ausführung

    ' ein Leerzeichen benötigt...

    SubKeyValue = " "

  End If



  ' Schlüsselwert erstellen/bearbeiten

  rc = RegSetValueEx(hKey, SubKeyName, 0, REG_SZ, _

    StrPtr(SubKeyValue), Len(SubKeyValue))

  If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Fehler behandeln



  ' ------------------------------------------------------------

  ' - Registrierungsschlüssel schließen...

  ' ------------------------------------------------------------

  rc = RegCloseKey(hKey) ' Schlüssel schließen



  ' Erfolgreiche Ausführung zurückgeben

  UpdateKey = True

  Exit Function



CreateKeyError:

  ' Fehlerrückgabe-Code festlegen

  UpdateKey = False



  ' Versuchen, den Schlüssel zu schließen

  rc = RegCloseKey(hKey)

End Function



Function GetKeyValue(KeyRoot As HKEY, KeyName As String, Value As String) As String

  Dim rc As Long ' Rückgabe-Code

  Dim hKey As HKEY ' Zugriffsnummer für Registrierungsschlüssel

  Dim lpAttr As SECURITY_ATTRIBUTES ' Sicherheitstyp der Registrierung

  Dim szd As ZString * MAX_PATH

  Dim cd As Integer



  lpAttr.nLength = 50 ' Sicherheitsattribute auf Standardeinstellungen setzen...

  lpAttr.lpSecurityDescriptor = 0

  lpAttr.bInheritHandle = True



  ' ------------------------------------------------------------

  ' - Registrierungsschlüssel erstellen/öffnen...

  ' ------------------------------------------------------------

  rc = RegCreateKeyEx(KeyRoot, StrPtr(KeyName), 0, 0, _

    REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, @lpAttr, _

    @hKey, 0) ' //KeyRoot//KeyName erstellen/öffnen

  If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Fehler behandeln...



  ' ------------------------------------------------------------

  ' - Schlüsselwert erstellen/bearbeiten...

  ' ------------------------------------------------------------

  rc = RegQueryValueEx(hKey, StrPtr(Value), 0, 0, @szd, @cd)

  If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Fehler behandeln



  ' ------------------------------------------------------------

  ' - Registrierungsschlüssel schließen...

  ' ------------------------------------------------------------

  rc = RegCloseKey(hKey) ' Schlüssel schließen



  ' Erfolgreiche Ausführung zurückgeben

  Return szd



CreateKeyError:

  ' Versuchen, den Schlüssel zu schließen

  rc = RegCloseKey(hKey)

  Return ""

End Function



' Fehler im Klartext

Function ErrorMsg(lErrorCode As Long) As String

  Select Case lErrorCode

    Case 1009, 1015

      ErrorMsg = "The Registry Database is corrupt!"

    Case 2, 1010

      ErrorMsg = "Bad Key Name"

    Case 1011

      ErrorMsg = "Can't Open Key"

    Case 4, 1012

      ErrorMsg = "Can't Read Key"

    Case 5

      ErrorMsg = "Access to this key is denied"

    Case 1013

      ErrorMsg = "Can't Write Key"

    Case 8, 14

      ErrorMsg = "Out of memory"

    Case 87

      ErrorMsg = "Invalid Parameter"

    Case 234

      ErrorMsg = "There is more data than the buffer has been allocated to hold."

    Case Else

      ErrorMsg = "Undefined Error Code: " & Str$(lErrorCode)

  End Select

End Function



Function RegisterProtocol (ProtocolName As String, ProgPath As String = Command(0)) As BOOL

    Dim As HKEY hKey

    Dim As DWORD hDepth

    Dim As SECURITY_ATTRIBUTES lpAttr



    With lpAttr

        .nLength = SizeOf(SECURITY_ATTRIBUTES)

        .lpSecurityDescriptor = NULL

        .bInheritHandle = TRUE

    End With



    If RegCreateKeyEx(Cast(HKEY, &h80000000), StrPtr(ProtocolName), 0, 0, 0, 131135, @lpAttr, @hKey, @hDepth) <> ERROR_SUCCESS Then

        RegCloseKey(hKey)

        Return FALSE

    EndIf



    RegOpenKey(Cast(HKEY, &h80000000), StrPtr(ProtocolName), @hKey)



  ' Sopurce-Filter updaten

  UpdateKey Cast(HKEY, &H80000000), ProtocolName, "Source Filter", _

    GetKeyValue(Cast(HKEY, &H80000000), "http", "Source Filter")



  ' Standard-Icon

  UpdateKey Cast(HKEY, &H80000000), ProtocolName & "\DefaultIcon", _

    vbNullString, ProgPath & ",0"



  ' Shell-Open-Key erstellen

  RegCreateKeyEx Cast(HKEY, &H80000000), ProtocolName & "\shell", _

    0, 0, 0, 131135, @lpAttr, @hKey, 0

  RegCloseKey hKey

  RegCreateKeyEx Cast(HKEY, &H80000000), ProtocolName & "\shell\open", _

    0, 0, 0, 131135, @lpAttr, @hKey, 0

  RegCloseKey hKey



  ' Eigenes Programm eintragen

  UpdateKey Cast(HKEY, &H80000000), ProtocolName & "\shell\open\command", _

    vbNullString, ProgPath & " ""%1"""



  ' URL-Protokoll updaten

  UpdateKey Cast(HKEY, &H80000000), ProtocolName, "Url Protocol", ""



  Return TRUE

End Function