frmnotify.frm

使用Winsock控制检测是否有邮件邮件服务器必须支持POP3

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "E-mail checker"
   ClientHeight    =   2355
   ClientLeft      =   45
   ClientTop       =   615
   ClientWidth     =   4665
   Icon            =   "frmNotify.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2355
   ScaleWidth      =   4665
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Visible         =   0   'False
   Begin MSWinsockLib.Winsock wsock 
      Left            =   240
      Top             =   1680
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   327681
   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         =   "Ver e-mail"
      Height          =   435
      Left            =   3480
      TabIndex        =   1
      Top             =   1740
      Width           =   1035
   End
   Begin VB.CommandButton cmdAceptar 
      Caption         =   "Aceptar"
      Default         =   -1  'True
      Height          =   435
      Left            =   2280
      TabIndex        =   0
      Top             =   1740
      Width           =   1035
   End
   Begin VB.Timer tmrCheck 
      Interval        =   60000
      Left            =   720
      Top             =   1680
   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            =   1200
      TabIndex        =   4
      Top             =   60
      Width           =   2595
   End
   Begin VB.Image imgNewMail 
      Height          =   675
      Left            =   180
      Top             =   360
      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            =   960
      TabIndex        =   2
      Top             =   360
      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 = "About ..."
    mnuOptionsCheckNow.Caption = "Check Now!!"
    mnuOptionsCerrar.Caption = "Exit"
    mnuOptionsExecutemail.Caption = "Run e-mail program"
    mnuOptionsConfigurar.Caption = "Configure ..."
    mnuOptionsHabilitado.Caption = "Enabled"
    
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
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
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()
    Unload Me
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 = LoadResString(Language + 12) + " " + cantmensajes + " " + LoadResString(Language + 13)
    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