测试模块.bas

一个商场财务系统

Attribute VB_Name = "Module1"
Option Explicit
Dim I As Integer
Public Const IP_STATUS_BASE = 11000
Public Const IP_SUCCESS = 0
Public Const IP_BUF_TOO_SMALL = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Public Const IP_NO_RESOURCES = (11000 + 6)
Public Const IP_BAD_OPTION = (11000 + 7)
Public Const IP_HW_ERROR = (11000 + 8)
Public Const IP_PACKET_TOO_BIG = (11000 + 9)
Public Const IP_REQ_TIMED_OUT = (11000 + 10)
Public Const IP_BAD_REQ = (11000 + 11)
Public Const IP_BAD_ROUTE = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Public Const IP_PARAM_PROBLEM = (11000 + 15)
Public Const IP_SOURCE_QUENCH = (11000 + 16)
Public Const IP_OPTION_TOO_BIG = (11000 + 17)
Public Const IP_BAD_DESTINATION = (11000 + 18)
Public Const IP_ADDR_DELETED = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Public Const IP_MTU_CHANGE = (11000 + 21)
Public Const IP_UNLOAD = (11000 + 22)
Public Const IP_ADDR_ADDED = (11000 + 23)
Public Const IP_GENERAL_FAILURE = (11000 + 50)
Public Const MAX_IP_STATUS = (11000 + 50)
Public Const IP_PENDING = (11000 + 255)
Public Const PING_TIMEOUT = 200
Public Const WS_VERSION_REQD = &H101
Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD = 1
Public Const SOCKET_ERROR = -1
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128

Public Type ICMP_OPTIONS
  Ttl As Byte
  Tos As Byte
  Flags As Byte
  OptionsSize As Byte
  OptionsData As Long
End Type

Dim ICMPOPT As ICMP_OPTIONS
Public Type ICMP_ECHO_REPLY
  Address As Long
  Status As Long
  RoundTripTime As Long
  DataSize As Integer
  Reserved As Integer
  DataPointer As Long
  Options As ICMP_OPTIONS
  Data As String * 250
End Type

Public Type WSADATA
  wVersion As Integer
  wHighVersion As Integer
  szDescription(0 To MAX_WSADescription) As Byte
  szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  wMaxSockets As Integer
  wMaxUDPDG As Integer
  dwVendorInfo As Long
End Type

Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle&) As Long
Public Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, _
   ByVal DestinationAddress As Long, ByVal RequestData As String, _
   ByVal RequestSize As Integer, ByVal RequestOptions As Long, _
   ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, _
   ByVal Timeout As Long) As Long
Public Declare Function WSAGetLastError Lib "WSOCK32.dll" () As Long
Public Declare Function WSAStartup Lib "WSOCK32.dll" _
  (ByVal wVersionReqired As Long, lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "WSCOK32.dll" () As Long
Public Declare Function gethostname Lib "WSCOK32.dll" _
  (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Public Declare Function gethostbyname Lib "WSOCK32.dll" (ByVal szHost$) As Long
Public Declare Function RtlMoveMemory Lib "kernel32" _
  (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) As Long
  
Public Function GetStatusCode(Status As Long) As String
 Dim msg As String
 Select Case Status
  Case IP_SUCCESS: msg = "测试成功"
  Case IP_DEST_HOST_UNREACHABLE: msg = "测试失败"
  Case IP_REQ_TIMED_OUT: msg = "测试失败"
  Case IP_BAD_DESTINATION: msg = "测试失败"
  Case Else:
 End Select
 GetStatusCode = msg
End Function
Public Function Hibyte(ByVal wParam As Integer)
 Hibyte = wParam \ &H100 And &HFF&
End Function
Public Function LoByte(ByVal wParam As Integer)
 LoByte = wParam And &HFF&
End Function
Public Function Ping(szAddress As String, Echo As ICMP_ECHO_REPLY) As Long
 Dim hPort As Long
 Dim dwAddress As Long
 Dim sDataToSend As String
 Dim iOpt As Long
 sDataToSend = Form1!Text2.Text
 dwAddress = AddressStringToLong(szAddress)
 hPort = IcmpCreateFile()
 If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, Echo, Len(Echo), PING_TIMEOUT) Then
   Ping = Echo.RoundTripTime
 Else: Ping = Echo.Status * -1
 End If
 Call IcmpCloseHandle(hPort)
End Function
Function AddressStringToLong(ByVal tmp As String) As Long
 Dim parts(1 To 4) As String
 I = 0
 While InStr(tmp, ".") > 0
  I = I + 1
  parts(I) = Mid(tmp, 1, InStr(tmp, ".") - 1)
  tmp = Mid(tmp, InStr(tmp, ".") + 1)
  Wend
  I = I + 1
  parts(I) = tmp
  If I <> 4 Then
   AddressStringToLong = 0
   Exit Function
End If
  AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
                             Right("00" & Hex(parts(3)), 2) & _
                             Right("00" & Hex(parts(2)), 2) & _
                             Right("00" & Hex(parts(1)), 2))
End Function
Public Function SocketsCleanup() As Boolean
Dim X As Long
X = WSACleanup()
If X <> 0 Then
 MsgBox "Windows Sockets error" & Trim$(Str$(X)) & _
          "Occurred in Cleanup.", vbExclamation
 SocketsCleanup = False
 Else
 SocketsCleanup = True
End If
End Function
Public Function SocketsInitialize() As Boolean
 Dim WSAD As WSADATA
 Dim X As Integer
 Dim szLoByte As String, szHiByte As String, szBuf As String
 X = WSAStartup(WS_VERSION_REQD, WSAD)
 If X <> 0 Then
  MsgBox "Windows Sockets for 32 bit Windows " & _
   "environments is not successfully responding. "
 SocketsInitialize = False
 Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
 Hibyte(WSAD.wVersion) < WS_VERSION_MINOR) Then
 szHiByte = Trim$(Str$(Hibyte(WSAD.wVersion)))
 szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
 szBuf = "Windows Sockets Version" & szLoByte & "." & szHiByte
 szBuf = szBuf & "is not supported by Windows " & _
        "Sockets for 32 bit Windows environments."
 MsgBox szBuf, vbExclamation
 SocketsInitialize = False
Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
 szBuf = "This application reqires a minimum of" & _
      Trim$(Str$(MIN_SOCKETS_REQD)) & "supported sockets."
      MsgBox szBuf, vbExclamation
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function