Code aus Form1.frm
Option Explicit
Dim Daten As String, Socks() As SocksProxyInfo
Private Type SocksProxyInfo
  State As SocksState
  InetIndex As Integer
  UdpIndex As Integer
  UDPData As String
  Datagram As String
End Type
Enum SocksState
  sMethodSelect = 1
  sAuth = 2
  sAccepted = 3
  sOK = 4
End Enum
Dim LocalIP As String
Private Sub Command1_Click()
    Call Timer1_Timer
End Sub
Private Sub Form_Load()
    LAN(0).Bind 1080, "127.0.0.1"
    LAN(0).Listen
    'Erstmal sorgen wir dafür, dass der Proxy Verbindungen auf dem
    'Port 1080 annimmt (Standard-SOCKS-Port)
    
    GetIP
    ' Jetzt suchen wir unsere aktuelle Internet-IP falls möglich raus
    
    Call Timer1_Timer
End Sub
Private Sub LAN_Close(Index As Integer)
    On Error Resume Next
    
    LAN(Index).Close
    
    Debug.Print "LAN.Close " & Index
    
    Internet(Socks(Index).InetIndex).Close
    Internet(Socks(Index).InetIndex).Tag = "unused"
End Sub
Private Sub LAN_ConnectionRequest(Index As Integer, ByVal _
    requestID As Long)
  Dim i As Long, Nummer As Long
    
    'Hier nehmen wir Verbindungen an, die aus dem lokalen Netzwerk
    'stammen, also alles Verbindungen von Clients
    
    Debug.Print "LAN.ConnectionRequest"
    
    For i = LAN.LBound To LAN.UBound
      If LAN(i).State = sckClosed Then
        LAN(i).Accept requestID
        Nummer = i
        Socks(Nummer).State = sMethodSelect
        Goto ConAcc
      End If
    Next i
    
    Load LAN(LAN.UBound + 1)
    Nummer = LAN.UBound
    
    ReDim Preserve Socks(Nummer)
    Socks(Nummer).State = sMethodSelect
    LAN(Nummer).Accept requestID
    
ConAcc:
    
    Debug.Print "LAN.Accepted " & Index
    Debug.Print "Remote: " & LAN(Index).RemoteHostIP & " " & _
        LAN(Index).RemotePort
    Debug.Print "Local: " & LAN(Index).LocalIP & " " & _
        LAN(Index).LocalPort
End Sub
Private Sub LAN_Error(Index As Integer, ByVal Number As Integer, _
    Description As String, ByVal Scode As Long, ByVal Source As _
    String, ByVal HelpFile As String, ByVal HelpContext As Long, _
    CancelDisplay As Boolean)
    LAN(Index).Close
    
    Debug.Print "Lan Error Closing " & Index
    
    If Index = 0 Then
      LAN(Index).Listen: Debug.Print "Restart Lan 0 Listening"
    End If
