Startseite / Tipps / VB 5/6-Tipp 0563: Eigenes Protokoll definieren

VB 5/6-Tipp 0563: Eigenes Protokoll definieren

 von KaZaK

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'--------------- Anfang Projektdatei pcat.vbp ---------------
' Die Komponente ' (MSWINSCK.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Windows Socket "Winsock1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label5"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
'
' Autor: KaZaK <kazak@gmx.net> unter Mithilfe von Kill][Switch und Sebastian

'P(rotocol) CAT(cher)
'Dieser Tip soll zeigen, wie man Links aus dem Webbrowser
'abfängt, die mit einem bestimmten Protokoll anfangen.
'(So wie es z.B. eDonkey oder eMule machen)
'In diesem Beispiel wurde "pcat" genommen.

'ACHTUNG: Damit das Programm funktionsfähig ist,
'muss es vorher kompiliert werden, und die Registry-
'einträge müssen erstellt werden.
'Fragen oder Anregungen bitte an kazak@gmx.net

Option Explicit

Private Sub Command1_Click()
'Sub, um die zugehörigen Registry-Einträge zu erstellen
Dim pfad As String
Dim regpfad As String
Dim system As String
Dim result

pfad = App.Path
pfad = Replace(pfad, "\\", "\")
pfad = pfad & "\" & App.EXEName & ".exe"

Const HKEY_CLASSES_ROOT = &H80000000

result = RegKeyCreate(HKEY_CLASSES_ROOT, "pcat\")
result = RegValueSet(HKEY_CLASSES_ROOT, "pcat\", "", "URL: pcat Protocol")
result = RegValueSet(HKEY_CLASSES_ROOT, "pcat\", "URL Protocol", "")
result = RegKeyCreate(HKEY_CLASSES_ROOT, "pcat\shell\open\command")
result = RegValueSet(HKEY_CLASSES_ROOT, "pcat\shell\open\command", "", pfad & " %1")
result = RegKeyCreate(HKEY_CLASSES_ROOT, "pcat\DefaultIcon")
result = RegValueSet(HKEY_CLASSES_ROOT, "pcat\DefaultIcon", "", pfad)

End Sub

Private Sub Form_Load()
'Sub zum initialisieren
Winsock1.Protocol = sckUDPProtocol
Winsock1.RemoteHost = "localhost"
Winsock1.RemotePort = 28958
Winsock1.LocalPort = 28958

'Error tritt bei schon belegtem Port auf, d.h. das
'Programm läuft schon einmal
On Error Goto bindfehler
Winsock1.Bind
'schreibe übergebene Parameter in die Textbox
Text1.Text = Command$
Exit Sub

bindfehler:
'wenn Fehler aufgetritt, schickt es den übergebenen
'String an das schon laufende Programm und beendet
'sich selbst
  Winsock1.Close
  Winsock1.LocalPort = Winsock1.RemotePort + 1
  Winsock1.SendData Command$
  Unload Me

End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
'Sub wenn Datem am Winsock ankommen
Dim daten As String
'schreibe die angekommenen Daten in die Texbox
Winsock1.GetData daten
Text1.Text = daten
End Sub
 
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

 
'
'Autor: ActiveVB.de

' Dem Tipp angepasstes Registry Modul

' Ausschlielich Registry Funktionen!

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
 
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE Or _
                 KEY_ENUMERATE_SUB_KEYS _
                 Or KEY_NOTIFY
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
Const ERROR_SUCCESS = 0&
 
Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_LITTLE_ENDIAN = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6
Const REG_MULTI_SZ = 7
 
Const REG_OPTION_NON_VOLATILE = &H0
 
Private RegRoot&

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
 



'---------- Ende Modul "Module1" alias Module1.bas ----------
'---------------- Ende Projektdatei pcat.vbp ----------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 8 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.