frmnotify.frm

基于VB和SQL的邮件自动处理辅助教学系统原码

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "邮件监听"
   ClientHeight    =   6060
   ClientLeft      =   45
   ClientTop       =   615
   ClientWidth     =   9510
   Icon            =   "frmNotify.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6060
   ScaleWidth      =   9510
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Visible         =   0   'False
   Begin VB.CommandButton Command1 
      Caption         =   "查看新邮件"
      Height          =   495
      Left            =   1920
      TabIndex        =   5
      Top             =   3600
      Width           =   1335
   End
   Begin MSWinsockLib.Winsock wsock 
      Left            =   240
      Top             =   1680
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.PictureBox TrayIcon 
      BorderStyle     =   0  'None
      Height          =   555
      Left            =   1260
      Picture         =   "frmNotify.frx":030A
      ScaleHeight     =   555
      ScaleWidth      =   495
      TabIndex        =   3
      Top             =   1680
      Visible         =   0   'False
      Width           =   495
   End
   Begin VB.CommandButton cmdOpenEmail 
      Caption         =   "进入邮箱"
      Height          =   435
      Left            =   3840
      TabIndex        =   1
      Top             =   3600
      Width           =   1275
   End
   Begin VB.CommandButton cmdAceptar 
      Caption         =   "退出"
      Default         =   -1  'True
      Height          =   435
      Left            =   5640
      TabIndex        =   0
      Top             =   3600
      Width           =   1275
   End
   Begin VB.Timer tmrCheck 
      Interval        =   60000
      Left            =   720
      Top             =   1680
   End
   Begin ComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   495
      Left            =   0
      TabIndex        =   6
      Top             =   5565
      Width           =   9510
      _ExtentX        =   16775
      _ExtentY        =   873
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   3
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Object.Width           =   4410
            MinWidth        =   4410
            Text            =   "邮件自动处理系统欢迎您"
            TextSave        =   "邮件自动处理系统欢迎您"
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Style           =   6
            Alignment       =   2
            AutoSize        =   1
            Object.Width           =   9710
            TextSave        =   "2006-6-1"
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel3 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            Style           =   5
            Alignment       =   2
            TextSave        =   "21:30"
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Label lblMsg 
      Alignment       =   2  'Center
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   1
      Left            =   2880
      TabIndex        =   4
      Top             =   360
      Width           =   2595
   End
   Begin VB.Image imgNewMail 
      Height          =   675
      Left            =   240
      Top             =   240
      Width           =   675
   End
   Begin VB.Label lblMsg 
      Alignment       =   2  'Center
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   840
      Index           =   0
      Left            =   2520
      TabIndex        =   2
      Top             =   1440
      Width           =   3525
   End
   Begin VB.Menu mnuOptions 
      Caption         =   " "
      Enabled         =   0   'False
      Begin VB.Menu mnuOptionsCheckNow 
         Caption         =   "Chequear ahora"
      End
      Begin VB.Menu mnuOptionsExecutemail 
         Caption         =   "Ejecutar programa mail"
      End
      Begin VB.Menu mnuOptionsSep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuOptionsConfigurar 
         Caption         =   "Configurar..."
      End
      Begin VB.Menu mnuOptionsHabilitado 
         Caption         =   "Habilitado"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuOptionsAbout 
         Caption         =   "Acerca de ..."
      End
      Begin VB.Menu mnuOptionsSep2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuOptionsCerrar 
         Caption         =   "Cerrar"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'e-checker
'Checks for incoming mail (POP3)
'starts in the system tray
'
'by Julio Daniel Moreyra
'Rawson - Chubut - Argentina
'21/07/98
'
'This program and the source code are freeware
'Feel free to use and modify it.
'Just say who made it.

Option Explicit
Dim result As Long
Dim Response As String
Dim TimeToCheck As Integer
Dim ShowAlert As Boolean

'Code taken (or stolen) from
'www.brianharper.demon.co.uk
'thanks Brian !!
'
Private Sub ShowProgramInTray()
    NI.cbSize = Len(NI) 'set the length of this structure
    NI.hwnd = TrayIcon.hwnd 'control to receive messages from
    NI.uID = 0 'uniqueID
    NI.uID = NI.uID + 1
    NI.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP 'operation flags
    NI.uCallbackMessage = WM_MOUSEMOVE 'recieve messages from mouse activities
    TrayIcon.Picture = LoadResPicture(20, vbResIcon)
    NI.hIcon = TrayIcon.Picture  'the location of the icon to display
    NI.szTip = LoadResString(Language) + Chr$(0)  'the tool tip to display
    result = Shell_NotifyIconA(NIM_ADD, NI) 'add the icon to the system tray