End Sub
Private Sub LAN_DataArrival(Index As Integer, ByVal bytesTotal As Long)
  Dim Buffer As String
  Dim Version As Integer, Befehl As String, DestAdresse As String
  Dim DestPort As Integer, NextPos As Integer, i As Long
    
    'Debug.Print "Incoming Data (LAN)"
    
    'Und hier kommen nun sowohl SOCKS-Daten als auch später normale
    'Daten an. Dabei wird nach aktuellen Status unterschieden, wie mit
    'den empfangenen Daten umgegangen wird.
    
    'Zuerst schickt uns der Client eine Nachricht, welche _
        Authentifizierungs-
    'Methoden er unterstützt, als Antwort erhält er "0" (da wir _
        nur den Aufbau
    'des Protokolls erklären wollen). Null bedeutet, dass keine _
        Kontrolle nötig
    'ist. Wir wechseln somit sofort den Status nach "Angenommen"
    
    'Wenn wir im Status "Angenommen" sind, erhalten wir Befehle, was der
    'Proxy machen soll. Ob er zum Beispiel eine lauschende Verbindung
    'aufbauen soll, oder sich zu einem anderen Server verbinden sollte.
    'Ebenso ist der "UDP"-Modus möglich. Sobald ein Befehl ausgeführt
    'wurde, schalten wir in den Status "Ok"
    
    'Im Status "OK" werden Daten einfach nur weitergeleitet
    
    LAN(Index).GetData Buffer, vbString
    
    If Socks(Index).State <> sOK Then
      Version = Asc(Mid$(Buffer, 1, 1))
      
      If Version <> 5 Then
        LAN(Index).Close
        Debug.Print "Falsche Versionsnummer, Lan Closed"
        Exit Sub
      End If
    End If
    
    Select Case Socks(Index).State
      Case sMethodSelect
        Version = Asc(Mid$(Buffer, 1, 1))
        
        If Version = 5 Then
          ' keine Passwortkontrolle
          
          LAN(Index).SendData Chr$(Version) & Chr$(0)
        Else
          LAN(Index).SendData Chr$(Version) & Chr$(255)
          Exit Sub
        End If
        
        Socks(Index).State = sAccepted
      Case sAuth
      Case sAccepted
        Select Case Asc(Mid$(Buffer, 2, 1))
          Case &H1
            Befehl = "CONNECT"
          Case &H2
            Befehl = "UDP"
          Case &H3
            Befehl = "BIND"
        End Select
        
        Select Case Asc(Mid$(Buffer, 4, 1))
          Case &H1
            For i = 0 To 2
              DestAdresse = DestAdresse & Asc(Mid$(Buffer, 5 + i, _
                  1)) & "."
            Next i
            DestAdresse = DestAdresse & Asc(Mid$(Buffer, 8, 1))
            
            NextPos = 9
          Case &H3
            DestAdresse = Mid$(Buffer, 6, Asc(Mid$(Buffer, 5, 1)))
            
            NextPos = Asc(Mid$(Buffer, 5, 1)) + 6
          Case &H4
            For i = 0 To 4
              DestAdresse = DestAdresse & Asc(Mid$(Buffer, 5 + i, _
                  1)) & "."
            Next i
            DestAdresse = DestAdresse & Asc(Mid$(Buffer, 10, 1))
            
            NextPos = 11
        End Select
        
        DestPort = Val(Asc(Mid$(Buffer, NextPos, 1))) * 256 Or _
            Val(Asc(Mid$(Buffer, NextPos + 1, 1)))
        
        Select Case LCase(Befehl)
          Case "connect"
            Debug.Print "cmd: Connect " & Index
            Connect Index, DestAdresse, DestPort
          Case "bind"
            Debug.Print "cmd: Bind"
            Bind Index, DestAdresse, DestPort
          Case "udp"
            Debug.Print "cmd: UDP"
            UDPConnect Index, DestAdresse, DestPort
        End Select
        
        Socks(Index).State = sOK
      Case sOK
        If Internet(Socks(Index).InetIndex).State = sckConnected Then
          Internet(Socks(Index).InetIndex).SendData Buffer
        End If
    End Select
End Sub
Sub Connect(LAN_Index As Integer, DestAdresse As String, DestPort _
    As Integer, Optional sProtokoll As ProtocolConstants = _
    sckTCPProtocol)
  Dim i As Long, Nummer As Long
    
    'Hier bauen wir, auf Wunsch des Clients, eine Verbindung ins
    'Internet auf
    'Der Client erhält erst eine Erfolgsmeldung, wenn die Verbindung
    'erfolgreich aufgebaut wurde
    
    For i = Internet.LBound To Internet.UBound
      If Internet(i).Tag = "unused" Then
        Nummer = i
        Goto ConAcc
      End If
    Next i
    
    Load Internet(Internet.UBound + 1)
    Nummer = Internet.UBound
    Internet(Nummer).Tag = "used"
ConAcc:
    
    With Internet(Nummer)
      .Protocol = sProtokoll
      .Connect DestAdresse, DestPort
      .Tag = "connect" & CStr(LAN_Index)
    End With
    
    Socks(LAN_Index).InetIndex = Nummer
    
    Debug.Print "Internet Connect " & LAN_Index
