VBA: Jak na TCP/IP?

Jan Matuška 12/2007 - Opět dávám k dispozici něco z mých zkušeností z posledních let.

Chtěl jsem pomocí VBA v MS Accessu 2000 stahovat mejly. Problém byl s TCP/IP socketem. Většina příkladů na netu (Planet Source Code atd.) používala ActiveX komponentu wsock. Jelikož nemám licenci na použití této komponenty (asi bych musel kvůli této drobnosti kupovat za drahý peníz celý Visual Basic), byly mi tyto příklady k ničemu. Musel jsem najít řešení pomocí Windows API. Velké pátrání se ale nakonec vyplatilo.. Našel jsem kód, který jsem si upravil do VBA třídy. Naprosto dokonale jsem tomu možná chvilku rozuměl, ale dnes už nevím přesně proč jsem které úpravy prováděl. Hlavně uživatelské události v třídách způsobovaly neopravitelné zničení MDB souboru při běhu programu, tak jsem se musel obejít bez nich. Třída teď funguje spolehlivě již několik let.

Možná jsem umazal nějaké odkazy na původního autora, aby mi nezavazely a nepletly se mi tam. Mělo to být jen pro moje potřeby. Takže když najdete někde tento kód, vězte, že nejsem tak docela jeho autorem, jen jsem ho okopíroval a poupravoval.

Abych poznal, že jsou to moje knihovny a konstanty, a ne mikrosoftí, a aby se mi dobře hledaly, píšu si důsledně před názvy své "jma*", tak se nedivte.

Soubor: jmaWebTcpIp.cls

Option Explicit
'Event ErrMessage(msg As String)

Private Declare Function ws_select Lib "ws2_32.dll" Alias "select" (ByVal nfds As Long, ByRef readfds As Any, ByRef writefds As Any, ByRef exceptfds As Any, ByRef TimeOut As Long) As Long
Private Const FD_SETSIZE = 64
Private Type timeval
  tv_sec  As Long   'seconds
  tv_usec As Long   'and microseconds
End Type
Private Type fd_set
  fd_count                  As Long '// how many are SET?
  fd_array(1 To FD_SETSIZE) As Long '// an array of SOCKETs
End Type
Private Const WSA_DESCRIPTION_LEN = 257
Private Const WSA_SYS_STATUS_LEN = 129
Private Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequired As Integer, ByRef lpWSAData As WSAData) As Long
Private Type WSAData
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSA_DESCRIPTION_LEN
    szSystemStatus As String * WSA_SYS_STATUS_LEN
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type
Private Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal lType As Long, ByVal Protocol As Long) As Long
Private Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Private Const SOCK_STREAM As Long = 1
Private Const AF_INET As Long = 2
Private Const IPPROTO_TCP As Long = 6
Private Const INVALID_SOCKET As Long = Not 0
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Private Declare Function htonl Lib "ws2_32.dll" (ByVal hostlong As Long) As Long
Private Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer
Private Declare Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long
Private Declare Function ws_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef Name As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function ws_send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByVal buf As String, ByVal lLen As Long, ByVal flags As Long) As Long
Private Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As String, ByVal lLen As Long, ByVal flags As Long) As Long
Private Declare Function ioctlsocket Lib "ws2_32.dll" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
Private Const FIONBIO As Long = &H8004667E
Private Type SOCKADDR
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type
Private Const SOCKET_ERROR As Long = -1
Private Declare Function bind Lib "ws2_32.dll" (ByVal s As Long, ByRef addr As SOCKADDR, ByVal namelen As Long) As Long
Private Declare Function listen Lib "ws2_32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
Private Const SOMAXCONN As Long = &H7FFFFFFF
Private Declare Function accept Lib "ws2_32.dll" (ByVal s As Long, ByRef addr As SOCKADDR, ByRef addrlen As Long) As Long
'*****
Dim hSocket As Long, tSockAddr As SOCKADDR
'*********************************************************

Public Enum jmaTcpCutExistingEnum
  jmaTcpDisconnectNo = 0
  jmaTcpDisconnectYes = 1
  jmaTcpDisconnectAsk = 2
End Enum

Public Enum jmaTcpStateEnum
  jmaTcpStateError = 0
  jmaTcpStateDisConnected = 1
  jmaTcpStateConnected = 11
  jmaTcpStateDataTransfer = 12
'  jmaTcpStateDataRead = 3
'  jmaTcpStateDataWrite = 4
End Enum

