messengerorig.frm

vb开发的消息传递系统

            lpRemoteName As Long
            lpComment As Long
            lpProvider As Long
    End Type
        
    Const UF_SCRIPT = &H1
    Const UF_ACCOUNTDISABLE = &H2
    Const UF_HOMEDIR_REQUIRED = &H8
    Const UF_LOCKOUT = &H10
    Const UF_PASSWD_NOTREQD = &H20
    Const UF_PASSWD_CANT_CHANGE = &H40
    Const UF_TEMP_DUPLICATE_ACCOUNT = &H100
    Const UF_NORMAL_ACCOUNT = &H200
    Const UF_INTERDOMAIN_TRUST_ACCOUNT = &H800
    Const UF_WORKSTATION_TRUST_ACCOUNT = &H1000
    Const UF_SERVER_TRUST_ACCOUNT = &H2000
    Const UF_DONT_EXPIRE_PASSWD = &H10000
    Const UF_MNS_LOGON_ACCOUNT = &H20000
    
    Dim Info As NETRESOURCE         'To store the resource
    Dim Domn As Boolean             'Flag set when enumerating Domain(s)
    Dim DTyp As String              'To store the Domain Name
    Dim tUsr As String              'Name of the Current User
    Dim lUsr As Long                'Length of the User Name
    Dim X    As Long                'General storage for Return Value(s)
           
Private Function Enumerate(Info As NETRESOURCE) As Long
'This function is used Recursively to enumerate Workstations/Domains in a Network

    Dim EnumerationHandle&
    Dim res&
    Dim tbuf() As Byte
    Dim BufferSize As Long
         
    DoEvents
    'Open the Network
    res = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, Info, EnumerationHandle)
    
    If res <> 0 Then
       Exit Function
    End If
    
    ReDim tbuf(16384)
    BufferSize = 16384       'Minimum 16 KB Kaka
    
    Do
       DoEvents
       'Enumerate the Resources
       res = WNetEnumResource(EnumerationHandle, 1, tbuf(0), BufferSize)
       ' Check for errors
       Select Case res
          Case 0   ' Success
              Load agGetAddressForObject(tbuf(0))
          Case Else
             If res = ERROR_MORE_DATA Then ReDim tbuf(BufferSize + 1) Else: Exit Do
       End Select
    Loop While res = 0
    ' And close the enumeration
    res = WNetCloseEnum(EnumerationHandle)
    Enumerate = 0

End Function

Public Sub Load(ByVal bufferaddress&)
'nr stores the addresses for all the values
    Dim nr As NETRESOURCELONG   ' Temporary structure for copying
    agCopyData ByVal bufferaddress, nr, Len(nr)    ' Copy the necessary data
    LoadInfoFromNRLong nr       ' Call this function to Load Values from Pointer Addr.
End Sub

Private Sub LoadInfoFromNRLong(nr As NETRESOURCELONG)
'This function is used to Load values into strings from Pointer Addresses
    
    Info.dwScope = nr.dwScope
    Info.dwType = nr.dwType
    Info.dwDisplayType = nr.dwDisplayType
    Info.dwUsage = nr.dwUsage
    
    If nr.lpRemoteName <> 0 Then
       Info.lpRemoteName = agGetStringFromPointer(nr.lpRemoteName) & Chr$(0)
    Else
       Info.lpRemoteName = vbNullString
    End If
    
    'Determine the type of resource
    Select Case Info.dwDisplayType
         Case RESOURCEDISPLAYTYPE_DOMAIN
                 DTyp = " Domain "
                 If Domn = True Then         'If search is for Domain(s) list and exit
                     cboWorkstation.AddItem Chr(32) & Info.lpRemoteName
                 Else
                     X& = Enumerate(Info)    'Look for further computers
                 End If
         Case RESOURCEDISPLAYTYPE_GENERIC
                 DTyp = " Generic "
         Case RESOURCEDISPLAYTYPE_GROUP
                 DTyp = " Group "
         Case RESOURCEDISPLAYTYPE_SERVER
                 DTyp = " Server "
                 If Domn = False Then        'If search is for Workstations(s) list and exit
                     cboWorkstation.AddItem Trim(Mid(Info.lpRemoteName, 3, Len(Info.lpRemoteName)))
                 End If
         Case RESOURCEDISPLAYTYPE_SHARE
                 DTyp = " Share "
         Case RESOURCEDISPLAYTYPE_FILE
                 DTyp = " File "
     End Select
   