End Sub
Sub UDPConnect(LAN_Index As Integer, DestAdresse As String, _
    DestPort As Integer)
  Dim i As Long, Nummer As Long
    
    'Diese Funktion öffnet eine UDP-Verbindung zur übergebenen Adresse
    '(vom Client empfangen)
    'Da die Verbindung sofort besteht, erhält der Client auch sofort
    'eine Bestätigung
    
    For i = Internet.LBound To Internet.UBound
      If Internet(i).Tag = "unused" Then
        Nummer = i
        Goto ConAcc
      End If
    Next i
    
    Load Internet(Internet.UBound + 1)
    Nummer = Internet.UBound
    Internet(Nummer).Tag = "used"
ConAcc:
    
    With Internet(Nummer)
      .Protocol = sckUDPProtocol
      .RemoteHost = DestAdresse
      .RemotePort = DestPort
      .Connect
      .Tag = "udp" & CStr(LAN_Index)
    End With
    
    Socks(LAN_Index).UdpIndex = Nummer
    
    Notify LAN_Index, Internet(Nummer).LocalPort
    
    Debug.Print "Internet Connect (UDP) " & LAN_Index
End Sub
Sub Bind(LAN_Index As Integer, DestAdresse As String, DestPort As _
    Integer)
  Dim i As Long, Nummer As Long
    
    'Hier setzen wir ein Winsock auf "Listen", sprich wir bauen
    'eine lauschende Verbindung auf
    'Dann weisen wir den Client darauf hin, dass das Winsock geladen
    'wurde. Er erhält eine weitere Erfolgsmeldung, sobald eine
    'Verbindung angenommen wurde
    
    For i = Internet.LBound To Internet.UBound
      If Internet(i).Tag = "unused" Then
        Nummer = i
        Goto ConAcc
      End If
    Next i
    
    Load Internet(Internet.UBound + 1)
    Nummer = Internet.UBound
    Internet(Nummer).Tag = "used"
ConAcc:
    
    With Internet(Nummer)
      .Protocol = sckTCPProtocol
      'If DestAdresse <> "" Then .LocalHostName = DestAdresse
      If DestPort > 0 Then
        .LocalPort = DestPort
      End If
      .Listen
      .Tag = "bind" & CStr(LAN_Index)
    End With
    
    Socks(LAN_Index).InetIndex = Nummer
    
    Notify LAN_Index, Internet(Nummer).LocalPort
    
    Debug.Print "Internet Bind " & LAN_Index
End Sub
Private Sub Internet_Close(Index As Integer)
  Dim Nummer As Integer
    
    If LCase(Left$(Internet(Index).Tag, 7)) = "connect" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 8))
    ElseIf LCase(Left$(Internet(Index).Tag, 3)) = "udp" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 4))
    ElseIf LCase(Left$(Internet(Index).Tag, 4)) = "bind" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 5))
    End If
    
    Internet(Index).Tag = "unused"
    Internet(Index).Close
    
    Debug.Print "Internet Closed " & Index
    
    LAN(Nummer).Close
    Debug.Print "Lan Closed " & Nummer
End Sub
Private Sub Internet_Connect(Index As Integer)
  Dim Nummer As Integer
    
    'Dieses Ereignis tritt auf, wenn die Verbindung hergestellt wurde
    'Sollte dies auf Grund des CONNECT-Befehls geschehen, _
        benachrichtigen
    'wir den Client über die nun bestehende Verbindung
    
    If LCase(Left$(Internet(Index).Tag, 7)) = "connect" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 8))
      
      Notify Nummer, Internet(Index).RemotePort, _
          Internet(Index).RemoteHostIP
    ElseIf LCase(Left$(Internet(Index).Tag, 3)) = "udp" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 4))
      
      Internet(Index).SendData Socks(Nummer).UDPData
    End If
    
    Debug.Print "Internet.Connect " & Index
