modnetstate.bas

1、以DLL形式提供医生工作站 2、 根据【检查项目】

Attribute VB_Name = "modNetState"
Option Explicit

Public Const TIMER_INTERVAL = 5000


Public Const NETSTAT_ESTABLISHED = 5

Public Type MIB_TCPROW '" TCP连接表中一行的结构
dwState As Long '" 状态
dwLocalAddr As Long '" Local IP
dwLocalPort As Long '" Local port
dwRemoteAddr As Long '" Remote IP
dwRemotePort As Long '" Remote port
End Type



Public Type MIB_TCPTABLE
    dwNum_Of_Entries As Long ' 当前 TCP连接的总数
    TCP_Table(2000) As MIB_TCPROW ' 预留了120行的缓冲区
End Type




Dim strLocalIp As String
Dim strLocalPort As String
Dim strRemoteIp As String
Dim strRemotePort As String
    

Dim Ip_Buf(1 To 4) As Byte
    
Dim TCP_STATE As MIB_TCPTABLE



Public Declare Function GetTcpTable Lib "iphlpapi.dll" (ByRef pTcpTable As MIB_TCPTABLE, ByRef pdwSize As Long, ByVal bOrder As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal Length As Long)

'获得网络状态
Public Function GetNetStat() As Boolean
On Error GoTo ErrHandler
    
    
    Dim Tmp1 As Long
    Dim Tmp2 As Long

    Dim strSql As String
    
    
    Dim nRtn As Long

    nRtn = GetTcpTable(TCP_STATE, Len(TCP_STATE), 1)
    
    
    Dim i As Long
    strSql = "DELETE FROM NETSNIFF WHERE DEPARTMENT ='" + CStr(DEPARTMENT_NAME) _
        + "' AND WORKSTATION = '" + STATION_NAME + "'"
            
    If Not ExecuteNonQuery(strSql) Then
        GetNetStat = False
        Exit Function
    End If
    
    
    For i = 0 To TCP_STATE.dwNum_Of_Entries
        If TCP_STATE.TCP_Table(i).dwState = NETSTAT_ESTABLISHED Then
            CopyMemory Ip_Buf(1), TCP_STATE.TCP_Table(i).dwLocalAddr, 4
            strLocalIp = CStr(Ip_Buf(1)) + "." + CStr(Ip_Buf(2)) + "." + CStr(Ip_Buf(3)) + "." + CStr(Ip_Buf(4))
            
            Tmp1 = TCP_STATE.TCP_Table(i).dwLocalPort ' 本地端口
            Tmp2 = Tmp1 / 256 + (Tmp1 Mod 256) * 256
            
            strLocalPort = CStr(Tmp2)
            
            CopyMemory Ip_Buf(1), TCP_STATE.TCP_Table(i).dwRemoteAddr, 4
            strRemoteIp = CStr(Ip_Buf(1)) + "." + CStr(Ip_Buf(2)) + "." + CStr(Ip_Buf(3)) + "." + CStr(Ip_Buf(4))
            
            Tmp1 = TCP_STATE.TCP_Table(i).dwRemotePort  '远端端口
            Tmp2 = Tmp1 / 256 + (Tmp1 Mod 256) * 256
            
            strRemotePort = CStr(Tmp2)
            
            
            
            If strLocalIp <> strRemoteIp Then
                'strSql = "DELETE FROM NETSNIFF WHERE DEPARTMENT ='" + CStr(DEPARTMENT_NAME) _
                '    + "' AND WORKSTATION = '" + STATION_NAME + "'"
            
                'If Not ExecuteNonQuery(strSql) Then
                '    GetNetStat = False
                '    Exit Function
                'End If
                
                If STATION_NAME = "" Then
                    STATION_NAME = "影像工作站"
                    
                End If
            
                strSql = "INSERT INTO NETSNIFF(ID,DEPARTMENT,WORKSTATION,LOCALIP,LOCALPORT,REMOTEIP,REMOTEPORT) " _
                    + " VALUES(HTPACS_SEQUENCE.NEXTVAL, '" + CStr(DEPARTMENT_NAME) + "','" + STATION_NAME + "','" + strLocalIp + "','" _
                    + strLocalPort + "','" + strRemoteIp _
                    + "','" + strRemotePort + "')"
            
                If Not ExecuteNonQuery(strSql) Then
                    GetNetStat = False
                    Exit Function
                End If
            End If
            
        End If
        
        
    Next
    
    GetNetStat = True
    Exit Function