End Sub
'Changes icon and tip in the system tray
Private Sub ShowIconInTray(NroIcon As Integer, msg As String)
    NI.szTip = msg + Chr(0)
    TrayIcon.Picture = LoadResPicture(NroIcon, vbResIcon)
    NI.hIcon = TrayIcon.Picture
    result = Shell_NotifyIconA(NIM_MODIFY, NI) 'add the icon to the system tray
End Sub
'Modify the menus for english
'
Private Sub ChangeMenus()
    
    mnuOptionsAbout.Caption = "关于 ..."
    mnuOptionsCheckNow.Caption = "立即检查!!"
    mnuOptionsCerrar.Caption = "退出"
    mnuOptionsExecutemail.Caption = "运行邮件程序"
    mnuOptionsConfigurar.Caption = "配置..."
    mnuOptionsHabilitado.Caption = "可见"
    
End Sub
'Waits syncronically for server's answer
'
Function WaitFor(ResponseCode As String, Respuesta As String) As Boolean
    Dim start As Single, Tmr As Single
    Static nIcon As Integer
    
    If nIcon = 0 Then nIcon = 40
    start = Timer ' Not forever
    
    While Len(Response) = 0
        Tmr = Timer - start
    
        DoEvents
        
        ShowIconInTray nIcon, LoadResString(Language + 16)
        If Tmr > Val(Timeout) Then  ' Time in seconds to wait
            Exit Function
        End If
        
        Sleep 200       'wait just that
        nIcon = nIcon + 10 'change icon - spinning
        If nIcon > 70 Then nIcon = 40
          
    Wend

    Respuesta = Response
    Response = "" ' **IMPORTANT:
    WaitFor = True
End Function

'Reads program configuration
Private Sub LeerConfiguracion()
    
    pop3Host = GetSetting(App.EXEName, "Config", "Host")
    pop3User = GetSetting(App.EXEName, "Config", "User")
    pop3Passwd = GetSetting(App.EXEName, "Config", "Passwd")
    Interval = GetSetting(App.EXEName, "Config", "Interval", "15")
    EmailProgram = GetSetting(App.EXEName, "Config", "Program")
    Arguments = GetSetting(App.EXEName, "Config", "Arguments")
    Timeout = GetSetting(App.EXEName, "Config", "TimeOut", "30")
    Sound = GetSetting(App.EXEName, "Config", "Sound", "mail.wav")

    Do While pop3Host = ""
        If pop3Host = "" Then
           MsgBox LoadResString(Language + 1), vbExclamation
            frmConfigurar.Show 1
        End If
    Loop
    
End Sub
'The user saw the warning. Hide form
Private Sub cmdAceptar_Click()
    'result = SetWindowPos(frmMain.hwnd, -2, 0, 0, 0, 0, 3)
    'frmMain.Visible = False
   frmMain.Hide
End Sub
'Call e-mail program
Private Sub cmdOpenEmail_Click()
    'mnuOptionsExecutemail_Click
    'result = SetWindowPos(frmMain.hwnd, -2, 0, 0, 0, 0, 3)
    'frmMain.Visible = False
    frmMain.Hide
    Form2.Show
End Sub

Private Sub Command1_Click()
frmMain.Hide
frmMail.Show
End Sub

Private Sub Form_Load()
    
    'If the command line has a switch, then
    'use english messages
    If Command$ <> "" Then
        Language = 300
        ChangeMenus
    Else
        Language = 200
    End If
    'cmdAceptar.Caption = LoadResString(Language + 2)
    'cmdOpenEmail.Caption = LoadResString(Language + 3)
    ShowProgramInTray    'self explanatory
    App.TaskVisible = False
    LeerConfiguracion    'read program settings
    mnuOptionsCheckNow_Click 'check now
    
End Sub
'Delete the systray icon
Private Sub Form_Unload(Cancel As Integer)

    result = Shell_NotifyIconA(NIM_DELETE, NI) 'removes the icon from the tray

End Sub


'Program about
Private Sub mnuOptionsAbout_Click()
    frmAbout.Show 1
End Sub
'Program exit
Private Sub mnuOptionsCerrar_Click()
If MsgBox("您确定退出本系统吗？", vbExclamation + vbYesNo, "确认") = vbYes Then
    End
    End If
End Sub
'Configure the program
Private Sub mnuOptionsConfigurar_Click()
    frmConfigurar.Show 1
    '
    TimeToCheck = Val(Interval)