End Sub
Private Sub Internet_ConnectionRequest(Index As Integer, ByVal _
    requestID As Long)
  Dim Nummer As Integer
    
    'Hier nehmen wir Verbindungen aus dem Internet an, falls dies
    'ein durch BIND initialisiertes Winsock ist. Der Client wird
    'sofort hierüber informiert
    
    If LCase(Left$(Internet(Index).Tag, 4)) = "bind" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 5))
      
      Internet(Index).Close
      Internet(Index).Accept requestID
      
      Notify Nummer, Internet(Index).RemotePort, _
          Internet(Index).RemoteHostIP
    End If
End Sub
Private Sub Internet_DataArrival(Index As Integer, ByVal _
    bytesTotal As Long)
  Dim Buffer As String, Nummer As Integer, pos As Long, Host As String
  Dim Port As Integer, i As Long
    
    'Hier kommen die Daten aus dem Internet an. Bei den Befehlen
    'CONNECT und BIND leiten wir einfach nur die Daten an den
    'Client weiter. Beim Befehl UDP müssen wir jedoch noch die
    'Daten auswerten. Hier erhalten wir im Prinzip weitere
    '"CONNECT"-Befehle. Wir bauen dann neue TCP-Verbindungen
    'auf
    
    'Debug.Print "Incoming Data (Internet)"
    
    Internet(Index).GetData Buffer
    
    If LCase(Left(Internet(Index).Tag, 7)) = "connect" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 8))
      
      If LAN(Nummer).State <> sckConnected Then
        Internet(Index).Close
        Exit Sub
      End If
      
      LAN(Nummer).SendData Buffer
    ElseIf LCase(Left$(Internet(Index).Tag, 3)) = "udp" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 4))
      
      Select Case Asc(Mid$(Buffer, 4, 1))
        Case &H1
          For i = 0 To 2
            Host = Host & Asc(Mid$(Buffer, 5 + i, 1)) & "."
          Next i
          Host = Host & Asc(Mid$(Buffer, 8, 1))
          pos = 9
        Case &H3
          pos = Asc(Mid$(Buffer, 5, 1))
          Host = Mid$(Buffer, 6, pos)
          pos = pos + 6
        Case &H4
          For i = 0 To 4
            Host = Host & Asc(Mid$(Buffer, 5 + i, 1)) & "."
          Next i
          Host = Host & Asc(Mid$(Buffer, 10, 1))
          pos = 11
      End Select
      
      Port = Val(Asc(Mid$(Buffer, pos, 1))) * 256 Or _
          Val(Asc(Mid$(Buffer, pos + 1, 1)))
      
      Socks(Nummer).Datagram = Left$(Buffer, pos + 2)
      Socks(Nummer).UDPData = Mid$(Buffer, pos + 3)
      
      Connect Nummer, Host, Port, sckUDPProtocol
    ElseIf LCase(Left$(Internet(Index).Tag, 4)) = "bind" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 5))
      
      If LAN(Nummer).State <> sckConnected Then
        Internet(Index).Close
        Exit Sub
      End If
      
      LAN(Nummer).SendData Buffer
    End If
End Sub
Private Sub Internet_Error(Index As Integer, ByVal Number As _
    Integer, Description As String, ByVal Scode As Long, ByVal _
    Source As String, ByVal HelpFile As String, ByVal HelpContext _
    As Long, CancelDisplay As Boolean)
  Dim Antwort(0 To 9) As Byte, Nummer As Long
    
    'Sollte ein Fehler in der vom Client gewünschten Verbindung ins
    'Internet auftauchen, informieren wir ihn darüber und schließen
    'die Internetverbindung
    
    Debug.Print "Internet.Error " & Index & " " & Description
    Internet(Index).Close
    Internet(Index).Tag = "unused"
    
    If LCase(Left(Internet(Index).Tag, 7)) = "connect" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 8))
    ElseIf LCase(Left$(Internet(Index).Tag, 3)) = "udp" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 4))
    ElseIf LCase(Left$(Internet(Index).Tag, 4)) = "bind" Then
      Nummer = Val(Mid$(Internet(Index).Tag, 5))
    Else
      Exit Sub
    End If
    
    Antwort(0) = 5
    Antwort(1) = 1
    Antwort(2) = 0
    Antwort(3) = 1
    Antwort(4) = 0
    Antwort(5) = 0
    Antwort(6) = 0
    Antwort(7) = 0
    Antwort(8) = 0
    Antwort(9) = 0
    
    If LAN(Nummer).State <> sckConnected Then
      Exit Sub
    End If
    LAN(Nummer).SendData StrConv(Antwort, vbUnicode)
