frmnetsend.frm

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

    '强制清理可能是上次用过的临时文件
    DeleteFile slogPath
    DeleteFile sExecFile
    
    
    cmdSend.Enabled = False '是发送按钮失效
    CmdClr.Enabled = False  '是清除按钮失效

    dBar1.Visible = False   '隐藏进度条
    isSending = False       '标实是否正在发送消息 >>>>>>>>>>>>>
    isSetting = False


    
    
    '配置选项，读取注册表
    MyPath = App.path & "\" & App.EXEName & ".EXE"
    RunKeyPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\XingerNetSend"
    isRecPath = "HKEY_LOCAL_MACHINE\SOFTWARE\XingerNetSend\isRecChat"
    isWinMinPath = "HKEY_LOCAL_MACHINE\SOFTWARE\XingerNetSend\isMinAfterSendSuss"
    isShowInTaskbarPath = "HKEY_LOCAL_MACHINE\SOFTWARE\XingerNetSend\isShowInTaskbar"
    isOntopPath = "HKEY_LOCAL_MACHINE\SOFTWARE\XingerNetSend\isAlwaysOnTop"
    isAutoResizePath = "HKEY_LOCAL_MACHINE\SOFTWARE\XingerNetSend\isAutoResize"
    LastSendToPath = "HKEY_LOCAL_MACHINE\SOFTWARE\XingerNetSend\LastSendTo"

    Dim Runkey As String
    Dim isMinAfterSendSuss As String

    '是否跟随 windows 启动
    Runkey = Reg_Read(RunKeyPath)
    If Runkey = MyPath Then
            isStartWithWin.Value = 1
    Else
            isStartWithWin.Value = 0
    End If

    '是否保存当前消息内容
    isRecChatToFile = Reg_Read(isRecPath)
    If isRecChatToFile = "1" Then
            isRecCheck.Value = 1
            isRec = True
    Else
            isRecCheck.Value = 0
            isRec = False
    End If

    '设置是否消息发送成功后最小化窗口
    isMinAfterSendSuss = Reg_Read(isWinMinPath)
    If isMinAfterSendSuss = "1" Then
            isMin.Value = 1
            isWinMin = True
    Else
            isMin.Value = 0
            isWinMin = False
    End If

    '是否在任务栏上显示
      isShowInTaskbar = Reg_Read(isShowInTaskbarPath)
    If isShowInTaskbar = "1" Then
            isShow.Value = 1
            lStyle = lStyle Or WS_EX_APPWINDOW      '是窗口在任务栏上可见
    Else
            isShow.Value = 0
            lStyle = lStyle And (Not WS_EX_APPWINDOW)       '使窗口在任务栏上不可见
    End If
    lResult = SetWindowLong(Me.hwnd, GWL_EXSTYLE, lStyle)   '设置窗口是否在任务栏显示

    'lStyle = GetWindowLong(YOURFORM.hwnd, GWL_EXSTYLE)     '获得任务栏当前状况
    'lStyle = lStyle Or WS_EX_APPWINDOW      ' 如果 ShowInTaskbar=False，用这句使窗口在Taskbar可见
    'lStyle = lStyle and (not WS_EX_APPWINDOW)      ' 如果 ShowInTaskbar=True， 用这句使窗口在Taskbar不可见
    ' 需要强调一点，你只能在Form_Load中使用这个方法，一旦窗口显示出来之后就没有办法了
   
    '设置是否为总在最上
    isOnTop = Reg_Read(isOntopPath)
    If isOnTop = "1" Then
            OnTop.Value = 1
            frmOnTop Me, True
            isSetFrmOnTop = True
    Else
            OnTop.Value = 0
            frmOnTop Me, False
            isSetFrmOnTop = False
    End If

    '是否允许窗口自动伸缩
    isAutoResizeValue = Reg_Read(isAutoResizePath)
    If isAutoResizeValue = "1" Then
            isAutoResizeCheck.Value = 1
            isAutoResize = True
    Else
            isAutoResizeCheck.Value = 0
            isAutoResize = False
    End If

    '最后一个发送给
    LastSendTo = Reg_Read(LastSendToPath)
    Call LoadUserList       '调入用户列表


    '开启窗体相吸的效果
    DockingStart Me, True
        
       

