frmnetsend.frm

vb做的数据库 客户管理系统

    
    isSending = True
    
        MousePointer = vbHourglass
    
            cmdSend.Visible = False
            CmdClr.Visible = False
            Setting.Visible = False
    
            dBar1.Visible = True
            dBar1.Style = Monic
            dBar1.BeginDisplay
    
            Call RunBatch           '开始发送
            Call SentList(txtUser.Text)
            Call LoadUserList
    
            dBar1.EndDisplay
            dBar1.Visible = False
    
            cmdSend.Visible = True
            CmdClr.Visible = True
            Setting.Visible = True
    
            ZOrder
            Me.SetFocus
            txtMSGID.SetFocus
    
        MousePointer = vbDefault
    
    isSending = False

End Sub




'清除按钮
'------------------------------------------------------------
Private Sub CmdClr_Click()
    txtMSGID.Text = ""
    lblResponse.Caption = ""
    cmdSend.Enabled = False
    CmdClr.Enabled = False
    txtMSGID.SetFocus
    cmdSend.Default = False
End Sub

Private Sub dBar1_Click()

End Sub

Private Sub GetIpButton_Click()
    frmGetIP.Show
End Sub



'关于按钮
'------------------------------------------------------------
Private Sub Setting_Click()
    isSetting = True
    cmdSend.Visible = False
    CmdClr.Visible = False

    frmnetSend.Height = FrmSettingHeight
    SettingFrame.Top = 480
    SettingFrame.Visible = True
    BgBottom.Top = 2280
    back.Visible = True

End Sub


Private Sub back_Click()
    isSetting = False
    cmdSend.Visible = True
    CmdClr.Visible = True

    frmnetSend.Height = FrmHeight
    SettingFrame.Visible = False
    BgBottom.Top = 5000
    back.Visible = False