End Sub

Private Sub cboSelected_GotFocus()
'Tell user what this will do
    lblStatus = "按 DEL 键删除用户."
End Sub

Private Sub cboSelected_KeyDown(KeyCode As Integer, Shift As Integer)
'Trapping DEL key so that the user may be removed from the selected List
    If cboSelected.ListCount > 0 And cboSelected.ListIndex > -1 And KeyCode = 46 Then
        cboSelected.RemoveItem cboSelected.ListIndex
        If cboSelected.ListCount > -1 Then
            cboSelected.ListIndex = cboSelected.ListCount - 1
        End If
    End If
End Sub

Private Sub cboWorkstation_Click()
'Selects the user to the Select ComboBox when Group Check is enabled
    If cboWorkstation.ListCount > -1 And Len(Trim(cboWorkstation)) > 0 Then
        If Mid(cboWorkstation, 1, 1) = "*" Then
            chkGroup.Value = 1
            Call SessionEnum(2)
        ElseIf chkGroup.Value = 1 Then
            cboSelected.AddItem cboWorkstation
            cboSelected.ListIndex = cboSelected.ListCount - 1
        End If
    End If
End Sub

Private Sub cboWorkstation_GotFocus()
'Prompt the user to select a Name
    If Len(lblStatus) <> 0 Then lblStatus = "可以选择或者直接输入发送到达的位置."
End Sub

Private Sub cboWorkstation_KeyPress(KeyAscii As Integer)
'Add the name to the Select Combo on ENTER press
    If KeyAscii = 13 Then
        If chkGroup.Value = 1 And Len(Trim(cboWorkstation)) Then
            cboSelected.AddItem cboWorkstation
            cboSelected.ListIndex = cboSelected.ListCount - 1
        End If
    Else
        If KeyAscii = 32 Then KeyAscii = 0 Else KeyAscii = Asc(UCase(Chr(KeyAscii)))
    End If
End Sub

Private Sub chkGroup_Click()
'This is used to Display the Select Combo
    cboSelected.Clear
    cboSelected.Visible = chkGroup
End Sub

Private Sub chkGroup_GotFocus()
'Tell user what this will do
    lblStatus = "选择一个用户."
End Sub

Private Sub cmdBeep_Click()
'This code sets the Beeper On/Off
    Dim xRet&, ySet&, bSet&     'Variables for Return Status, Speaker Status, Set Variable
    ySet = Get_Beep
    If ySet = 0 Then bSet = 1 Else bSet = 0    'Set bSet to the Opposite of Set Status
    xRet = SystemParametersInfo(SPI_SETBEEP, bSet, ySet, 0&)
    If xRet <> 0 Then
        xRet = Get_Beep
    Else
        lblStatus = "不发出声音."
    End If
End Sub
    
Function Get_Beep() As Long
'This code sets the Beeper On/Off
    Dim xRet&, ySet&    'Variables for Return Status, Speaker Status
    xRet = SystemParametersInfo(SPI_GETBEEP, 0&, ySet, 0&)
    If xRet <> 0 Then
        If ySet = 0 Then
            lblStatus = "关闭声音."
            cmdBeep.BackColor = &H40C0&     'Set to Red to meaning Off
        Else
            lblStatus = "打开声音."
            cmdBeep.BackColor = &HC0C000    'Set to Green to meaning On
        End If
    Else
        cmdBeep.BackColor = &HC0C0C0        'Set Default color to the Beep Button
        lblStatus = "不检测声音状态."
    End If
    Get_Beep = ySet
End Function

Private Sub cmdBeep_GotFocus()
'Tell user this will set beeper On/Off
    lblStatus = "设置声音是否打开."
End Sub

Private Sub cmdExit_Click()
'Close Messenger, Tata
    Unload Me
End Sub
    
Private Sub cmdExit_GotFocus()
'Tell user this will khatam the Messenger
    lblStatus = "结束程序."
End Sub

