frmsendmain.frm

类似QQ的局域网聊天软件源码.可以实现语音聊天和对话的小型软件

    dwDisplayType As Long
    dwUsage As Long
    sLocalName As String
    sRemoteName As String
    sComment As String
    sProvider As String
End Type
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As NETRESOURCE, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Function VarPtrAny Lib "vb40032.dll" Alias "VarPtr" (lpObject As Any) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Sub CopyMemByPtr Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpTo As Long, ByVal lpFrom As Long, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

Sub GetLocalInfo()
    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
    Dim uNet() As NETRESOURCE_REAL
    Dim N As Integer
    N = 1
    bFirstTime = True
    Do
        If bFirstTime Then
            lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
            bFirstTime = False
        Else
            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
                lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
                If lCount > 0 Then
                    ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE_REAL
                    For l = 0 To lCount - 1
                        'Each Resource will appear here as uNet(i)
                        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 l > 15 Then Exit Sub
            If uNet(l).dwDisplayType = 2 Then
                strGroupComputerName(N) = Right(uNet(l).sRemoteName, Len(uNet(l).sRemoteName) - 2)
                If N > 10 Then
                    N = 1
                    mnvComputer.MenuCur = mnvComputer.MenuCur + 1
                End If
                  mnvComputer.MenuItemsMax = N
                  mnvComputer.MenuItemCur = N
                  mnvComputer.MenuItemCaption = Right(uNet(l).sRemoteName, Len(uNet(l).sRemoteName) - 2)
                  mnvComputer.MenuItemKey = Right(uNet(l).sRemoteName, Len(uNet(l).sRemoteName) - 2)
                  Set mnvComputer.MenuItemIcon = ImageList1.ListImages(2).Picture
                N = N + 1
            End If
        Next l
    End If
    mnvComputer.MenuCur = 1
End Sub

Private Sub cmdInfo_Click()
    FrmLocalInfo.Show 1
End Sub

Private Sub FlatBttn1_Click()
    FrmLocalInfo.Show 1
End Sub

Private Sub FlatBttn2_Click()
    FrmCalendar.Show 1
End Sub

Private Sub FlatBttn3_Click()
    frmAbout.Show 1
End Sub

Private Sub Form_Load()
    Me.Top = 300
    Me.Left = Screen.Width - Me.Width - 300
    
    'Get the username
    strComputerName = ComputerName()
    Me.Caption = strComputerName
    Call GetLocalInfo
   
    If WindowState = vbMinimized Then
        LastState = vbNormal
    Else
        LastState = WindowState
    End If

  With myData
    .cbSize = Len(myData)
    .hwnd = Me.hwnd
    .uID = 0
    .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
    .uCallbackMessage = WM_MOUSEMOVE
    .hIcon = Me.Icon.Handle '默认为窗口图标
    .szTip = "提示" & vbNullChar
    .szTip = "通用管理咨询公司局域网消息发送器！--Author:lihonggen " & Chr(13) & "：）" & vbNullChar
  End With
  Shell_NotifyIcon NIM_ADD, myData
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Select Case CLng(X)
    Case WM_RBUTTONUP '鼠标在图标上右击时弹出菜单
        Me.PopupMenu mnuTray
    Case WM_LBUTTONUP '鼠标在图标上左击时窗口若最小化则恢复窗口位置
        If Me.WindowState = vbMinimized Then
            Me.WindowState = LastState
            SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, 0&
          '  Me.Show 1
        End If
  End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If MsgBox("你是否要退出局域网消息发送器 ？", 4 + 32 + 256, "局域网消息发送器") = vbYes Then
        Cancel = False
        Shell_NotifyIcon NIM_DELETE, myData '窗口卸载时，将状态栏中的图标一同卸载
        End
    Else
        Cancel = True
    End If
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuAbout_Click()
    frmAbout.Show 1
End Sub

Private Sub mnuAllway_Click()
    If mnuAllway.Checked Then
        Call NoSetWinPos(Me)
        mnuAllway.Checked = False
    Else
        Call SetWinPos(Me)
        mnuAllway.Checked = True
    End If
End Sub

Private Sub mnuCalendar_Click()
    FrmCalendar.Show 1
End Sub

Private Sub mnuTrayChangeIcon_Click()
    On Error GoTo ErrHandler
    With cdlOpen
      .CancelError = True ' 设置标志
      .InitDir = App.Path ' 默认的文件夹为当前文件夹
      .FLAGS = cdlOFNHideReadOnly ' 设置过滤器
      .Filter = "图标文件 (*.ico)|*.ico" ' 指定缺省的过滤器为图标文件
      .ShowOpen ' 显示选定文件的名字
    End With

    Image1.Picture = LoadPicture(cdlOpen.FileName)

    With myData
        .hIcon = Image1.Picture
        .uFlags = NIF_ICON
    End With
    Shell_NotifyIcon NIM_MODIFY, myData

ErrHandler:     ' 用户按了"取消"按钮
    Exit Sub
End Sub

Private Sub mnuTrayClose_Click()
    Unload Me
End Sub

Private Sub Form_Resize()
'    mnvComputer.Width = Me.Width - 150
'    If Me.Height - 850 > 0 Then
'       mnvComputer.Height = Me.Height - 850
'    End If
'    SSTab1.Width = Me.Width - 20
'    SSTab1.Height = Me.Height

    Select Case WindowState
        Case vbMinimized
            Me.Hide
     '     mnuTrayMaximize.Enabled = True
          mnuTrayMinimize.Enabled = False
          mnuTrayRestore.Enabled = True
        Case vbMaximized
          mnuTrayMinimize.Enabled = True
          mnuTrayRestore.Enabled = True
            SSTab1.SetFocus
        Case vbNormal
    '      mnuTrayMaximize.Enabled = True
            Me.Width = 1800
            Me.Height = 6855
          mnuTrayMinimize.Enabled = True
          mnuTrayRestore.Enabled = False
            'SSTab1.SetFocus
    End Select
    mnuTrayMaximize.Enabled = False
    If WindowState <> vbMinimized Then LastState = WindowState
End Sub

Private Sub mnuTrayMaximize_Click()
    WindowState = vbMaximized
End Sub

Private Sub mnuTrayMinimize_Click()
    WindowState = vbMinimized
End Sub

Private Sub mnuTrayRestore_Click()
    SendMessage hwnd, WM_SYSCOMMAND, SC_RESTORE, 0&
End Sub

Private Sub mnvComputer_MenuItemClick(MenuNumber As Long, MenuItem As Long)
    mnvComputer.MenuCur = MenuNumber
    mnvComputer.MenuItemCur = MenuItem
    FrmMain.Caption = mnvComputer.MenuItemCaption
    FrmMain.cboComputer.Text = mnvComputer.MenuItemCaption
    FrmMain.Show 1
End Sub

Private Sub mnvComputer_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        PopupMenu mnuTray
    End If
End Sub