Dim mRaiseAll As Boolean
Dim mErrorMsg As String

Public Property Get ErrorMsg() As String
  ErrorMsg = mErrorMsg
End Property

Public Property Get RaiseAllEventMessages() As Boolean
  RaiseAllEventMessages = mRaiseAll
End Property
Public Property Let RaiseAllEventMessages(ByVal NewValue As Boolean)
  mRaiseAll = NewValue
End Property

Public Property Get Handle() As Long
  Handle = hSocket
End Property

Private Sub ErrMessage(ByVal Msg As String)
  mErrorMsg = Msg
End Sub

Public Function Connect(ByVal IP As String, ByVal Port As String, Optional CutExisting As jmaTcpCutExistingEnum = jmaTcpDisconnectNo) As Boolean
'JMA
'I: CutExisting ... jestli odpojit existujici spojeni
  Dim tWSAData As WSAData
  Dim Er
  
  Connect = False
  
  Er = WSAStartup(&H202, tWSAData) 'inicializujeme WinSock verzi 2.2
  If Er <> 0 Then
    Call ErrMessage("Nepodarilo se inicializovat WinSock 2.2 - chyba " & Er)
    Exit Function
  End If
    
  If hSocket <> 0 Then 'pokud je handle na socket nenulovy, tak jsem pripojen
    'jsem pripojenej -> dotaz na odhlaseni a znovu napojeni
    Select Case CutExisting
    Case jmaTcpDisconnectNo
    Case jmaTcpDisconnectYes
      Disconnect
    Case jmaTcpDisconnectAsk
      If MsgBox("Momentalne jste pripojeni. Chcete se odhlasit a pripojit se znovu?", vbQuestion + vbYesNo, "jmaWebTcpIp") = vbYes Then
        Disconnect
      End If
    End Select
  End If
  
  If hSocket = 0 Then
    hSocket = socket(AF_INET, SOCK_STREAM, IPPROTO_TCP) 'vytvorim socket
    If hSocket = INVALID_SOCKET Then 'chyba
      hSocket = 0
      Call ErrMessage(" Nepodarilo se vytvorit socket")
      Exit Function
    End If
    
    'naplnime strukturu
    With tSockAddr
        .sin_family = AF_INET              'rodina protokolu
        .sin_addr = inet_addr(IP)  'inet_addr("127.0.0.1") 'loop-back adresa
        .sin_port = htons(Port) 'htons(9999)            'port (pozn. prevadim pomoci htons)
    End With
    
    'zkusim se pripojit
    If ws_connect(hSocket, tSockAddr, Len(tSockAddr)) = SOCKET_ERROR Then
        'chyba -> zavru socket
        closesocket hSocket
        hSocket = 0
        Call ErrMessage(Time & " Nepodarilo se pripojit")
        Exit Function
    Else
        If mRaiseAll Then Call ErrMessage(Time & " Spojeni otevreno")
    End If
    
    'prepnuti na neblokujici socket
    'to je dulezite - jinak by nastala prodleva u volani recv
    If ioctlsocket(hSocket, FIONBIO, 1) = SOCKET_ERROR Then
        Call ErrMessage(Time & " Chyba pri prepnuti na neblokujici socket")
    Else 'vsechno v poradku, muzeme pokracovat
'        Connect = Recieve
        'timer pro ziskani dat ktera nam poslal server
'            tmrRecv.Enabled = True
'            tmrStav.Enabled = True
    End If
  Else 'spojeni ponechano stavajici
      
  End If
  Connect = True
End Function

Public Function Send(ByVal Request As String) As Boolean
On Error GoTo EH
  Dim Er
  Send = False
  If hSocket = 0 Then
    Disconnect
  ElseIf Len(Request) > 0 Then
    If mRaiseAll Then Call ErrMessage("> " & Request)
    Request = Request & vbCrLf
    Er = ws_send(hSocket, Request, Len(Request), 0)        'poslu text
    If Er = SOCKET_ERROR Then
    Else
      If mRaiseAll Then Call ErrMessage(Time & " Odeslani OK")
    End If
  End If
  Send = True
EX:
  Exit Function
EH:
  MsgBox Err.Description
  Resume EX
  Resume
