elwig-misc/wgmaster/vba/MTcpSocket.bas

Option Compare Database

' Fügen sie diesen Code in ein öffentliches Modul ein
Private Declare Function gethostbyname Lib "wsock32.dll" ( _
  ByVal Name As String) As Long
Private Declare Function socket Lib "wsock32.dll" ( _
  ByVal af As Long, _
  ByVal prototype As Long, _
  ByVal protocol As Long) As Long
Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Private Declare Function connect Lib "wsock32.dll" ( _
  ByVal s As Long, _
  Name As SOCKADDR, _
  ByVal namelen As Long) As Long
Private Declare Function send Lib "wsock32.dll" ( _
  ByVal s As Long, _
  buf As Any, _
  ByVal length As Long, _
  ByVal flags As Long) As Long
Private Declare Function recv Lib "wsock32.dll" ( _
  ByVal s As Long, _
  buf As Any, _
  ByVal length As Long, _
  ByVal flags As Long) As Long
Private Declare Function ioctlsocket Lib "wsock32.dll" ( _
  ByVal s As Long, _
   ByVal cmd As Long, _
  argp As Long) As Long
Private Declare Function inet_addr Lib "wsock32.dll" ( _
  ByVal cp As String) As Long
Private Declare Function htons Lib "wsock32.dll" ( _
  ByVal hostshort As Integer) As Integer
Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Private Declare Sub MoveMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  Destination As Any, _
  Source As Any, _
  ByVal length As Long)
 
Private Declare Function WSAStartup Lib "wsock32.dll" ( _
  ByVal wVersionRequested As Integer, _
  lpWSAData As WSAData) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
 
Private Type HOSTENT
  hname As Long
  haliases As Long
  haddrtype As Integer
  hlength As Integer
  haddrlist As Long
End Type
 
Private Type SOCKADDR
  sin_family As Integer
  sin_port As Integer
  sin_addr As Long
  sin_zero As String * 8
End Type

Private Type WSAData
  wVersion As Integer
  wHighVersion As Integer
  szDescription As String * 257
  szSystemStatus As String * 129
  iMaxSockets As Long
  iMaxUdpDg As Long
  lpVendorInfo As Long
End Type
 


' eine der HOSTENT-haddrtype-Konstanten
Private Const AF_INET = 2 ' Internet Protokoll (UDP/IP oder TCP/IP).
 
' socket prototype-Konstanten
Private Const SOCK_STREAM = 1 ' 2-wege Stream. Bei AF_INET ist es das
' TCP/IP Protokoll
Private Const SOCK_DGRAM = 2 ' Datagramm Basierende verbindung. Bei AF_INET
' ist es das UDP Protokoll
 
' recv flags-Konstanten
Private Const MSG_PEEK = &H2 ' Daten aus dem Puffer lesen, aber nicht aus
' dem Puffer entfernen
 
' ioctlsocket cmd-Konstanten
Private Const FIONBIO = &H8004667E ' Setzen ob die Funktion bei der nächsten
' Datenanfrage zurückkehren soll

Dim hSock As Long


' IP-Adresse einer Internetadresse ermitteln
Public Function GetIP(ByVal HostName As String) As String
  Dim pHost As Long, HostInfo As HOSTENT
  Dim pIP As Long, IPArray(3) As Byte
 
  ' Informationen des Host ermitteln
  pHost = gethostbyname(HostName)
  If pHost = 0 Then Exit Function
 
  ' HOSTENT-Struktur kopieren
  MoveMemory HostInfo, ByVal pHost, Len(HostInfo)
 
  ' Pointer der 1ten Ip-Adresse ermitteln
  ReDim IpAddress(HostInfo.hlength - 1)
  MoveMemory pIP, ByVal HostInfo.haddrlist, 4
  MoveMemory IPArray(0), ByVal pIP, 4
 
  GetIP = IPArray(0) & "." & IPArray(1) & "." & IPArray(2) & "." & IPArray(3)
End Function

' Mit einem Server verbinden
Public Function ConnectToServer(ByVal ServerIP As String, ByVal ServerPort _
As Long) As Long
  Dim Retval As Long, ServerAddr As SOCKADDR
 
  ' Socket erstellen
  hSock = socket(AF_INET, SOCK_STREAM, 0&)
  If hSock = -1 Then
    ConnectToServer = -1
    Exit Function
  End If
 
  ' mit dem Server verbinden
  With ServerAddr
    .sin_addr = inet_addr(ServerIP)
    .sin_port = htons(ServerPort)
    .sin_family = AF_INET
  End With
  Retval = connect(hSock, ServerAddr, Len(ServerAddr))
  If Retval < 0 Then
    MsgBox ("Connection Error:" + Retval)
    Call closesocket(hSock)
    ConnectToServer = -1
    Exit Function
  End If
 
  ' Rückkehren der Funktion nach dem Abfragen von ankommenden Daten erzwingen
  Retval = ioctlsocket(hSock, FIONBIO, 1&)
 
  ' Socket-ID zurückgeben
  ConnectToServer = hSock
End Function

' Sock/Verbindung schließen
Public Function Disconnect(ByRef Sock As Long)
  Call closesocket(hSock)
  Sock = 0
End Function

' Daten senden
Public Function SendData(ByVal Data As String) As Long
  SendData = send(hSock, ByVal Data, Len(Data), 0&)
End Function

' Sind Daten angekommen ?
Public Function DataComeIn() As Long
  Dim Tmpstr As String * 1
 
  DataComeIn = recv(hSock, ByVal Tmpstr, Len(Tmpstr), MSG_PEEK)
  If DataComeIn = -1 Then
    DataComeIn = WSAGetLastError()
  End If
End Function

' Daten ermitteln
Public Function GetData() As String
  Dim Tmpstr As String * 4096, Retval As Long
 
  Retval = recv(hSock, ByVal Tmpstr, Len(Tmpstr), 0&)
  GetData = Left$(Tmpstr, Retval)
End Function
 
' Fügen Sie diesen Code in eine Form mit einem Command-Button und einem
' Textfeld ein
 

Public Function StartWinSocket() As Long

  Dim Retval As Long, WSD As WSAData
 
  Retval = WSAStartup(&H202, WSD)
  If Retval < 0 Then
   StartWinSocket = -1
  End If
  
   StartWinSocket = 0

End Function


Public Sub EndWinSocket()

  Call Disconnect(hSock)
  Call WSACleanup
  
End Sub


Public Function ReceiveString(length) As String

Dim resultString As String

While Len(resultString) < length

 While DataComeIn() = 0
  DoEvents
 Wend
 
 resultString = resultString + GetData()
 
Wend
ReceiveString = resultString

End Function