messengerorig.frm

vb开发的消息传递系统

    DoEvents
    cboWorkstation.Clear
    X& = SessionEnum(3)
    Me.MousePointer = 1
    If cboWorkstation.ListCount > 0 Then
        cboWorkstation.ListIndex = 0
        txtMsg = ""
        lblStatus = "选择工作组."
    End If
    
    'Beep
    Me.Caption = "发送消息"

End Sub
 
    
Private Sub txtMsg_Change()
'Warns the user not to enter more than a specified limit of length

    If Len(txtMsg) = 0 Then
        lblStatus = "输入发送的消息."
    ElseIf Len(txtMsg) > 880 Then   'or 896 - lUsr Then
        lblStatus = "消息内容不能超过 " & 880 & " 字符." 'or 896 - lUsr & " 字符."
    Else
        If chkGroup.Value = 1 Then
            lblStatus = "发送到工作组"
        Else
            lblStatus = "发送到:  " & cboWorkstation
        End If
    End If
    
End Sub

Function This_Comp() As String
'Finds the Name of this Computer

    Dim X As Long, wkst As String * 50, Length As Long, lpgBuffer As Long, INFOW As WKSTA_INFO_100
    Length = 50
    
    'For Windows NT Platform
    'X = NetWkstaGetInfo(StrConv("", vbUnicode), ByVal 100&, lpgBuffer)
    'CopyMem INFOW, ByVal lpgBuffer, Len(INFOW)
    'temp = PointerToStringW(INFOW.COMPUTER)
    'NetApiBufferFree (lpgBuffer)
    'This_Comp = temp
    
    'For Any Platform
    X = GetComputerName(wkst, Length)
    This_Comp = wkst
    
End Function
    
Private Function PointerToStringW(lpStringW As Long) As String
'Derives a string from a Pointer

   Dim Buffer() As Byte
   Dim nLen As Long
   
   If lpStringW Then
      nLen = lstrlenW(lpStringW) * 2
      If nLen Then
         ReDim Buffer(0 To (nLen - 1)) As Byte
         CopyMem Buffer(0), ByVal lpStringW, nLen
         PointerToStringW = Buffer
      End If
   End If
   
End Function
    
Function SendMessage(Whom As String, Msg As String)
'This function actually sends Messages to the Names sent in the argument

    Dim Systms As String
    Dim Texts As String
    Dim Mlen As Long
    Dim X As Long
    
    Dim Delim As String
    Dim Start As Long
    
    Delim = "------------------------------------------------------------------------------------------------------------------------------------"
    Texts = String(1024, Chr$(0))
    
    'If Len(Msg) > (896 - lUsr) Then Msg = Mid(Msg, 1, (896 - lUsr))
    
    If Len(Msg) > 880 Then Msg = Mid(Msg, 1, 880)
    Texts = Msg & Chr(13) & Chr(10) & Chr(13) & Chr(10) & tUsr
    
    Start = InStr(Texts, Delim)
    If Start > 1 Then
        Texts = Mid(Texts, Start + Len(Delim) + 2, Len(Texts))
    End If
    
    Mlen = LenB(Texts)
    
    If Left$(Whom, 1) = " " Then
        Systms = Trim(Whom) & "*"
    Else
        Systms = Trim(Whom)
    End If
    
    lblStatus = "正在发送 ..."
    DoEvents
    X = NetMessageBufferSend(ByVal StrConv("", vbUnicode), ByVal StrConv(Systms, vbUnicode), ByVal StrConv(This_Comp, vbUnicode), ByVal StrConv(Texts, vbUnicode), Mlen)
    If X = 0 Then
        lblStatus = "发送成功."
    Else
        DoEvents
        If InStr(1, txtMsg, "------------------------------------------------------------------------------------------------------------------------------------", vbTextCompare) = 0 Then
            txtMsg = "不能发送到 : " & Whom & Chr(13) & Chr(10) & "------------------------------------------------------------------------------------------------------------------------------------" & Chr(13) & Chr(10) & txtMsg
        Else
            txtMsg = "不能发送到 : " & Whom & Chr(13) & Chr(10) & txtMsg
        End If
        lblStatus = GetLastErrorStr(X)
        If Len(lblStatus) = 0 Then lblStatus = "当前用户无效."
    End If
    
End Function

    
Function GetLastErrorStr(dwErrCode As Long) As String
'Finds the Error if the Message was not sucessful

  Static sMsgBuf As String * 257, dwLen As Long

  dwLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _
                                      Or FORMAT_MESSAGE_IGNORE_INSERTS _
                                      Or FORMAT_MESSAGE_MAX_WIDTH_MASK, ByVal 0&, _
                                      dwErrCode, LANG_USER_DEFAULT, _
                                      ByVal sMsgBuf, 256&, 0&)

  If dwLen Then GetLastErrorStr = Left$(sMsgBuf, dwLen)
  
End Function
    
Private Sub txtMsg_GotFocus()
'Displays Message to Whom

    If Len(cboWorkstation) = 0 Then Exit Sub
    If Len(txtMsg) = 0 Then
        lblStatus = "输入消息."
    Else
        If chkGroup.Value = 1 Then
            lblStatus = "发送到工作组."
        Else
            lblStatus = "发送给:  " & cboWorkstation
        End If
    End If

End Sub

Private Sub user_Click()
'Lists all the available NORMAL users from the Server

    lblStatus = "正在查找用户 ..."
    Me.MousePointer = 11
    
    Me.Caption = "正在查找用户 ..."

    DoEvents
    cboWorkstation.Clear
    X& = SessionEnum(1)
    Me.MousePointer = 1
    If cboWorkstation.ListCount > 0 Then cboWorkstation.ListIndex = 0
    
    'Beep
    Me.Caption = "发送消息"
    txtMsg = ""