End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)   '卸载窗体
    Dim MyExit As String

    If isSending Then
        MyExit = MsgBox("系统正在发送消息，真的要退出吗？", vbOKCancel + vbQuestion, "Net Send")
        If MyExit = vbOK Then
            End
        Else
            Cancel = 1
            UnloadMode = 1
        End If
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)

    Set frmnetSend = Nothing
    DockingTerminate Me     '关闭窗体相吸的效果

End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim isTopZeroAndMouseInForm As Boolean  '窗体是否 top=0，并且鼠标是否在 form 上
    isTopZeroAndMouseInForm = False
    Dim isWinGoingUp As Boolean     '是否是窗体正在向上缩进屏幕
    Dim isWinGoingDown As Boolean   '是否是窗体正在向下伸出屏幕

    'lblResponse.Caption = "x=" & X & " y=" & Y & " top=" & frmnetSend.Top

    If isAutoResize And (Not isSending) And (Not isTitleDblClickMin) Then   '用户允许窗体自动伸缩，
                                                                            '并且不是在发送消息的时候
                                                                            '窗口不是因为被双击标题栏而最小化了
    With frmnetSend
        .Width = FrmWidth
        Dim isFormArea As Boolean       '鼠标是否在 form 上

        DoEvents

        '是否在 form 上的判断条件
        isFormArea = (X < .ScaleWidth - 50) And (Y < .ScaleHeight - 50) And (X > 0 And Y > -50)  '鼠标在 form 上

        If isFormArea Then    '鼠标在 form 上
            DoEvents
            While (.Top < 0) And (Not isWinGoingUp) '窗体正在伸出屏幕
                    DoEvents
                    .Top = .Top + 1
                    isTopZeroAndMouseInForm = True
                    isWinGoingDown = True
            Wend
            isWinGoingDown = False
            If isTopZeroAndMouseInForm Then
                    If .Top <> 0 Then
                            .Top = 0
                    End If
                    isTopZeroAndMouseInForm = False
            End If
            If isSetting Then       '正在配置中
                    SettingFrame.Visible = True
            Else
                    MainFrame.Visible = True
            End If
        Else            '鼠标不在 form 上
            DoEvents
            If .Top = 0 And Not isSetting Then      '禁止设置时窗体收缩
                While (.Top > -.ScaleHeight) And (Not isWinGoingDown)   '窗体正在缩进屏幕
                        DoEvents
                        .Top = .Top - 1
                        isWinGoingUp = True
                Wend
                isWinGoingUp = False
                If .Top <> -.ScaleHeight + 60 Then
                        .Top = -.ScaleHeight + 60
                End If
                MainFrame.Visible = False
                SettingFrame.Visible = False
            ElseIf isSetting Then       '正在配置中，下面的代码主要是自动缩放窗体大小
                If .Height <> FrmSettingHeight Then
                        .Height = FrmSettingHeight
                End If
                SettingFrame.Visible = True
            Else
                If .Height <> FrmHeight Then
                        .Height = FrmHeight
                End If
                MainFrame.Visible = True
            End If
        End If
    End With
    End If
End Sub



Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        DoDrag Me

End Sub


Private Sub TitleName_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    DoDrag Me

End Sub

Private Sub TitleName_DblClick()
    Dim FrmHeightNormal As Long
    
    If isSetting Then
        FrmHeightNormal = FrmSettingHeight
    Else
        FrmHeightNormal = FrmHeight
    End If

    If Me.Height <> 360 Then
        Me.Height = 360
        UnfoldButton.Visible = True     '显示折叠按钮
        isTitleDblClickMin = True
    Else
        Me.Height = FrmHeightNormal
        UnfoldButton.Visible = False    '隐藏折叠按钮
        isTitleDblClickMin = False
    End If

End Sub


