module1.bas

电子书“Visual Basic 6 网络编程实例教程.rar”

Attribute VB_Name = "Module1"
Option Explicit

'在LMMSG.H中声明的常量
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_BAD_NETPATH As Long = 53
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_NOT_SUPPORTED As Long = 50
Private Const ERROR_INVALID_NAME As Long = 123
Private Const NERR_BASE As Long = 2100
Private Const NERR_Success As Long = 0                     '成功调用
Private Const NERR_NetworkError As Long = (NERR_BASE + 36) '发生了网络错误
Private Const NERR_NameNotFound As Long = (NERR_BASE + 173) '网络中不能找到消息别名
Private Const NERR_UseNotFound As Long = (NERR_BASE + 150) '未发现网络连接

Public Const MAX_COMPUTERNAME As Long = 15
Public Const VER_PLATFORM_WIN32s As Long = 0
Public Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
Public Const VER_PLATFORM_WIN32_NT As Long = 2

Public Type OSVERSIONINFO
  OSVSize         As Long         '本结构的字节长度，
  dwVerMajor      As Long         '操作系统主版本号
  dwVerMinor      As Long         '操作系统次版本号
  dwBuildNumber   As Long         'NT: 操作系统的建立序号；
                                  'Win9x: 低位字表示操作系统的建立序号，
                                  '       高位字节表示操作系统的主版本号和次版本号
  PlatformID      As Long         '操作系统的平台标志
  szCSDVersion    As String * 128 'NT: 诸如"Service Pack 3"的字符串；
                                  'Win9x: 表示额额外信息的字符串
End Type

'用户为发送数据所定义的数据类型
Public Type NetMessageData
   sServerName As String
   sSendTo As String
   sSendFrom As String
   sMessage As String
End Type

'NetMessageBufferSend的参数:
'servername:  该字符串指定了执行本函数的远程机器名。空指针或空字符串表示在本地机上执行函数。
'
'msgname:     指定了消息缓存应被发送到的已注册的消息别名
'
'fromname:    指定了要发送的消息的名称。
'
'msgbuf:      要发送的消息的内容
'
'msgbuflen:   消息的内容的字节长度
Private Declare Function NetMessageBufferSend Lib "netapi32" _
  (ByVal servername As String, _
   ByVal msgname As String, _
   ByVal fromname As String, _
   ByVal msgbuf As String, _
   ByRef msgbuflen As Long) As Long

Public Declare Function GetComputerName Lib "kernel32" _
   Alias "GetComputerNameA" _
  (ByVal lpBuffer As String, _
   nSize As Long) As Long

Public Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long


Public Function IsWinNT() As Boolean

  '如果系统是WinNT/Win2000，则返回True
   #If Win32 Then
      Dim OSV As OSVERSIONINFO
      OSV.OSVSize = Len(OSV)
      If GetVersionEx(OSV) = 1 Then
         IsWinNT = (OSV.PlatformID = VER_PLATFORM_WIN32_NT)
      End If
   #End If
End Function

Public Function NetSendMessage(MSgData As NetMessageData) As String
   Dim success As Long
  '由于NetMessageBufferSend不能在Win9x上运行，所以需确保系统为NT
   If IsWinNT() Then
     '如果目的地名称为空，则返回错误并退出函数
      If MSgData.sSendTo = "" Then
            NetSendMessage = GetNetSendMessageStatus(ERROR_INVALID_PARAMETER)
            Exit Function
      Else
         If Len(MSgData.sMessage) Then
           '将字符串转换为unicode字符串
            MSgData.sSendTo = StrConv(MSgData.sSendTo, vbUnicode)
            MSgData.sMessage = StrConv(MSgData.sMessage, vbUnicode)
           '注意：如果用vbNullString作为SendFrom和sServerName的值，
           '来调用API函数，则它将在发送消息的机器上弹出“信使服务”对话框
            If Len(MSgData.sServerName) > 0 Then
                  MSgData.sServerName = StrConv(MSgData.sServerName, vbUnicode)
            Else: MSgData.sServerName = vbNullString
            End If
            If Len(MSgData.sSendFrom) > 0 Then
                  MSgData.sSendFrom = StrConv(MSgData.sSendFrom, vbUnicode)
            Else: MSgData.sSendFrom = vbNullString
            End If
            
          '改变鼠标光标图形
           Screen.MousePointer = vbHourglass
           success = NetMessageBufferSend(MSgData.sServerName, _
                                          MSgData.sSendTo, _
                                          MSgData.sSendFrom, _
                                          MSgData.sMessage, _
                                          ByVal Len(MSgData.sMessage))
           Screen.MousePointer = vbNormal
           NetSendMessage = GetNetSendMessageStatus(success)
         End If 'If Len(MSgData.sMessage)
      End If  'If MSgData.sSendTo
   End If  'If IsWinNT
End Function

Private Function GetNetSendMessageStatus(nError As Long) As String
   Dim msg As String
   Select Case nError
     Case NERR_Success:            msg = "消息已成功发送"
     Case NERR_NameNotFound:       msg = "目的地：用户或工作站未找到"
     Case NERR_NetworkError:       msg = "网络错误"
     Case NERR_UseNotFound:        msg = "未发现网络连接"
     Case ERROR_ACCESS_DENIED:     msg = "拒绝访问该计算机"
     Case ERROR_BAD_NETPATH:       msg = "发送源：未找到服务器"
     Case ERROR_INVALID_PARAMETER: msg = "使用了无效的参数"
     Case ERROR_NOT_SUPPORTED:     msg = "不支持的网络请求"
     Case ERROR_INVALID_NAME:      msg = "有非法字符"
     Case Else:                    msg = "未知错误"
   End Select
   GetNetSendMessageStatus = msg
End Function