End Sub
Sub Notify(LAN_Index As Integer, Port As Integer, Optional sIP As _
    String = "")
  Dim IP() As String, Antwort(0 To 9) As Byte, i As Integer
    
    'Hier schicken wir dem Client eine Erfolgsmeldung. Null bedeutet
    'erfolgreich
    
    If sIP = "" Then
      If LocalIP = "" Then
        GetIP
      End If
      If LocalIP = "" Then
        LocalIP = LAN(LAN_Index).LocalIP
      End If
      IP() = Split(LocalIP, ".")
    Else
      IP() = Split(sIP, ".")
    End If
    
    Antwort(0) = 5
    Antwort(1) = 0
    Antwort(2) = 0
    Antwort(3) = 1
    
    For i = 0 To 3
      Antwort(4 + i) = Val(IP(i))
    Next i
    
    Antwort(8) = Fix(Port / 256)
    Antwort(9) = Port - (Fix(Port / 256) * 256)
    
    LAN(LAN_Index).SendData StrConv(Antwort(), vbUnicode)
    
    Debug.Print "Notify"
End Sub
Private Sub Timer1_Timer()
  Dim i As Long, ListItem As ListItem
    
    ListView1.ListItems.Clear
    
    For i = LAN.LBound To LAN.UBound
      If LAN(i).State = sckConnected Or LAN(i).State = sckListening Then
        Set ListItem = ListView1.ListItems.Add(, , CStr(i))
        ListItem.ListSubItems.Add , , "LAN"
        ListItem.ListSubItems.Add , , LAN(i).RemoteHostIP
        ListItem.ListSubItems.Add , , LAN(i).RemotePort
        ListItem.ListSubItems.Add , , LAN(i).LocalPort
        ListItem.ListSubItems.Add , , IIf(LAN(i).State = _
            sckConnected, "Verbunden", "Lauschen")
        ListItem.ListSubItems.Add , , IIf(LAN(i).Protocol = _
            sckTCPProtocol, "TCP", "UDP")
      End If
      DoEvents
    Next i
    
    For i = Internet.LBound To Internet.UBound
      If Internet(i).State = sckConnected Or Internet(i).State = _
          sckListening Then
        Set ListItem = ListView1.ListItems.Add(, , CStr(i))
        ListItem.ListSubItems.Add , , "Internet"
        ListItem.ListSubItems.Add , , Internet(i).RemoteHostIP
        ListItem.ListSubItems.Add , , Internet(i).RemotePort
        ListItem.ListSubItems.Add , , Internet(i).LocalPort
        ListItem.ListSubItems.Add , , IIf(Internet(i).State = _
            sckConnected, "Verbunden", "Lauschen")
        ListItem.ListSubItems.Add , , IIf(Internet(i).Protocol = _
            sckTCPProtocol, "TCP", "UDP")
      End If
      DoEvents
    Next i
End Sub
Sub GetIP()
  Dim IPs() As String, i As Long
    
    'Wir lesen alle IPs des Rechners aus und filtern LAN-Adressen
    'Achtung, LAN-Adressen können auch anders anfangen, ich kenne
    'nicht mehr alle reservierten Bereiche. Bei Fehlern austauschen
    
    'Die IP, über die der Rechner aus dem Internet angesprochen wird,
    'muss bekannt sein!
    
    IPs = GetIPs()
    
    For i = LBound(IPs) To UBound(IPs)
      If Left$(IPs(i), 8) = "192.168." Then
        IPs(i) = ""
      End If
      If Left$(IPs(i), 5) = "10.0." Then
        IPs(i) = ""
      End If
      
      If IPs(i) <> "" Then
        Debug.Print IPs(i)
      End If
      If IPs(i) <> "" Then
        LocalIP = IPs(i)
      End If
    Next i
End Sub