End Sub
'Go for it!!
Private Sub mnuOptionsCheckNow_Click()
    Dim Respuesta As String
    Dim cantmensajes As String
    
    On Error GoTo errsock
    wsock.RemoteHost = pop3Host
    wsock.RemotePort = POP3Port
    wsock.LocalPort = 0
    'if localport <> 0 then I must wait 4 minutes
    'for reuse the socket. A design behavior of the control
    wsock.Connect
    
    If Not WaitFor("+OK", Respuesta) Then
        MsgBox LoadResString(Language + 4), vbCritical
        ShowIconInTray 30, LoadResString(Language + 5)
        wsock.Close
        Exit Sub
    End If
    wsock.SendData "USER " & pop3User + vbCrLf
    If Not WaitFor("+OK", Respuesta) Then
        MsgBox LoadResString(Language + 6), vbCritical
        ShowIconInTray 30, LoadResString(Language + 7)
        wsock.Close
        Exit Sub
    End If
    wsock.SendData "PASS " & pop3Passwd + vbCrLf
    If Not WaitFor("+OK", Respuesta) Then
        MsgBox LoadResString(Language + 8), vbCritical
        ShowIconInTray 30, LoadResString(Language + 9)
        wsock.Close
        Exit Sub
    End If
    wsock.SendData "STAT" + vbCrLf
    If Not WaitFor("+OK", Respuesta) Then
        MsgBox LoadResString(Language + 10), vbCritical
        ShowIconInTray 30, LoadResString(Language + 11)
        wsock.Close
        Exit Sub
    End If
    cantmensajes = Mid$(Respuesta, 5, InStr(5, Respuesta, " ", vbTextCompare) - 5)
    lblMsg(0).Caption = "您有" + " " + cantmensajes + " " + "封新邮件"
    lblMsg(1).Caption = Format$(Now, "General Date")
    imgNewMail.Picture = LoadResPicture(IIf(cantmensajes > 0, 80, 90), vbResIcon)
    If Val(cantmensajes) > 0 Then
        ShowIconInTray 10, lblMsg(0).Caption
        If HasSound() Then
            PlayWarningSound Sound
        Else
            Beep
        End If
    Else
        ShowIconInTray 20, lblMsg(0).Caption
    End If
    wsock.SendData "QUIT" + vbCrLf
    wsock.Close
    TimeToCheck = Val(Interval)
    'If time expires or the user requires a check
    If ShowAlert Or cantmensajes > 0 Then
        tmrCheck.Enabled = False
        frmMain.Visible = True
        result = SetWindowPos(frmMain.hwnd, -1, 0, 0, 0, 0, 3)
        tmrCheck.Enabled = True
    End If
    ShowAlert = True
    Exit Sub
    
errsock:
    MsgBox Err.Description, vbCritical
    ShowIconInTray 30, LoadResString(Language + 14)
    wsock.Close
    Exit Sub

End Sub
'Call e-mail program
Private Sub mnuOptionsExecutemail_Click()
    Dim rc As Double
    
    On Error Resume Next
    If EmailProgram <> "" Then
        Screen.MousePointer = vbHourglass
        rc = Shell(EmailProgram + " " + Arguments, vbMaximizedFocus)
        Screen.MousePointer = vbNormal
        If rc = 0 Then
            MsgBox LoadResString(Language + 15), vbExclamation
        End If
    End If
End Sub
'Enable / disable the timer
Private Sub mnuOptionsHabilitado_Click()
    
    mnuOptionsHabilitado.Checked = Not mnuOptionsHabilitado.Checked
    tmrCheck.Enabled = mnuOptionsHabilitado.Checked
    
End Sub
'When is moment to check ?
Private Sub tmrCheck_Timer()
        
    TimeToCheck = TimeToCheck - 1
    If TimeToCheck = 0 Then
        ShowAlert = False
        mnuOptionsCheckNow_Click
    End If
    
End Sub
'Captura de los mensajes del mouse
Private Sub Trayicon_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim msg As Long
    msg = (x And &HFF) * &H100

    Select Case msg
        Case 0 'mouse moves
        
        Case &HF00  'left mouse button down
        
        Case &H1E00 'left mouse button up
        
        Case &H3C00  'right mouse button down
        PopupMenu mnuOptions 'show the popoup menu
        Case &H2D00 'left mouse button double click
        mnuOptionsCheckNow_Click
        Case &H4B00 'right mouse button up
        
        Case &H5A00 'right mouse button double click
        
    End Select
   
End Sub


Private Sub wsock_DataArrival(ByVal bytesTotal As Long)
    
    wsock.GetData Response
    
End Sub