End Sub
Private Sub RunBatch()
    
      Dim t$
      Dim iFile As Integer
      Dim msgs As String
      Dim ToUser As String
  
      On Error GoTo RunBatch_ERROR

      'First write the Execution Program
      'See you need to write it to a batch file cos VB won't send the Pipe to a file
      'To see if it has been successful!!

      ToUser = Trim(txtUser.Text)
      msgs = txtMSGID.Text
      msgs = Replace(msgs, """", "｀")  '查找替换字符串
      msgs = Replace(msgs, "(", "〔")
      msgs = Replace(msgs, ")", "〕")
      msgs = Replace(msgs, "%", "％")
      msgs = Replace(msgs, "^", "⌒")
      msgs = Replace(msgs, "/", "／")


      txtUser.Enabled = False
      txtMSGID.Enabled = False
              
            iFile = FreeFile
            Open sExecFile For Output As iFile
                t$ = "net send " & ToUser & " " & Chr$(34) & msgs & Chr$(34) & " >" & slogPath
                Print #iFile, t$
            Close iFile


            '保存最后一位发送给到注册表，以便下次使用
            Reg_Write LastSendToPath, ToUser, ""

            lblResponse.Caption = "发送中..."
            'Now Shell the Program
            Shell sExecFile, vbHide

            Do While Len(Dir(slogPath)) = 0
                DoEvents ' This loop is so we can varify the message has been sent
            Loop

            Do While lblResponse.Caption = "发送中..."
                Call CheckSuccess
                DoEvents
            Loop

            '保存发送记录到本地文件
            If isRec = True Then
                Dim strIsSuccessSend As String
                Dim LblResponseCaptionTmp As String
                Dim SendMsg As String

                LblResponseCaptionTmp = lblResponse.Caption     '保存发送后的状态到临时变量

                If LblResponseCaptionTmp = "消息成功发送。" Then
                        strIsSuccessSend = " >>>>>>>>> ● 发送成功"
                Else
                        strIsSuccessSend = " >>>>>>>>> ○ 未能发送"
                End If

                lblResponse.Caption = "保存当前消息内容..."
                Open ChatFile For Append As iFile
                    SendMsg = Now() & " From [" & MyComputerName & "] To [" & UCase(ToUser) & "]" & strIsSuccessSend & vbCrLf & msgs & vbCrLf
                    Print #iFile, SendMsg
                Close iFile

                lblResponse.Caption = LblResponseCaptionTmp
            End If
                            
      txtUser.Enabled = True
      txtMSGID.Enabled = True

      
      '将刚刚发送的消息选中，反白
      Call txtMSGID_Gotfocus


        Kill slogPath
        Kill sExecFile
        Exit Sub


RunBatch_ERROR:

    Select Case Err.Number
        Case 70 ' Permission denied Probably doing somting!!
                DoEvents: DoEvents
                Resume
        Case 53 'File not found
                Resume Next
        Case Else
                MsgBox Err.Description
    End Select

    If Err.Number <> 0 Then
        Err.Clear
    End If

    '退出整个程序
    End


End Sub
'是否在消息发送成功后，窗体自动最小化
Private Sub isMin_Click()
    If isMin.Value = 1 Then
        Reg_Write isWinMinPath, "1", ""
        isWinMin = True
    Else
        Reg_Write isWinMinPath, "0", ""
        isWinMin = False
    End If
End Sub


'是否记录当前消息内容
Private Sub isRecCheck_Click()
    If isRecCheck.Value = 1 Then
        Reg_Write isRecPath, "1", ""
        isRec = True
    Else
        Reg_Write isRecPath, "0", ""
        isRec = False
    End If
End Sub

'是否在任务栏上显示
Private Sub isShow_Click()

    If isShow.Value = 1 Then
        Reg_Write isShowInTaskbarPath, "1", ""
    Else
        Reg_Write isShowInTaskbarPath, "0", ""
    End If

End Sub

'是否开机启动
Private Sub isStartWithWin_Click()
    If isStartWithWin.Value = 1 Then
        Reg_Write RunKeyPath, MyPath, ""
    Else
        Reg_Del (RunKeyPath)
    End If
End Sub



Private Sub OnTop_Click()
    If OnTop.Value = 1 Then
        Reg_Write isOntopPath, "1", ""
        frmOnTop Me, True
        isSetFrmOnTop = True
    Else
        Reg_Write isOntopPath, "0", ""
        frmOnTop Me, False
        isSetFrmOnTop = False
    End If
End Sub


Private Sub isAutoResizeCheck_Click()
    If isAutoResizeCheck.Value = 1 Then
        Reg_Write isAutoResizePath, "1", ""
        isAutoResize = True
    Else
        Reg_Write isAutoResizePath, "1", ""
        isAutoResize = False
    End If
End Sub

'查看消息记录
Private Sub EditChat_Click()
    ShellExecute Me.hwnd, "open", "notepad.exe", ChatFile, "", 1
End Sub

'将刚刚发送的消息选中，反白
'------------------------------------------------------------
Private Sub txtMSGID_Gotfocus()
    txtMSGID.SelStart = 0
    txtMSGID.SelLength = Len(txtMSGID.Text)
End Sub
'测试是否发送成功
'------------------------------------------------------------
Private Sub CheckSuccess()
    Dim t$
    Dim iFile As Integer

    iFile = FreeFile
    Open slogPath For Input As iFile
        Do While Not EOF(iFile)
            DoEvents
            Line Input #iFile, t$
            t$ = LCase(Trim(t$))
            If t$ <> "" Then
                If InStr(t$, "success") <> 0 Or InStr(t$, "已经送到") <> 0 Then
                    isSuccessSend = True
                    lblResponse.Caption = "消息成功发送。"
                    If isWinMin Then
                        frmnetSend.WindowState = vbMinimized    '消息发送成功后，窗体最小化
                                'vbNormal 0 (Default) Normal.
                                'vbMinimized 1 Minimized (minimized to an icon)    最小化
                                'vbMaximized 2 Maximized (enlarged to maximum size)最大化
                    End If
                Else
                    isSuccessSend = False
                    lblResponse.Caption = "对不起，消息未能成功发送。"
                    If Me.WindowState = vbMinimized Then    '如果窗口是最小化的
                        frmnetSend.WindowState = vbNormal       '窗口正常化显示
                    End If
                End If
            End If
            DoEvents
        If isSuccessSend Then

        Else

        End If

        Loop
    Close iFile
End Sub




Private Sub SentList(sUser)

    Dim iFile As Integer
    Dim tUser As String
    Dim SaveUser As Boolean


    SaveUser = True
    If Len(Dir(sfPath)) <> 0 Then
        iFile = FreeFile
        Open sfPath For Input As iFile
            Do While Not EOF(iFile)
                Input #iFile, tUser
                If tUser = sUser Then
                    SaveUser = False
                    Exit Do
                End If
            Loop
        Close iFile
    End If

    If SaveUser Then
        iFile = FreeFile
        Open sfPath For Append As iFile

        Print #iFile, sUser

        Close iFile
    End If

End Sub
'获取 Windows 目录
Function WindowsDirectory() As String
    Dim buffer As String * 512
    Dim length As Long
    length = GetWindowsDirectory(buffer, Len(buffer))
    WindowsDirectory = Left$(buffer, length)
End Function
Private Sub Form_Load()

    '初始化 frmNetSend
    '--------------------------------------------------
    Dim my As Long

    FrmHeight = 3125
    FrmSettingHeight = 3860
    FrmWidth = 4215

    Me.Height = FrmHeight
    Me.Width = FrmWidth

    isSuccessSend = False           '消息是否被成功发送，初始化为假
    isTitleDblClickMin = False      '窗体是否是因为被双击标题栏而最小化了
    dBar1.Top = 2280        '进度条的距离顶部的高度
    
    
    myVer.dwOSVersionInfoSize = VER_INFO_SIZE
    my& = GetVersionEx&(myVer)
    
    MyComputerVer = myVer.dwPlatformId
 
    '获取计算机名
    MyComputerName = sGetComputerName
    If MyComputerName <> "" Then
            frmnetSend.Caption = "Net Send - From " & MyComputerName
    End If




    '获得 Windows 目录
    WinDir = WindowsDirectory()

    sfPath = App.path & "\sent.dat"         '用户名列表文件
    ChatFile = App.path & "\chat.txt"       '消息记录
    slogPath = WinDir & "\fnnetmsg.log"
    sExecFile = WinDir & "\send.bat"