ErrHandler:
    GetNetStat = False
End Function

'获得信息交换状态
Public Function GetInfoChange() As Boolean
    On Error GoTo ErrHandler
    
    
    Dim Tmp1 As Long
    Dim Tmp2 As Long

    Dim strSql As String
    
    
    Dim nRtn As Long

    nRtn = GetTcpTable(TCP_STATE, Len(TCP_STATE), 1)
    
    
    Dim i As Long
    strSql = "DELETE FROM INFOCHANGE WHERE USERNAME ='" + CStr(USER_NAME) + "'"
        
        '+ "' AND WORKSTATION = '" + STATION_NAME + "'"
            
    If Not ExecuteNonQuery(strSql) Then
        GetInfoChange = False
        Exit Function
    End If
    
    
    For i = 0 To TCP_STATE.dwNum_Of_Entries
        If TCP_STATE.TCP_Table(i).dwState = NETSTAT_ESTABLISHED Then
            CopyMemory Ip_Buf(1), TCP_STATE.TCP_Table(i).dwLocalAddr, 4
            strLocalIp = CStr(Ip_Buf(1)) + "." + CStr(Ip_Buf(2)) + "." + CStr(Ip_Buf(3)) + "." + CStr(Ip_Buf(4))
            
            Tmp1 = TCP_STATE.TCP_Table(i).dwLocalPort ' 本地端口
            Tmp2 = Tmp1 / 256 + (Tmp1 Mod 256) * 256
            
            strLocalPort = CStr(Tmp2)
            
            CopyMemory Ip_Buf(1), TCP_STATE.TCP_Table(i).dwRemoteAddr, 4
            strRemoteIp = CStr(Ip_Buf(1)) + "." + CStr(Ip_Buf(2)) + "." + CStr(Ip_Buf(3)) + "." + CStr(Ip_Buf(4))
            
            Tmp1 = TCP_STATE.TCP_Table(i).dwRemotePort  '远端端口
            Tmp2 = Tmp1 / 256 + (Tmp1 Mod 256) * 256
            
            strRemotePort = CStr(Tmp2)
            
            Dim STATES As String
            Dim INFOTYPE As String
            STATES = "----"
            INFOTYPE = " "
            
            If strLocalIp <> strRemoteIp Then
                'strSql = "DELETE FROM NETSNIFF WHERE DEPARTMENT ='" + CStr(DEPARTMENT_NAME) _
                '    + "' AND WORKSTATION = '" + STATION_NAME + "'"
            
                'If Not ExecuteNonQuery(strSql) Then
                '    GetNetStat = False
                '    Exit Function
                'End If
                
                INFOTYPE = "HIS-PACS"
                STATES = Now
                
                If STATION_NAME = "" Then
                    STATION_NAME = "影像工作站"
                    
                End If
            
                strSql = "INSERT INTO INFOCHANGE(ID,REMOTEIP,LOCALIP,USERNAME,CHANGETYPE,NOWDATE,SAVESTATE) " _
                    + " VALUES(HTPACS_SEQUENCE.NEXTVAL, '" + strRemoteIp + "','" + strLocalIp + "'," _
                    + "'" + CStr(USER_NAME) + "','" + CStr(INFOTYPE) + "','" + CStr(Now) + "','" + CStr(STATES) + "')"
            
                If Not ExecuteNonQuery(strSql) Then
                    GetInfoChange = False
                    Exit Function
                End If
            End If
            
        End If
        
        
    Next
    
    GetInfoChange = True
    Exit Function
ErrHandler:
    GetInfoChange = False
End Function