frmac_qq.frm

办公自动化系统--vb+access

Private Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&

'  存放主机信息的结构
Private Type HOSTENT
    hName      As Long    '  主机的正式名称
    hAliases   As Long    '  主机别名列表
    hAddrType  As Integer '  主机地址类型
    hLen       As Integer '  主机地址长度
    hAddrList  As Long    '  主机IP地址列表
End Type

'  存放Winsock版本等信息的结构
Private 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

'  初始化Socket
Private Function SocketsInitialize(Optional sErr As String) As Boolean
    Dim WSAD As WSADATA
    Dim sLoByte As String
    Dim sHiByte As String
    
    '  初始化Winsock DLL，并判断版本是否满足要求
    If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
        sErr = "The 32-bit Windows Socket is not responding."
        SocketsInitialize = False
        Exit Function
    End If
    
    '  判断是否有支持足够的Socket
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        sErr = "This application requires a minimum of " & _
                CStr(MIN_SOCKETS_REQD) & " supported sockets."
        SocketsInitialize = False
        Exit Function
    End If
    
    '  判断Winsock的版本是否被32为Winsock支持
    If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
            (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
            HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then

        sHiByte = CStr(HiByte(WSAD.wVersion))
        sLoByte = CStr(LoByte(WSAD.wVersion))

        sErr = "Sockets version " & sLoByte & "." & sHiByte & _
                " is not supported by 32-bit Windows Sockets."

        SocketsInitialize = False
        Exit Function
    End If
    
    SocketsInitialize = True
End Function

' 释放Socket库所占用的系统资源
Private Sub SocketsCleanup()
    If WSACleanup() <> ERROR_SUCCESS Then
        App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
    End If
End Sub

'  获得一个整数的高字节位
Private Function HiByte(ByVal wParam As Integer)
    HiByte = wParam \ &H1 And &HFF&
End Function

'  获得一个整数的低字节位
Private Function LoByte(ByVal wParam As Integer)
    LoByte = wParam And &HFF&
End Function

'   用于获得网上邻居计算机名称的子程序
Sub GetNeighbor()
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1

Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF
Dim uNet() As NETRESOURCE

bFirstTime = True

Do
    If bFirstTime Then
        '  启动对顶级网络资源进行枚举的过程,并返回枚举资源所用的句柄
        lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
        bFirstTime = False
    Else
        '  如果uNet(lLastIndex)资源包含了可以枚举的额外资源,并返回枚举资源所用的句柄
        If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
            '  启动对包含于指定资源内的资源的枚举
            lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
        Else '否则
            lReturn = NOT_A_CONTAINER
            hEnum = 0
        End If
        '  下一个资源
        lLastIndex = lLastIndex + 1
    End If
    
    If lReturn = NO_ERROR Then  '如果返回值表示成功
        lCount = RESOURCE_ENUM_ALL
        Do
            '  设置缓冲区大小
            lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
            '  应用上面WNetOpenEnum返回的句柄枚举网络资源,并将枚举信息装载到uNetApi缓冲区
            lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
            If lCount > 0 Then
                '  为动态数组变量重新分配存储空间
                ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE
                For l = 0 To lCount - 1
                    '将枚举信息赋值给 uNet
                    uNet(lMin + l).dwScope = uNetApi(l).dwScope
                    uNet(lMin + l).dwType = uNetApi(l).dwType
                    uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
                    uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
                    
                    '  对于以下的值通过内存复制的方式赋值
                    If uNetApi(l).pLocalName Then
                        lLength = lstrlen(uNetApi(l).pLocalName)
                        uNet(lMin + l).sLocalName = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
                    End If
                    
                    If uNetApi(l).pRemoteName Then
                        lLength = lstrlen(uNetApi(l).pRemoteName)
                        uNet(lMin + l).sRemoteName = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
                    End If
                    
                    If uNetApi(l).pComment Then
                        lLength = lstrlen(uNetApi(l).pComment)
                        uNet(lMin + l).sComment = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength
                    End If
                    
                    If uNetApi(l).pProvider Then
                        lLength = lstrlen(uNetApi(l).pProvider)
                        uNet(lMin + l).sProvider = Space$(lLength)
                        CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength
                    End If
                Next l
            End If
            lMin = lMin + lCount
        Loop While lReturn = ERROR_MORE_DATA
    End If
    
    If hEnum Then
    '  结束枚举操作
    l = WNetCloseEnum(hEnum)
    End If
Loop While lLastIndex < lMin

If UBound(uNet) > 0 Then
    For l = 0 To UBound(uNet)
       '  判断资源类型,并将网上邻居显示出来
       If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then
            List1.AddItem uNet(l).sRemoteName
       End If
    Next l
End If
End Sub

Private Sub cmdClear_Click()
  txtMemo.Text = ""
End Sub

Private Sub cmdSend_Click()
     Dim ToName() As Byte
     Dim FromName() As Byte
     Dim Msg() As Byte
     
     ToName = Trim(TxtCmpName.Text) & vbNullChar
     FromName = Trim(txtFromName.Text) & vbNullChar
     Msg = txtMemo.Text & vbNullChar
     NetMessageBufferSend ByVal 0&, ToName(0), FromName(0), Msg(0), UBound(Msg)
End Sub


Private Sub Form_Load()
  GetNeighbor
  txtFromName.Text = Mid(frm_mainBefore.StatusBar1.Panels(1).Text, 6, Len(frm_mainBefore.StatusBar1.Panels(1).Text) - 5)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   ReleaseCapture
   SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub

Private Sub labExit_Click()
  Unload Me
End Sub

Private Sub List1_Click()
  TxtCmpName = Mid(List1.List(List1.ListIndex), 3, Len(List1.List(List1.ListIndex)))
End Sub