Private Sub cmdSend_Click()
'This function sends Messages to Names either in Select Combo/ Default Combo

    Dim iSel As Integer
    Dim tMsg As String
    
    tMsg = txtMsg       'Store actual Message in a string
    If chkGroup.Value = 1 Then
        If cboSelected.ListCount < 1 Then
            Beep
            lblStatus = "无选择."
        Else
            Me.WindowState = vbMinimized
            Me.Caption = "正在发送，请等待 ..."
            For iSel = 0 To cboSelected.ListCount - 1
                If Len(Trim(cboSelected.List(iSel))) = 0 Or (Left(Trim(cboSelected.List(iSel)), 1) = "*") Then
                    Beep
                    lblStatus = "无法发送： " & cboSelected.List(iSel)
                Else
                    Call SendMessage(cboSelected.List(iSel), tMsg)
                End If
            Next iSel
            Me.Caption = "发送消息"
            Me.WindowState = vbNormal
        End If
    Else
        If Len(Trim(cboWorkstation)) = 0 Or (Left(Trim(cboWorkstation), 1) = "*") Then
            Beep
            lblStatus = "选择或输入用户名称."
        Else
            Call SendMessage(cboWorkstation, tMsg)
        End If
    End If
    
End Sub
    
Private Sub cmdSend_GotFocus()
'Display whether the Message is to Group or Name
    If chkGroup.Value = 1 Then
        lblStatus = "发送消息到工作组。"
    Else
        lblStatus = "发送给:  " & cboWorkstation
    End If
End Sub

Private Sub domain_Click()
'Calls Enumerate function to select Domain names from the Network

    Me.MousePointer = 11
    lblStatus = "正在查找域  ..."
    
    Me.Caption = "正在查找域 ..."
    
    cboWorkstation.Clear
    Reset_Info
    Domn = True
    DoEvents:     X& = Enumerate(Info)    'To enumerate root, necessary to enumerate the Network
    DoEvents:     X& = Enumerate(Info)    'To enumerate further
    Domn = False
    
    'Beep
    If cboWorkstation.ListCount > 0 Then lblStatus = "域被找到."
    
    Me.MousePointer = 1
    If cboWorkstation.ListCount > 0 Then cboWorkstation.ListIndex = 0
    
    'Beep
    Me.Caption = "发送消息"
    txtMsg = ""

End Sub

Private Sub exit_Click()
'This will Khatam the Messenger
    End
End Sub

Private Sub Form_Load()
'Prompts the user to enter a Message, Finds Beeper status before
    Dim nRet As Long
    nRet = SetWindowRgn(Me.hWnd, CreateFormRegion(1, 1, 0, 0), True)
    
    lblStatus = "输入要发送的消息."
    Call Get_Beep       'Finds Beeper Status
    Call Get_User       'Gets the User name and attaches it to the Message
    
End Sub

Private Function CreateFormRegion(ScaleX As Single, ScaleY As Single, OffsetX As Integer, OffsetY As Integer) As Long
    Dim Corraction As Integer
    Dim HolderRegion As Long, ObjectRegion As Long, nRet As Long, Counter As Integer
    Dim PolyPoints() As POINTAPI
    
    ResultRegion = CreateRectRgn(0, 0, 0, 0)
    HolderRegion = CreateRectRgn(0, 0, 0, 0)
    
                ObjectRegion = CreateRoundRectRgn( _
                        shpBorder.Left / Screen.TwipsPerPixelX + OffsetX, _
                        shpBorder.Top / Screen.TwipsPerPixelY + OffsetY, _
                        (shpBorder.Left + shpBorder.Width) / Screen.TwipsPerPixelX + OffsetX, _
                        (shpBorder.Top + shpBorder.Height) / Screen.TwipsPerPixelY + OffsetY, _
                        RectXRound, RectYRound)
        nRet = CombineRgn(HolderRegion, ResultRegion, ResultRegion, RGN_COPY)
        nRet = CombineRgn(ResultRegion, HolderRegion, ObjectRegion, 2)
        DeleteObject ObjectRegion
    DeleteObject ObjectRegion
    DeleteObject HolderRegion
    CreateFormRegion = ResultRegion
End Function

Private Sub Form_Unload(Cancel As Integer)
    DeleteObject ResultRegion

End Sub

Private Sub group_Click()
'Displays Group names, at present the service is not available to this list

    lblStatus = "正在查找工作组 ..."
    Me.MousePointer = 11
    
    Me.Caption = "正在查找工作组 ..."