End Sub
    
Private Sub workstation_Click()
'Lists all the Workstations currently switched on from the Network call Enumerate Func.

    Me.MousePointer = 11
    lblStatus = "Finding Workstation(s) Please Wait ..."
    
    Me.Caption = "Finding Workstation(s) Please Wait ..."
    
    cboWorkstation.Clear
    Reset_Info
    DoEvents:     X& = Enumerate(Info)    'To enumerate root, necessary to enumerate the Network
    DoEvents:     X& = Enumerate(Info)    'To enumerate further
    'Beep
    If cboWorkstation.ListCount > 0 Then lblStatus = "Workstation(s) Found. Enter Message."
    
    Me.MousePointer = 1
    If cboWorkstation.ListCount > 0 Then cboWorkstation.ListIndex = 0

    'Beep
    Me.Caption = "发送消息"
    txtMsg = ""
    
End Sub
    
Function SessionEnum(level As Long) As Long
'This function is used to List Users/Group as per the Menu selection
    
    Dim lpBuffer As Long
    Dim nRead As Long
    Dim nTotal As Long
    Dim nRet As Long
    Dim rHan As Long
    
    Dim i As Long
    Dim Grp As String
    Dim temp As String
    Dim Whom As String
    
    If level = 1 Then
         Dim infoU() As UM_INFO
         Whom = " User(s) "
    ElseIf level = 3 Then
         Dim infoG() As GRP_INFO
         Whom = " Group(s) "
    Else
         Dim infoGU() As G_USER
         Whom = " Group User(s) "
    End If
    
    lblStatus = "正在查找" & Whom & "请等待 ..."
    
    If level = 1 Or level = 3 Then
         nRet = NetQueryDisplayInformation(ByVal StrConv(Get_Server, vbUnicode), ByVal level, ByVal 0&, ByVal 1000&, ByVal 16384&, nRead, lpBuffer)
    Else
         Grp = Trim(Mid(cboWorkstation, 3, Len(cboWorkstation)))
         nRet = NetGroupGetUsers(ByVal StrConv(Get_Server, vbUnicode), ByVal StrConv(Grp, vbUnicode), ByVal 0&, lpBuffer, ByVal 16384&, nRead, nTotal, rHan)
         If nRet = 0 Then chkGroup.Value = 1
    End If
    
    temp = GetLastErrorStr(nRet)
    If nRet <> 0 Then
         If Len(temp) = 0 Then
             lblStatus = "Could not find" & Whom
             If nRet = 2312 Then lblStatus = "Session does not exist with that computer."
             If nRet = 2221 Then lblStatus = "User name could not be found."
             If nRet = 2351 Then lblStatus = "This computer name is invalid."
         Else
             lblStatus = temp
         End If
         Exit Function
    End If
    
    temp = ""
    If nRet = 0 And nRead > 0 Then
       If level = 1 Then
             ReDim infoU(nRead - 1) As UM_INFO
             CopyMem infoU(0), ByVal lpBuffer, nRead * Len(infoU(0))
       ElseIf level = 3 Then
             ReDim infoG(nRead - 1) As GRP_INFO
             CopyMem infoG(0), ByVal lpBuffer, nRead * Len(infoG(0))
       Else
             ReDim infoGU(nRead - 1) As G_USER
             CopyMem infoGU(0), ByVal lpBuffer, nRead * Len(infoGU(0))
       End If
       
       For i = 0 To nRead - 1
         If level = 3 Then
               temp = PointerToStringW(infoG(i).GRP_NAME)
               cboWorkstation.AddItem "*  " & UCase(Trim(temp))
         ElseIf level = 1 Then
               temp = PointerToStringW(infoU(i).C_NAME)
               If (UF_NORMAL_ACCOUNT And infoU(i).C_FLAG) Then
                     cboWorkstation.AddItem UCase(Trim(temp))
               End If
         Else
             temp = PointerToStringW(infoGU(i).U_NAME)
             cboSelected.AddItem UCase(Trim(temp))
         End If
       Next i
       lblStatus = Whom & "已经找到，请输入消息."
       If cboSelected.ListCount > 0 And level = 2 Then cboSelected.ListIndex = 0
    Else
       lblStatus = "无法找到用户."
    End If
     
    NetApiBufferFree (lpBuffer)
    
End Function
    
Function Get_Server() As String
'Gets the Server Name

    Dim z As Long
    Dim lpbyt As Long
    Dim temp As String
    
    z = NetGetDCName(ByVal StrConv("", vbUnicode), ByVal StrConv("", vbUnicode), lpbyt)
    
    If z <> 0 Then lblStatus = "错误: " & GetLastErrorStr(z)
    If z = 0 Then temp = PointerToStringW(lpbyt) Else: temp = ""
    
    NetApiBufferFree (lpbyt)

    Get_Server = temp
    
End Function
    
Function Reset_Info()
'This funtion resets the NETRESOURCE structure for a fresh Enumeration

    Info.dwDisplayType = 0
    Info.dwScope = 0
    Info.dwType = 0
    Info.dwUsage = 0
    Info.lpComment = ""
    Info.lpLocalName = ""
    Info.lpProvider = ""
    Info.lpRemoteName = ""
    
End Function

Function Get_User() As String
'This function gets the name of the Logged on User

    Dim lRet  As Long
    Dim tUser As String * 256
    Dim tLen  As Long
    
    tLen = 255
    X = GetUserName(tUser, tLen)
    
    If tLen > 0 Then
        'Set the retrieved name to the Global Name parameter
        tUsr = StrConv(tUser, vbProperCase)
        lUsr = 16   'tLen + 2
    End If

End Function