End Function
'
'Private Function RecieveAll() As String
'  Dim sOut As String
'  Dim bCompleted As Boolean
'  Dim bWaiting As Boolean
'  Dim sData As String, lRet
'  bWaiting = True 'ze začátku může být dlouho -1
'  bCompleted = False 'pokud je víc řádků, čekat na tečku
'  Do Until bCompleted And Not bWaiting
'    If lRet > 0 Then 'Prisla data
'      bWaiting = False
'      sData = Left(sData, lRet)
'      sOut = sOut & sData
'      call ErrMessage(Time & " Prisla data: " & sData)
'      If StrCount(sOut, vbCrLf, 2) >= 2 Then
'        If Right(sOut, 3) = "." & vbCrLf Then
'          sOut = Left(sOut, Len(sOut) - 3)
'          bCompleted = True
'        Else
'          bCompleted = False
'        End If
'      Else
'        bCompleted = True
'      End If
'    ElseIf lRet = 0 Then 'Server me odpojil.
'      call ErrMessage(Time & " Server zrusil spojeni")
'      Disconnect
'      sData = vbnullstring
'      Exit Do
'    ElseIf lRet = -1 Then 'cekat na to, az prijdou data (-1 => jeste nedorazily)
'      sData = vbnullstring
'      bCompleted = False
'    End If
'    DoEvents
'  Loop
'  Recieve = sOut 'ale na konci mám crlf!
'End Function

Public Function Query(ByVal Command As String) As String
  Dim s As String
  If QueryTo(Command, s) Then Query = s
End Function

Public Function QueryTo(ByVal Command As String, ToString As String) As Boolean
On Error GoTo EH
  If Send(Command) Then
    Do While State = jmaTcpStateDataTransfer
      ToString = ToString & Recieve()
    Loop
    QueryTo = True
  End If
EX:
  Exit Function
EH:
  MsgBox Err.Description
  Resume EX
End Function

Public Function RecieveAllTo(ToString As String) As Boolean
On Error GoTo EH
  ToString = vbNullString
  Do While State = jmaTcpStateDataTransfer
    DoEvents
    ToString = ToString & Recieve()
  Loop
  RecieveAllTo = True
EX:
  Exit Function
EH:
  MsgBox Err.Description
  Resume EX
End Function

Public Function Recieve(Optional ByVal BufLen As Long = 255)
  Dim sData As String, lRet As Long
  sData = Space$(BufLen) 'priprava bufferu
  lRet = recv(hSocket, sData, Len(sData), 0) 'ziskame data, v lRet je delka dat
  If lRet > 0 Then 'Prisla data
    sData = left(sData, lRet)
    If mRaiseAll Then Call ErrMessage(Time & " Prisla data: " & sData)
    Recieve = sData
  ElseIf lRet = 0 Then 'Server me odpojil.
    Call ErrMessage(Time & " Server zrusil spojeni")
    Disconnect
  End If
  
End Function

Public Function State() As jmaTcpStateEnum
  Dim tStateRead As fd_set, tStateWrite As fd_set
  Dim lRetR As Long, sVystup As String
  Dim lRetW As Long
  Dim lRet As Long
  
  With tStateRead
      .fd_count = 1
      .fd_array(1) = hSocket
  End With
  tStateWrite = tStateRead
  lRet = ws_select(0, tStateRead, tStateWrite, ByVal 0&, 0)

'  lRetR = ws_select(0, tStateRead, ByVal 0&, ByVal 0&, 0)
'  lRetW = ws_select(0, ByVal 0&, tStateWrite, ByVal 0&, 0)
'  If lRetR = 2 Then
'    State = jmaTcpStateDataRead
'  ElseIf lRetW = 2 Then
'    State = jmaTcpStateDataWrite
'  ElseIf lRetR = 1 Or lRetW = 1 Then
'      State = jmaTcpStateConnected
'  ElseIf lRetR = SOCKET_ERROR Or lRetW = SOCKET_ERROR Then
  Select Case lRet
  Case 1
    State = jmaTcpStateConnected
  Case 2
    State = jmaTcpStateDataTransfer
  Case SOCKET_ERROR
      State = jmaTcpStateError
  Case Else
      State = jmaTcpStateError
  End Select
End Function
Public Property Get IsConnected() As Boolean
  IsConnected = (State >= jmaTcpStateConnected) '(hSocket <> 0)
End Property

Public Sub Disconnect()
  If hSocket <> 0 Then
    closesocket hSocket
    If mRaiseAll Then Call ErrMessage(Time & " Odpojeno.")
    hSocket = 0
  End If
End Sub

Private Sub Class_Terminate()
  If hSocket <> 0 Then closesocket hSocket
  WSACleanup
End Sub