Private Sub EndButton_Click()
    Dim MyExit As String

    If isSending Then
        MyExit = MsgBox("系统正在发送消息，真的要退出吗？", vbOKCancel + vbQuestion, "Net Send")
        If MyExit = vbOK Then
            End
        End If
    Else
        Unload Me
    End If
End Sub

'窗体折叠按钮
Private Sub FoldButton_Click()
    Call TitleName_DblClick
End Sub

'窗体展开按钮
Private Sub UnfoldButton_Click()
    Call TitleName_DblClick
End Sub


Private Sub MinButton_Click()
    frmnetSend.WindowState = vbMinimized
End Sub

'检测存放程序的路径是否合法
Private Function isValidPath(path As String) As Boolean
        Dim str As String
        Dim c As String
        Dim i As Long
        
        str = " ()%^&"
        For i = 1 To Len(path)
                c = Mid(path, i, 1)
                If InStr(str, c) <> 0 Then
                        isValidPath = False
                        Exit Function
                End If
        Next
        isValidPath = True
End Function


'调入用户列表
'------------------------------------------------------------
Private Sub LoadUserList()

        Dim iFile As Integer
        Dim tUser As String
        Dim stUser As String ' Current value
        Dim isExistLastSendTo As Boolean        '用户列表文件中是否存在上次最后一个发送给用户，
                                                '主要是防止这个用户可能被用户在编辑发送用户列表时被删除

        isExistLastSendTo = False
        stUser = txtUser.Text
        txtUser.Clear
    
        If Len(Dir(sfPath)) <> 0 Then
                iFile = FreeFile
                Open sfPath For Input As iFile
                        Do While Not EOF(iFile)
                                Input #iFile, tUser
                                txtUser.AddItem tUser
                                txtUser.Text = tUser  ' Will be the last person sent to!!
                                If tUser = LastSendTo Then      '判断上次最后发送给是否存在于文件中
                                        isExistLastSendTo = True
                                End If
                        Loop
                Close iFile
        End If

        'Form OnLoad 时，初始化发送用户列表
        If isExistLastSendTo Then
                If LastSendTo <> "" Then
                        txtUser.Text = LastSendTo
                End If
        End If

        'stUser 是本次发送的用户名，由于可能要添加新的用户……
        If stUser <> "" Then
                txtUser.Text = stUser
        End If
    
End Sub





'超链接
'------------------------------------------------------------
Private Sub HttpLink_Click()
        Dim conSwNormal As Long
        ShellExecute hwnd, "open", "http://www.XingWorld.net", vbNullString, vbNullString, conSwNormal
End Sub


'查看/编辑用户列表
Private Sub users_Click()
        ShellExecute Me.hwnd, "open", "notepad.exe", App.path & "\sent.dat", "", 1
End Sub

Private Sub SendMsgs_Click()
        ShellExecute Me.hwnd, "open", "notepad.exe", ChatFile, "", 1
End Sub

Private Sub Xinger_Click()
        Dim conSwNormal As Long
        ShellExecute hwnd, "open", "http://home.XingWorld.net/xing", vbNullString, vbNullString, conSwNormal
End Sub



Private Sub txtMSGID_KeyPress(KeyAscii As Integer)
        iSenseKeyPress txtMSGID, KeyAscii
End Sub


'检测消息内容的改变：空，非空
'------------------------------------------------------------
Private Sub txtMSGID_Change()

        lblResponse.Caption = ""
        iSenseChange txtMSGID   '智能填写

        If txtMSGID.Text <> "" And txtUser.Text <> "" Then
                cmdSend.Enabled = True
                CmdClr.Enabled = True
                cmdSend.Default = True
        Else
                cmdSend.Enabled = False
                CmdClr.Enabled = False
                cmdSend.Default = False
        End If

End Sub

'检测是否有用户/IP 输入

Private Sub txtUser_Change()
        If txtMSGID.Text <> "" And txtUser.Text <> "" Then
                cmdSend.Enabled = True
                CmdClr.Enabled = True
                cmdSend.Default = True
        Else
                cmdSend.Enabled = False
                CmdClr.Enabled = False
                cmdSend.Default = False
        End If
End Sub